├── .gitignore ├── LispLib ├── LispLib.vcxproj ├── LispLib.vcxproj.filters ├── LuaLib.sln ├── lisp.c └── lisp.h ├── NtLisp.sln ├── NtLisp ├── NtLisp.vcxproj ├── NtLisp.vcxproj.filters ├── crt │ ├── crt.h │ ├── io.c │ ├── libmd.h │ ├── libmd │ │ ├── __cos.c │ │ ├── __expo2.c │ │ ├── __rem_pio2.c │ │ ├── __rem_pio2_large.c │ │ ├── __sin.c │ │ ├── __tan.c │ │ ├── _fltused.c │ │ ├── acos.c │ │ ├── acosh.c │ │ ├── asin.c │ │ ├── asinh.c │ │ ├── atan.c │ │ ├── atan2.c │ │ ├── atanh.c │ │ ├── ceil.c │ │ ├── copysign.c │ │ ├── cos.c │ │ ├── cosh.c │ │ ├── erf.c │ │ ├── exp.c │ │ ├── expm1.c │ │ ├── fabs.c │ │ ├── floor.c │ │ ├── fmod.c │ │ ├── fpclassify.c │ │ ├── frexp.c │ │ ├── ldexp.c │ │ ├── lgamma.c │ │ ├── log.c │ │ ├── log10.c │ │ ├── log1p.c │ │ ├── modf.c │ │ ├── nearbyint.c │ │ ├── pow.c │ │ ├── rint.c │ │ ├── scalbn.c │ │ ├── signbit.c │ │ ├── sin.c │ │ ├── sinh.c │ │ ├── sqrt.c │ │ ├── tan.c │ │ ├── tanh.c │ │ ├── tgamma.c │ │ └── trunc.c │ ├── memory.cpp │ ├── misc.c │ ├── stdint.h │ └── string.c ├── driver_io.hpp ├── logger.hpp └── main.cpp ├── NtLispRepl ├── NtLispRepl.vcxproj ├── NtLispRepl.vcxproj.filters └── main.cpp ├── README.md └── vmware_03-17-34.png /.gitignore: -------------------------------------------------------------------------------- 1 | *.db 2 | *.ipch 3 | *.opendb 4 | *.user 5 | *.log 6 | *.exe 7 | *.tlog 8 | *.obj 9 | *.exp 10 | *.pdb 11 | *.lib 12 | *.suo 13 | *.ilk 14 | *.db-shm 15 | *.db-wal 16 | .vs/ 17 | Debug/ 18 | Release/ 19 | x64/ 20 | -------------------------------------------------------------------------------- /LispLib/LispLib.vcxproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Debug 6 | Win32 7 | 8 | 9 | Release 10 | Win32 11 | 12 | 13 | Debug 14 | x64 15 | 16 | 17 | Release 18 | x64 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 16.0 29 | {71FC9FC1-F46F-41D4-913E-07298D6E8220} 30 | Win32Proj 31 | LuaLib 32 | 10.0.19041.0 33 | 34 | 35 | 36 | StaticLibrary 37 | true 38 | WindowsKernelModeDriver10.0 39 | Unicode 40 | 41 | 42 | StaticLibrary 43 | false 44 | WindowsKernelModeDriver10.0 45 | true 46 | Unicode 47 | 48 | 49 | StaticLibrary 50 | true 51 | WindowsKernelModeDriver10.0 52 | Unicode 53 | 54 | 55 | StaticLibrary 56 | false 57 | WindowsKernelModeDriver10.0 58 | true 59 | Unicode 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | true 81 | $(IncludePath);$(KMDF_INC_PATH)$(KMDF_VER_PATH); 82 | $(DDK_LibraryPath_DDKPlatform);$(LibraryPath) 83 | 84 | 85 | true 86 | $(IncludePath);$(KMDF_INC_PATH)$(KMDF_VER_PATH) 87 | $(DDK_LibraryPath_DDKPlatform);$(LibraryPath); 88 | 89 | 90 | false 91 | $(IncludePath);$(KMDF_INC_PATH)$(KMDF_VER_PATH); 92 | $(DDK_LibraryPath_DDKPlatform);$(LibraryPath) 93 | 94 | 95 | false 96 | $(IncludePath);$(KMDF_INC_PATH)$(KMDF_VER_PATH) 97 | $(DDK_LibraryPath_DDKPlatform);$(LibraryPath); 98 | 99 | 100 | 101 | NotUsing 102 | Level3 103 | true 104 | WIN32;_DEBUG;_LIB;%(PreprocessorDefinitions) 105 | true 106 | pch.h 107 | false 108 | 109 | 110 | Windows 111 | true 112 | 113 | 114 | true 115 | 116 | 117 | 118 | 119 | NotUsing 120 | Level3 121 | true 122 | _NO_CRT_STDIO_INLINE;_CRT_SECURE_NO_WARNINGS;_DEBUG;_LIB;%(PreprocessorDefinitions) 123 | true 124 | pch.h 125 | false 126 | 127 | 128 | Windows 129 | true 130 | 131 | 132 | 133 | 134 | true 135 | 136 | 137 | 138 | 139 | NotUsing 140 | Level3 141 | true 142 | true 143 | true 144 | WIN32;NDEBUG;_LIB;%(PreprocessorDefinitions) 145 | true 146 | pch.h 147 | false 148 | 149 | 150 | Windows 151 | true 152 | true 153 | true 154 | 155 | 156 | true 157 | 158 | 159 | 160 | 161 | NotUsing 162 | Level3 163 | true 164 | true 165 | true 166 | _NO_CRT_STDIO_INLINE;_CRT_SECURE_NO_WARNINGS;NDEBUG;_LIB;%(PreprocessorDefinitions) 167 | true 168 | pch.h 169 | false 170 | 171 | 172 | Windows 173 | true 174 | true 175 | true 176 | 177 | 178 | 179 | 180 | true 181 | 182 | 183 | 184 | 185 | 186 | -------------------------------------------------------------------------------- /LispLib/LispLib.vcxproj.filters: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /LispLib/LuaLib.sln: -------------------------------------------------------------------------------- 1 | 2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio Version 16 4 | VisualStudioVersion = 16.0.29709.97 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "LuaLib", "LuaLib.vcxproj", "{71FC9FC1-F46F-41D4-913E-07298D6E8220}" 7 | EndProject 8 | Global 9 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 10 | Debug|x64 = Debug|x64 11 | Debug|x86 = Debug|x86 12 | Release|x64 = Release|x64 13 | Release|x86 = Release|x86 14 | EndGlobalSection 15 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 16 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x64.ActiveCfg = Debug|x64 17 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x64.Build.0 = Debug|x64 18 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x86.ActiveCfg = Debug|Win32 19 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x86.Build.0 = Debug|Win32 20 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x64.ActiveCfg = Release|x64 21 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x64.Build.0 = Release|x64 22 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x86.ActiveCfg = Release|Win32 23 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x86.Build.0 = Release|Win32 24 | EndGlobalSection 25 | GlobalSection(SolutionProperties) = preSolution 26 | HideSolutionNode = FALSE 27 | EndGlobalSection 28 | GlobalSection(ExtensibilityGlobals) = postSolution 29 | SolutionGuid = {0E812DA3-D166-4D3C-9218-E8BB24A7A288} 30 | EndGlobalSection 31 | EndGlobal 32 | -------------------------------------------------------------------------------- /LispLib/lisp.h: -------------------------------------------------------------------------------- 1 | #ifndef LISP_H 2 | #define LISP_H 3 | 4 | /* https://github.com/justinmeiners/lisp-interpreter 5 | Created By: Justin Meiners (https://justinmeiners.github.io) 6 | License: MIT 7 | 8 | Build without standard library. (subset of MIT Scheme) 9 | The basic manipulation functions are still available in C. 10 | #define LISP_NO_LIB 1 11 | 12 | Build without functions which give lisp access to the system, 13 | such as file access. 14 | #define LISP_NO_SYSTEM_LIB 1 15 | 16 | Additional options: override how much data 17 | the parser reads into memory at once from a file. 18 | #define LISP_FILE_CHUNK_SIZE 4096 19 | 20 | */ 21 | 22 | #include 23 | 24 | #define LISP_DEBUG 0 25 | #define LISP_NO_SYSTEM_LIB 1 26 | 27 | /* how much data the parser reads 28 | into memory at once from a file */ 29 | #define LISP_FILE_CHUNK_SIZE 4096 30 | 31 | 32 | typedef enum 33 | { 34 | LISP_NULL = 0, 35 | LISP_REAL, // decimal/floating point type 36 | LISP_INT, // integer type 37 | LISP_CHAR, 38 | LISP_PAIR, // cons pair (car, cdr) 39 | LISP_SYMBOL, // unquoted strings 40 | LISP_STRING, // quoted strings 41 | LISP_LAMBDA, // user defined lambda 42 | LISP_FUNC, // C function 43 | LISP_TABLE, // key/value storage 44 | LISP_VECTOR, // heterogenous array but contiguous allocation 45 | } LispType; 46 | 47 | typedef enum 48 | { 49 | LISP_ERROR_NONE = 0, 50 | LISP_ERROR_FILE_OPEN, 51 | LISP_ERROR_PAREN_UNEXPECTED, 52 | LISP_ERROR_PAREN_EXPECTED, 53 | LISP_ERROR_DOT_UNEXPECTED, 54 | LISP_ERROR_BAD_TOKEN, 55 | 56 | LISP_ERROR_BAD_QUOTE, 57 | LISP_ERROR_BAD_DEFINE, 58 | LISP_ERROR_BAD_SET, 59 | LISP_ERROR_BAD_COND, 60 | LISP_ERROR_BAD_AND, 61 | LISP_ERROR_BAD_OR, 62 | LISP_ERROR_BAD_LET, 63 | LISP_ERROR_BAD_LAMBDA, 64 | 65 | LISP_ERROR_UNKNOWN_VAR, 66 | LISP_ERROR_BAD_OP, 67 | LISP_ERROR_UNKNOWN_EVAL, 68 | LISP_ERROR_OUT_OF_BOUNDS, 69 | 70 | LISP_ERROR_BAD_ARG, 71 | } LispError; 72 | 73 | typedef struct 74 | { 75 | union LispVal 76 | { 77 | float real_val; 78 | int int_val; 79 | void* ptr_val; 80 | } val; 81 | 82 | LispType type; 83 | } Lisp; 84 | 85 | typedef struct 86 | { 87 | struct LispImpl* impl; 88 | } LispContext; 89 | 90 | typedef Lisp(*LispCFunc)(Lisp, LispError*, LispContext); 91 | 92 | /* no need to change these, just use the _opt variant */ 93 | #define LISP_DEFAULT_SYMBOL_TABLE_SIZE 512 94 | #define LISP_DEFAULT_PAGE_SIZE 32768 95 | #define LISP_DEFAULT_STACK_DEPTH 1024 96 | 97 | // SETUP 98 | // ----------------------------------------- 99 | #ifndef LISP_NO_LIB 100 | LispContext lisp_init_lib(void); 101 | LispContext lisp_init_lib_opt(int symbol_table_size, size_t stack_depth, size_t page_size); 102 | #endif 103 | 104 | LispContext lisp_init_empty(void); 105 | LispContext lisp_init_empty_opt(int symbol_table_size, size_t stack_depth, size_t page_size); 106 | void lisp_shutdown(LispContext ctx); 107 | 108 | // garbage collection. 109 | // this will free all objects which are not reachable from root_to_save or the global env 110 | Lisp lisp_collect(Lisp root_to_save, LispContext ctx); 111 | 112 | // REPL 113 | // ----------------------------------------- 114 | 115 | // reads text raw s-expressions. But does not apply any syntax expansions (equivalent to quoting the whole structure). 116 | // This is primarily for using Lisp as JSON/XML 117 | // For code call expand after reading 118 | Lisp lisp_read(const char* text, LispError* out_error, LispContext ctx); 119 | Lisp lisp_read_file(FILE* file, LispError* out_error, LispContext ctx); 120 | Lisp lisp_read_path(const char* path, LispError* out_error, LispContext ctx); 121 | 122 | // expands special Lisp forms (For code) 123 | // The default eval will do this for you, but this can prepare statements 124 | // that are run multiple times 125 | Lisp lisp_expand(Lisp lisp, LispError* out_error, LispContext ctx); 126 | 127 | // evaluate a lisp expression 128 | Lisp lisp_eval_opt(Lisp expr, Lisp env, LispError* out_error, LispContext ctx); 129 | // same as above but uses global environment 130 | Lisp lisp_eval(Lisp expr, LispError* out_error, LispContext ctx); 131 | 132 | // print out a lisp structure 133 | void lisp_print(Lisp l); 134 | void lisp_printf(FILE* file, Lisp l); 135 | const char* lisp_error_string(LispError error); 136 | 137 | // DATA STRUCTURES 138 | // ----------------------------------------- 139 | #define lisp_type(x) ((x).type) 140 | #define lisp_eq(a, b) ((a).val.ptr_val == (b).val.ptr_val) 141 | int lisp_eq_r(Lisp a, Lisp b); 142 | Lisp lisp_make_null(void); 143 | 144 | #define lisp_is_null(x) ((x).type == LISP_NULL) 145 | 146 | Lisp lisp_make_int(int n); 147 | int lisp_int(Lisp x); 148 | 149 | Lisp lisp_make_real(float x); 150 | float lisp_real(Lisp x); 151 | 152 | Lisp lisp_make_string(const char* c_string, LispContext ctx); 153 | Lisp lisp_make_empty_string(unsigned int n, char c, LispContext ctx); 154 | char lisp_string_ref(Lisp s, int n); 155 | void lisp_string_set(Lisp s, int n, char c); 156 | char* lisp_string(Lisp s); 157 | 158 | Lisp lisp_make_char(int c); 159 | int lisp_char(Lisp l); 160 | 161 | Lisp lisp_make_symbol(const char* symbol, LispContext ctx); 162 | const char* lisp_symbol(Lisp x); 163 | 164 | Lisp lisp_car(Lisp p); 165 | Lisp lisp_cdr(Lisp p); 166 | void lisp_set_car(Lisp p, Lisp x); 167 | void lisp_set_cdr(Lisp p, Lisp x); 168 | Lisp lisp_cons(Lisp car, Lisp cdr, LispContext ctx); 169 | #define lisp_is_pair(p) ((p).type == LISP_PAIR) 170 | 171 | Lisp lisp_list_copy(Lisp x, LispContext ctx); 172 | Lisp lisp_make_list(Lisp x, int n, LispContext ctx); 173 | // convenience function for cons'ing together items. arguments must be null terminated 174 | Lisp lisp_make_listv(LispContext ctx, Lisp first, ...); 175 | // another helpful list building technique O(1) 176 | void lisp_fast_append(Lisp* front, Lisp* back, Lisp x, LispContext ctx); 177 | Lisp lisp_list_append(Lisp l, Lisp tail, LispContext ctx); // O(n) 178 | Lisp lisp_list_advance(Lisp l, int i); // O(n) 179 | Lisp lisp_list_ref(Lisp l, int i); // O(n) 180 | int lisp_list_index_of(Lisp l, Lisp x); // O(n) 181 | int lisp_list_length(Lisp l); // O(n) 182 | // given a list of pairs ((key1 val1) (key2 val2) ... (keyN valN)) 183 | // returns the pair with the given key or null of none 184 | Lisp lisp_list_assoc(Lisp l, Lisp key); // O(n) 185 | // given a list of pairs returns the value of the pair with the given key. (car (cdr (assoc ..))) 186 | Lisp lisp_list_for_key(Lisp l, Lisp key); // O(n) 187 | // concise CAR/CDR combos such as CADR, CAAADR, CAAADAAR.... 188 | Lisp lisp_list_nav(Lisp p, const char* path); 189 | // This operation modifys the list 190 | Lisp lisp_list_reverse(Lisp l); // O(n) 191 | 192 | Lisp lisp_make_vector(unsigned int n, Lisp x, LispContext ctx); 193 | int lisp_vector_length(Lisp v); 194 | Lisp lisp_vector_ref(Lisp v, int i); 195 | void lisp_vector_set(Lisp v, int i, Lisp x); 196 | Lisp lisp_vector_assoc(Lisp v, Lisp key); // O(n) 197 | Lisp lisp_vector_grow(Lisp v, unsigned int n, LispContext ctx); 198 | Lisp lisp_subvector(Lisp old, int start, int end, LispContext ctx); 199 | 200 | Lisp lisp_make_table(unsigned int capacity, LispContext ctx); 201 | void lisp_table_set(Lisp t, Lisp key, Lisp x, LispContext ctx); 202 | // returns the key value pair, or null if not found 203 | Lisp lisp_table_get(Lisp t, Lisp key, LispContext ctx); 204 | unsigned int lisp_table_size(Lisp t); 205 | Lisp lisp_table_to_assoc_list(Lisp t, LispContext ctx); 206 | 207 | /* This struct is just for making definitions a little less error prone, 208 | having separate arrays for names and functions leads to easy mistakes. */ 209 | typedef struct 210 | { 211 | const char* name; 212 | LispCFunc func_ptr; 213 | } LispFuncDef; 214 | void lisp_table_define_funcs(Lisp t, const LispFuncDef* defs, LispContext ctx); 215 | 216 | // programatically generate compound procedures 217 | Lisp lisp_make_lambda(Lisp args, Lisp body, Lisp env, LispContext ctx); 218 | 219 | // C functions 220 | Lisp lisp_make_func(LispCFunc func_ptr); 221 | LispCFunc lisp_func(Lisp l); 222 | 223 | // evaluation environments 224 | Lisp lisp_env_global(LispContext ctx); 225 | void lisp_env_set_global(Lisp env, LispContext ctx); 226 | 227 | Lisp lisp_env_extend(Lisp l, Lisp table, LispContext ctx); 228 | Lisp lisp_env_lookup(Lisp l, Lisp key, LispContext ctx); 229 | void lisp_env_define(Lisp l, Lisp key, Lisp x, LispContext ctx); 230 | void lisp_env_set(Lisp l, Lisp key, Lisp x, LispContext ctx); 231 | 232 | #endif 233 | -------------------------------------------------------------------------------- /NtLisp.sln: -------------------------------------------------------------------------------- 1 | 2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio Version 16 4 | VisualStudioVersion = 16.0.29709.97 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "LispLib", "LispLib\LispLib.vcxproj", "{71FC9FC1-F46F-41D4-913E-07298D6E8220}" 7 | EndProject 8 | Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "NtLispRepl", "NtLispRepl\NtLispRepl.vcxproj", "{82B12053-4DA0-440B-8AF4-55F49658299E}" 9 | EndProject 10 | Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "NtLisp", "NtLisp\NtLisp.vcxproj", "{7FAC530A-63E4-4C27-86E1-B318205E4C0E}" 11 | EndProject 12 | Global 13 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 14 | Debug|x64 = Debug|x64 15 | Debug|x86 = Debug|x86 16 | Release|x64 = Release|x64 17 | Release|x86 = Release|x86 18 | EndGlobalSection 19 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 20 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x64.ActiveCfg = Debug|x64 21 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x64.Build.0 = Debug|x64 22 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x64.Deploy.0 = Debug|x64 23 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x86.ActiveCfg = Debug|Win32 24 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x86.Build.0 = Debug|Win32 25 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Debug|x86.Deploy.0 = Debug|Win32 26 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x64.ActiveCfg = Release|x64 27 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x64.Build.0 = Release|x64 28 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x64.Deploy.0 = Release|x64 29 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x86.ActiveCfg = Release|Win32 30 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x86.Build.0 = Release|Win32 31 | {71FC9FC1-F46F-41D4-913E-07298D6E8220}.Release|x86.Deploy.0 = Release|Win32 32 | {82B12053-4DA0-440B-8AF4-55F49658299E}.Debug|x64.ActiveCfg = Debug|x64 33 | {82B12053-4DA0-440B-8AF4-55F49658299E}.Debug|x64.Build.0 = Debug|x64 34 | {82B12053-4DA0-440B-8AF4-55F49658299E}.Debug|x86.ActiveCfg = Debug|Win32 35 | {82B12053-4DA0-440B-8AF4-55F49658299E}.Debug|x86.Build.0 = Debug|Win32 36 | {82B12053-4DA0-440B-8AF4-55F49658299E}.Release|x64.ActiveCfg = Release|x64 37 | {82B12053-4DA0-440B-8AF4-55F49658299E}.Release|x64.Build.0 = Release|x64 38 | {82B12053-4DA0-440B-8AF4-55F49658299E}.Release|x86.ActiveCfg = Release|Win32 39 | {82B12053-4DA0-440B-8AF4-55F49658299E}.Release|x86.Build.0 = Release|Win32 40 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Debug|x64.ActiveCfg = Debug|x64 41 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Debug|x64.Build.0 = Debug|x64 42 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Debug|x64.Deploy.0 = Debug|x64 43 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Debug|x86.ActiveCfg = Debug|Win32 44 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Debug|x86.Build.0 = Debug|Win32 45 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Debug|x86.Deploy.0 = Debug|Win32 46 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Release|x64.ActiveCfg = Release|x64 47 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Release|x64.Build.0 = Release|x64 48 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Release|x64.Deploy.0 = Release|x64 49 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Release|x86.ActiveCfg = Release|Win32 50 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Release|x86.Build.0 = Release|Win32 51 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E}.Release|x86.Deploy.0 = Release|Win32 52 | EndGlobalSection 53 | GlobalSection(SolutionProperties) = preSolution 54 | HideSolutionNode = FALSE 55 | EndGlobalSection 56 | GlobalSection(ExtensibilityGlobals) = postSolution 57 | SolutionGuid = {F86C24F0-ACB0-423E-9DBC-C1B65F86BC4A} 58 | EndGlobalSection 59 | EndGlobal 60 | -------------------------------------------------------------------------------- /NtLisp/NtLisp.vcxproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Debug 6 | Win32 7 | 8 | 9 | Release 10 | Win32 11 | 12 | 13 | Debug 14 | x64 15 | 16 | 17 | Release 18 | x64 19 | 20 | 21 | 22 | {7FAC530A-63E4-4C27-86E1-B318205E4C0E} 23 | {1bc93793-694f-48fe-9372-81e2b05556fd} 24 | v4.5 25 | 12.0 26 | Debug 27 | Win32 28 | KernelLuaVm 29 | 10.0.19041.0 30 | 31 | 32 | 33 | Windows10 34 | true 35 | WindowsKernelModeDriver10.0 36 | Driver 37 | KMDF 38 | Universal 39 | 40 | 41 | Windows10 42 | false 43 | WindowsKernelModeDriver10.0 44 | Driver 45 | KMDF 46 | Universal 47 | 48 | 49 | Windows10 50 | true 51 | WindowsKernelModeDriver10.0 52 | Driver 53 | KMDF 54 | Universal 55 | 56 | 57 | Windows10 58 | false 59 | WindowsKernelModeDriver10.0 60 | Driver 61 | KMDF 62 | Universal 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | DbgengKernelDebugger 74 | $(SolutionDir)..\LispLib;$(IncludePath);$(KMDF_INC_PATH)$(KMDF_VER_PATH) 75 | 76 | 77 | DbgengKernelDebugger 78 | $(SolutionDir)..\LispLib;$(IncludePath);$(KMDF_INC_PATH)$(KMDF_VER_PATH) 79 | 80 | 81 | DbgengKernelDebugger 82 | $(SolutionDir)LispLib;$(IncludePath);$(KMDF_INC_PATH)$(KMDF_VER_PATH) 83 | 84 | 85 | DbgengKernelDebugger 86 | $(SolutionDir)LispLib;$(IncludePath);$(KMDF_INC_PATH)$(KMDF_VER_PATH) 87 | 88 | 89 | 90 | false 91 | CompileAsCpp 92 | false 93 | false 94 | false 95 | stdcpp17 96 | _DEBUG;_X86_=1;i386=1;STD_CALL;%(PreprocessorDefinitions) 97 | 98 | 99 | false 100 | 101 | 102 | 103 | 104 | false 105 | CompileAsCpp 106 | false 107 | false 108 | stdcpp17 109 | 110 | 111 | false 112 | 113 | 114 | 115 | 116 | false 117 | CompileAsCpp 118 | false 119 | false 120 | false 121 | stdcpp17 122 | _DEBUG;_WIN64;_AMD64_;AMD64;%(PreprocessorDefinitions) 123 | 124 | 125 | false 126 | 127 | 128 | 129 | 130 | false 131 | CompileAsCpp 132 | false 133 | false 134 | stdcpp17 135 | /Oi- %(AdditionalOptions) 136 | 137 | 138 | false 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | {71fc9fc1-f46f-41d4-913e-07298d6e8220} 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | CppCode 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | -------------------------------------------------------------------------------- /NtLisp/NtLisp.vcxproj.filters: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | crt\libmd 7 | 8 | 9 | crt\libmd 10 | 11 | 12 | crt\libmd 13 | 14 | 15 | crt\libmd 16 | 17 | 18 | crt\libmd 19 | 20 | 21 | crt\libmd 22 | 23 | 24 | crt\libmd 25 | 26 | 27 | crt\libmd 28 | 29 | 30 | crt\libmd 31 | 32 | 33 | crt\libmd 34 | 35 | 36 | crt\libmd 37 | 38 | 39 | crt\libmd 40 | 41 | 42 | crt\libmd 43 | 44 | 45 | crt\libmd 46 | 47 | 48 | crt\libmd 49 | 50 | 51 | crt\libmd 52 | 53 | 54 | crt\libmd 55 | 56 | 57 | crt\libmd 58 | 59 | 60 | crt\libmd 61 | 62 | 63 | crt\libmd 64 | 65 | 66 | crt\libmd 67 | 68 | 69 | crt\libmd 70 | 71 | 72 | crt\libmd 73 | 74 | 75 | crt\libmd 76 | 77 | 78 | crt\libmd 79 | 80 | 81 | crt\libmd 82 | 83 | 84 | crt\libmd 85 | 86 | 87 | crt\libmd 88 | 89 | 90 | crt\libmd 91 | 92 | 93 | crt\libmd 94 | 95 | 96 | crt\libmd 97 | 98 | 99 | crt\libmd 100 | 101 | 102 | crt\libmd 103 | 104 | 105 | crt\libmd 106 | 107 | 108 | crt\libmd 109 | 110 | 111 | crt\libmd 112 | 113 | 114 | crt\libmd 115 | 116 | 117 | crt\libmd 118 | 119 | 120 | crt\libmd 121 | 122 | 123 | crt\libmd 124 | 125 | 126 | crt\libmd 127 | 128 | 129 | crt\libmd 130 | 131 | 132 | crt\libmd 133 | 134 | 135 | crt\libmd 136 | 137 | 138 | crt\misc 139 | 140 | 141 | crt\misc 142 | 143 | 144 | crt\misc 145 | 146 | 147 | crt\misc 148 | 149 | 150 | 151 | 152 | {34fc80ff-2c2f-48ce-bc9d-e58bed8bd8c5} 153 | 154 | 155 | {d020440f-50cc-4ecd-bb74-30ed1469974b} 156 | 157 | 158 | {51d27d14-edb0-4590-bb60-8e20b89d3a8a} 159 | 160 | 161 | 162 | 163 | crt 164 | 165 | 166 | crt\misc 167 | 168 | 169 | crt\misc 170 | 171 | 172 | 173 | 174 | -------------------------------------------------------------------------------- /NtLisp/crt/crt.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #define _INC_STDIO 3 | #include 4 | #include 5 | #include 6 | #include "stdint.h" 7 | #include "libmd.h" 8 | 9 | #define FILE_STDOUT ((FILE*)0x13370001) 10 | #define FILE_STDERR ((FILE*)0x13370002) 11 | 12 | // CRT initializers. 13 | // 14 | #pragma section(".CRT", read) 15 | using fn_crt_initializer = void(*)(); 16 | __declspec( allocate( ".CRT" ) ) static const fn_crt_initializer crt_tracker = nullptr; 17 | 18 | namespace crt 19 | { 20 | static void initialize() 21 | { 22 | const fn_crt_initializer* entry = &crt_tracker; 23 | while ( *++entry ) 24 | ( *entry )( ); 25 | } 26 | }; 27 | 28 | // C++ memory decleration. 29 | // 30 | __declspec( restrict ) void* malloc( size_t n ); 31 | void free( void* p ); 32 | void* operator new( size_t, void* where ); 33 | void* operator new( size_t Size ); 34 | void* operator new[ ] ( size_t Size ); 35 | void operator delete( void* Adr ); 36 | void operator delete( void* Adr, size_t Size ); 37 | void operator delete[ ] ( void* Adr ); 38 | void operator delete[ ] ( void* Adr, size_t Size ); 39 | 40 | extern "C" 41 | { 42 | // String utils. 43 | // 44 | int isalpha( int c ); 45 | int isdigit( int c ); 46 | int isalnum( int c ); 47 | int iscntrl( int c ); 48 | int isgraph( int c ); 49 | int ispunct( int c ); 50 | __declspec( dllimport ) int sscanf_s( const char* buffer, const char* format, ... ); // @ ntoskrnl.lib 51 | __declspec( dllimport ) int sprintf_s( char* buffer, size_t sizeOfBuffer, const char* format, ... ); // @ ntoskrnl.lib 52 | double strtod( const char* str, const char** endptr ); 53 | char* strpbrk( const char* s1, const char* s2 ); 54 | int strcoll( const char* a, const char* b ); 55 | 56 | // IO utils. 57 | // 58 | typedef struct _FILE {} FILE; // Maybe it will be implemented one day. 59 | 60 | FILE* __cdecl __acrt_iob_func( unsigned i ); 61 | FILE* freopen( const char* filename, const char* mode, FILE* stream ); 62 | size_t fwrite( const void* ptr, size_t size, size_t count, FILE* stream ); 63 | size_t fread( void* ptr, size_t size, size_t count, FILE* stream ); 64 | int getc( FILE* stream ); 65 | FILE* fopen( const char* filename, const char* mode ); 66 | int fflush( FILE* stream ); 67 | int ferror( FILE* stream ); 68 | int feof( FILE* stream ); 69 | int fclose( FILE* stream ); 70 | int fprintf( FILE* stream, const char* fmt, ... ); 71 | 72 | // Misc. functions. 73 | // 74 | void abort(); 75 | char* getenv(); 76 | }; -------------------------------------------------------------------------------- /NtLisp/crt/io.c: -------------------------------------------------------------------------------- 1 | #include "../logger.hpp" 2 | #include "crt.h" 3 | 4 | FILE* __cdecl __acrt_iob_func( unsigned i ) 5 | { 6 | if ( i == 1 ) return FILE_STDOUT; 7 | if ( i == 2 ) return FILE_STDERR; 8 | return 0; 9 | } 10 | 11 | FILE* freopen( const char* filename, const char* mode, FILE* stream ) 12 | { 13 | return 0; 14 | } 15 | 16 | size_t fwrite( const void* ptr, size_t size, size_t count, FILE* stream ) 17 | { 18 | if ( stream == FILE_STDOUT ) 19 | { 20 | logger::logs.append( ptr, size * count ); 21 | return count; 22 | } 23 | else if ( stream == FILE_STDERR ) 24 | { 25 | logger::errors.append( ptr, size * count ); 26 | return count; 27 | } 28 | return 0; 29 | } 30 | 31 | size_t fread( void* ptr, size_t size, size_t count, FILE* stream ) 32 | { 33 | return 0; 34 | } 35 | 36 | int getc( FILE* stream ) 37 | { 38 | return -1; 39 | } 40 | 41 | FILE* fopen( const char* filename, const char* mode ) 42 | { 43 | return 0; 44 | } 45 | 46 | int fflush( FILE* stream ) 47 | { 48 | return 0; 49 | } 50 | 51 | int ferror( FILE* stream ) 52 | { 53 | return 1; 54 | } 55 | 56 | int feof( FILE* stream ) 57 | { 58 | return 1; 59 | } 60 | 61 | int fclose( FILE* stream ) 62 | { 63 | return 1; 64 | } 65 | 66 | #include 67 | 68 | extern "C" __declspec(dllimport) int _vsnprintf( char* dest, size_t count, const char* fmt, va_list args ); 69 | 70 | int fprintf( FILE* stream, const char* fmt, ... ) 71 | { 72 | va_list args; 73 | va_start( args, fmt ); 74 | char buf[512] = ""; 75 | auto n = _vsnprintf( buf, sizeof( buf ), fmt, args ); 76 | if ( n >= sizeof(buf) ) 77 | { 78 | // todo: allocate things 79 | __debugbreak(); 80 | } 81 | va_end( args ); 82 | fwrite( buf, n, 1, stream ); 83 | return 1; 84 | } -------------------------------------------------------------------------------- /NtLisp/crt/libmd.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include "stdint.h" 4 | 5 | extern "C" 6 | { 7 | extern char _fltused; 8 | 9 | typedef double double_t; 10 | typedef float float_t; 11 | 12 | #define FLT_EVAL_METHOD 0 13 | 14 | #ifndef _HUGE_ENUF 15 | #define _HUGE_ENUF 1e+300 // _HUGE_ENUF*_HUGE_ENUF must overflow 16 | #endif 17 | 18 | #define INFINITY ((float)(_HUGE_ENUF * _HUGE_ENUF)) 19 | #define HUGE_VAL ((double)INFINITY) 20 | #define HUGE_VALF ((float)INFINITY) 21 | #define HUGE_VALL ((long double)INFINITY) 22 | #define NAN ((float)(INFINITY * 0.0F)) 23 | 24 | #define _DENORM (-2) 25 | #define _FINITE (-1) 26 | #define _INFCODE 1 27 | #define _NANCODE 2 28 | 29 | #define FP_INFINITE _INFCODE 30 | #define FP_NAN _NANCODE 31 | #define FP_NORMAL _FINITE 32 | #define FP_SUBNORMAL _DENORM 33 | #define FP_ZERO 0 34 | 35 | #define isinf(x) (fpclassify(x)==FP_INFINITE) 36 | #define isnan(x) (fpclassify(x)==FP_NAN) 37 | #define isfinite(x) (fpclassify(x)!=FP_NAN && fpclassify(x)!=FP_INFINITE ) 38 | #define isnormal(x) (fpclassify(x)==FP_NORMAL) 39 | 40 | 41 | #define _C2 1 // 0 if not 2's complement 42 | #define FP_ILOGB0 (-0x7fffffff - _C2) 43 | #define FP_ILOGBNAN 0x7fffffff 44 | 45 | #define MATH_ERRNO 1 46 | #define MATH_ERREXCEPT 2 47 | #define math_errhandling (MATH_ERRNO | MATH_ERREXCEPT) 48 | 49 | // Values for use as arguments to the _fperrraise function 50 | #define _FE_DIVBYZERO 0x04 51 | #define _FE_INEXACT 0x20 52 | #define _FE_INVALID 0x01 53 | #define _FE_OVERFLOW 0x08 54 | #define _FE_UNDERFLOW 0x10 55 | 56 | #define _D0_C 3 // little-endian, small long doubles 57 | #define _D1_C 2 58 | #define _D2_C 1 59 | #define _D3_C 0 60 | 61 | #define _DBIAS 0x3fe 62 | #define _DOFF 4 63 | 64 | #define _F0_C 1 // little-endian 65 | #define _F1_C 0 66 | 67 | #define _FBIAS 0x7e 68 | #define _FOFF 7 69 | #define _FRND 1 70 | 71 | #define _L0_C 3 // little-endian, 64-bit long doubles 72 | #define _L1_C 2 73 | #define _L2_C 1 74 | #define _L3_C 0 75 | 76 | #define _LBIAS 0x3fe 77 | #define _LOFF 4 78 | 79 | // IEEE 754 double properties 80 | #define _DFRAC ((unsigned short)((1 << _DOFF) - 1)) 81 | #define _DMASK ((unsigned short)(0x7fff & ~_DFRAC)) 82 | #define _DMAX ((unsigned short)((1 << (15 - _DOFF)) - 1)) 83 | #define _DSIGN ((unsigned short)0x8000) 84 | 85 | // IEEE 754 float properties 86 | #define _FFRAC ((unsigned short)((1 << _FOFF) - 1)) 87 | #define _FMASK ((unsigned short)(0x7fff & ~_FFRAC)) 88 | #define _FMAX ((unsigned short)((1 << (15 - _FOFF)) - 1)) 89 | #define _FSIGN ((unsigned short)0x8000) 90 | 91 | // IEEE 754 long double properties 92 | #define _LFRAC ((unsigned short)(-1)) 93 | #define _LMASK ((unsigned short)0x7fff) 94 | #define _LMAX ((unsigned short)0x7fff) 95 | #define _LSIGN ((unsigned short)0x8000) 96 | 97 | #define _DHUGE_EXP (int)(_DMAX * 900L / 1000) 98 | #define _FHUGE_EXP (int)(_FMAX * 900L / 1000) 99 | #define _LHUGE_EXP (int)(_LMAX * 900L / 1000) 100 | 101 | #define _DSIGN_C(_Val) (((_double_val *)(char*)&(_Val))->_Sh[_D0_C] & _DSIGN) 102 | #define _FSIGN_C(_Val) (((_float_val *)(char*)&(_Val))->_Sh[_F0_C] & _FSIGN) 103 | #define _LSIGN_C(_Val) (((_ldouble_val*)(char*)&(_Val))->_Sh[_L0_C] & _LSIGN) 104 | 105 | 106 | #define FORCE_EVAL(x) do { \ 107 | if (sizeof(x) == sizeof(float)) { \ 108 | volatile float __x; \ 109 | __x = (x); \ 110 | (void)__x; \ 111 | } else if (sizeof(x) == sizeof(double)) { \ 112 | volatile double __x; \ 113 | __x = (x); \ 114 | (void)__x; \ 115 | } else { \ 116 | volatile long double __x; \ 117 | __x = (x); \ 118 | (void)__x; \ 119 | } \ 120 | } while(0) 121 | 122 | /* Get two 32 bit ints from a double. */ 123 | #define EXTRACT_WORDS(hi,lo,d) \ 124 | do { \ 125 | union {double f; uint64_t i;} __u; \ 126 | __u.f = (d); \ 127 | (hi) = __u.i >> 32; \ 128 | (lo) = (uint32_t)__u.i; \ 129 | } while (0) 130 | 131 | /* Get the more significant 32 bit int from a double. */ 132 | #define GET_HIGH_WORD(hi,d) \ 133 | do { \ 134 | union {double f; uint64_t i;} __u; \ 135 | __u.f = (d); \ 136 | (hi) = __u.i >> 32; \ 137 | } while (0) 138 | 139 | /* Get the less significant 32 bit int from a double. */ 140 | #define GET_LOW_WORD(lo,d) \ 141 | do { \ 142 | union {double f; uint64_t i;} __u; \ 143 | __u.f = (d); \ 144 | (lo) = (uint32_t)__u.i; \ 145 | } while (0) 146 | 147 | /* Set a double from two 32 bit ints. */ 148 | #define INSERT_WORDS(d,hi,lo) \ 149 | do { \ 150 | union {double f; uint64_t i;} __u; \ 151 | __u.i = ((uint64_t)(hi)<<32) | (uint32_t)(lo); \ 152 | (d) = __u.f; \ 153 | } while (0) 154 | 155 | /* Set the more significant 32 bits of a double from an int. */ 156 | #define SET_HIGH_WORD(d,hi) \ 157 | do { \ 158 | union {double f; uint64_t i;} __u; \ 159 | __u.f = (d); \ 160 | __u.i &= 0xffffffff; \ 161 | __u.i |= (uint64_t)(hi) << 32; \ 162 | (d) = __u.f; \ 163 | } while (0) 164 | 165 | /* Set the less significant 32 bits of a double from an int. */ 166 | #define SET_LOW_WORD(d,lo) \ 167 | do { \ 168 | union {double f; uint64_t i;} __u; \ 169 | __u.f = (d); \ 170 | __u.i &= 0xffffffff00000000ull; \ 171 | __u.i |= (uint32_t)(lo); \ 172 | (d) = __u.f; \ 173 | } while (0) 174 | 175 | #define DBL_EPSILON 2.22044604925031308085e-16 176 | 177 | double trunc( double x ); 178 | double tgamma( double x ); 179 | double __lgamma_r( double x, int* sign ); 180 | double sqrt( double x ); 181 | double tanh( double x ); 182 | double tan( double x ); 183 | double sinh( double x ); 184 | double sin( double x ); 185 | double cosh( double x ); 186 | double cos( double x ); 187 | double atanh( double x ); 188 | double atan( double x ); 189 | double asinh( double x ); 190 | double asin( double x ); 191 | double acosh( double x ); 192 | double acos( double x ); 193 | double atan2( double y, double x ); 194 | double scalbn( double x, int n ); 195 | double rint( double x ); 196 | double pow( double x, double y ); 197 | double nearbyint( double x ); 198 | double modf( double x, double* iptr ); 199 | double log( double x ); 200 | double log1p( double x ); 201 | double log10( double x ); 202 | double lgamma( double x ); 203 | double ldexp( double x, int n ); 204 | double frexp( double x, int* e ); 205 | double fmod( double x, double y ); 206 | double floor( double x ); 207 | double expm1( double x ); 208 | double exp( double x ); 209 | double erf( double x ); 210 | double copysign( double x, double y ); 211 | double ceil( double x ); 212 | double __tan( double x, double y, int odd ); 213 | double __sin( double x, double y, int iy ); 214 | int signbit( double x ); 215 | int __rem_pio2_large( double* x, double* y, int e0, int nx, int prec ); 216 | int __rem_pio2( double x, double* y ); 217 | int fpclassify( double x ); 218 | double __expo2( double x ); 219 | double __cos( double x, double y ); 220 | double fabs( double x ); 221 | }; -------------------------------------------------------------------------------- /NtLisp/crt/libmd/__cos.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/k_cos.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunSoft, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* 13 | * __cos( x, y ) 14 | * kernel cos function on [-pi/4, pi/4], pi/4 ~ 0.785398164 15 | * Input x is assumed to be bounded by ~pi/4 in magnitude. 16 | * Input y is the tail of x. 17 | * 18 | * Algorithm 19 | * 1. Since cos(-x) = cos(x), we need only to consider positive x. 20 | * 2. if x < 2^-27 (hx<0x3e400000 0), return 1 with inexact if x!=0. 21 | * 3. cos(x) is approximated by a polynomial of degree 14 on 22 | * [0,pi/4] 23 | * 4 14 24 | * cos(x) ~ 1 - x*x/2 + C1*x + ... + C6*x 25 | * where the remez error is 26 | * 27 | * | 2 4 6 8 10 12 14 | -58 28 | * |cos(x)-(1-.5*x +C1*x +C2*x +C3*x +C4*x +C5*x +C6*x )| <= 2 29 | * | | 30 | * 31 | * 4 6 8 10 12 14 32 | * 4. let r = C1*x +C2*x +C3*x +C4*x +C5*x +C6*x , then 33 | * cos(x) ~ 1 - x*x/2 + r 34 | * since cos(x+y) ~ cos(x) - sin(x)*y 35 | * ~ cos(x) - x*y, 36 | * a correction term is necessary in cos(x) and hence 37 | * cos(x+y) = 1 - (x*x/2 - (r - x*y)) 38 | * For better accuracy, rearrange to 39 | * cos(x+y) ~ w + (tmp + (r-x*y)) 40 | * where w = 1 - x*x/2 and tmp is a tiny correction term 41 | * (1 - x*x/2 == w + tmp exactly in infinite precision). 42 | * The exactness of w + tmp in infinite precision depends on w 43 | * and tmp having the same precision as x. If they have extra 44 | * precision due to compiler bugs, then the extra precision is 45 | * only good provided it is retained in all terms of the final 46 | * expression for cos(). Retention happens in all cases tested 47 | * under FreeBSD, so don't pessimize things by forcibly clipping 48 | * any extra precision in w. 49 | */ 50 | 51 | #include "..\libmd.h" 52 | 53 | static const double 54 | C1 = 4.16666666666666019037e-02, /* 0x3FA55555, 0x5555554C */ 55 | C2 = -1.38888888888741095749e-03, /* 0xBF56C16C, 0x16C15177 */ 56 | C3 = 2.48015872894767294178e-05, /* 0x3EFA01A0, 0x19CB1590 */ 57 | C4 = -2.75573143513906633035e-07, /* 0xBE927E4F, 0x809C52AD */ 58 | C5 = 2.08757232129817482790e-09, /* 0x3E21EE9E, 0xBDB4B1C4 */ 59 | C6 = -1.13596475577881948265e-11; /* 0xBDA8FAE9, 0xBE8838D4 */ 60 | 61 | double __cos(double x, double y) 62 | { 63 | double_t hz,z,r,w; 64 | 65 | z = x*x; 66 | w = z*z; 67 | r = z*(C1+z*(C2+z*C3)) + w*w*(C4+z*(C5+z*C6)); 68 | hz = 0.5*z; 69 | w = 1.0-hz; 70 | return w + (((1.0-w)-hz) + (z*r-x*y)); 71 | } 72 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/__expo2.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | /* k is such that k*ln2 has minimal relative error and x - kln2 > log(DBL_MIN) */ 4 | static const int k = 2043; 5 | static const double kln2 = 0x1.62066151add8bp+10; 6 | 7 | /* exp(x)/2 for x >= log(DBL_MAX), slightly better than 0.5*exp(x/2)*exp(x/2) */ 8 | double __expo2(double x) 9 | { 10 | double scale; 11 | 12 | /* note that k is odd and scale*scale overflows */ 13 | INSERT_WORDS(scale, (uint32_t)(0x3ff + k/2) << 20, 0); 14 | /* exp(x - k ln2) * 2**(k-1) */ 15 | return exp(x - kln2) * scale * scale; 16 | } 17 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/__rem_pio2.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/e_rem_pio2.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunSoft, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | * 12 | * Optimized by Bruce D. Evans. 13 | */ 14 | /* __rem_pio2(x,y) 15 | * 16 | * return the remainder of x rem pi/2 in y[0]+y[1] 17 | * use __rem_pio2_large() for large x 18 | */ 19 | 20 | #include "..\libmd.h" 21 | 22 | #if FLT_EVAL_METHOD==0 || FLT_EVAL_METHOD==1 23 | #define EPS DBL_EPSILON 24 | #elif FLT_EVAL_METHOD==2 25 | #define EPS LDBL_EPSILON 26 | #endif 27 | 28 | /* 29 | * invpio2: 53 bits of 2/pi 30 | * pio2_1: first 33 bit of pi/2 31 | * pio2_1t: pi/2 - pio2_1 32 | * pio2_2: second 33 bit of pi/2 33 | * pio2_2t: pi/2 - (pio2_1+pio2_2) 34 | * pio2_3: third 33 bit of pi/2 35 | * pio2_3t: pi/2 - (pio2_1+pio2_2+pio2_3) 36 | */ 37 | static const double 38 | toint = 1.5/EPS, 39 | invpio2 = 6.36619772367581382433e-01, /* 0x3FE45F30, 0x6DC9C883 */ 40 | pio2_1 = 1.57079632673412561417e+00, /* 0x3FF921FB, 0x54400000 */ 41 | pio2_1t = 6.07710050650619224932e-11, /* 0x3DD0B461, 0x1A626331 */ 42 | pio2_2 = 6.07710050630396597660e-11, /* 0x3DD0B461, 0x1A600000 */ 43 | pio2_2t = 2.02226624879595063154e-21, /* 0x3BA3198A, 0x2E037073 */ 44 | pio2_3 = 2.02226624871116645580e-21, /* 0x3BA3198A, 0x2E000000 */ 45 | pio2_3t = 8.47842766036889956997e-32; /* 0x397B839A, 0x252049C1 */ 46 | 47 | /* caller must handle the case when reduction is not needed: |x| ~<= pi/4 */ 48 | int __rem_pio2(double x, double *y) 49 | { 50 | union {double f; uint64_t i;} u = {x}; 51 | double_t z,w,t,r,fn; 52 | double tx[3],ty[2]; 53 | uint32_t ix; 54 | int sign, n, ex, ey, i; 55 | 56 | sign = u.i>>63; 57 | ix = u.i>>32 & 0x7fffffff; 58 | if (ix <= 0x400f6a7a) { /* |x| ~<= 5pi/4 */ 59 | if ((ix & 0xfffff) == 0x921fb) /* |x| ~= pi/2 or 2pi/2 */ 60 | goto medium; /* cancellation -- use medium case */ 61 | if (ix <= 0x4002d97c) { /* |x| ~<= 3pi/4 */ 62 | if (!sign) { 63 | z = x - pio2_1; /* one round good to 85 bits */ 64 | y[0] = z - pio2_1t; 65 | y[1] = (z-y[0]) - pio2_1t; 66 | return 1; 67 | } else { 68 | z = x + pio2_1; 69 | y[0] = z + pio2_1t; 70 | y[1] = (z-y[0]) + pio2_1t; 71 | return -1; 72 | } 73 | } else { 74 | if (!sign) { 75 | z = x - 2*pio2_1; 76 | y[0] = z - 2*pio2_1t; 77 | y[1] = (z-y[0]) - 2*pio2_1t; 78 | return 2; 79 | } else { 80 | z = x + 2*pio2_1; 81 | y[0] = z + 2*pio2_1t; 82 | y[1] = (z-y[0]) + 2*pio2_1t; 83 | return -2; 84 | } 85 | } 86 | } 87 | if (ix <= 0x401c463b) { /* |x| ~<= 9pi/4 */ 88 | if (ix <= 0x4015fdbc) { /* |x| ~<= 7pi/4 */ 89 | if (ix == 0x4012d97c) /* |x| ~= 3pi/2 */ 90 | goto medium; 91 | if (!sign) { 92 | z = x - 3*pio2_1; 93 | y[0] = z - 3*pio2_1t; 94 | y[1] = (z-y[0]) - 3*pio2_1t; 95 | return 3; 96 | } else { 97 | z = x + 3*pio2_1; 98 | y[0] = z + 3*pio2_1t; 99 | y[1] = (z-y[0]) + 3*pio2_1t; 100 | return -3; 101 | } 102 | } else { 103 | if (ix == 0x401921fb) /* |x| ~= 4pi/2 */ 104 | goto medium; 105 | if (!sign) { 106 | z = x - 4*pio2_1; 107 | y[0] = z - 4*pio2_1t; 108 | y[1] = (z-y[0]) - 4*pio2_1t; 109 | return 4; 110 | } else { 111 | z = x + 4*pio2_1; 112 | y[0] = z + 4*pio2_1t; 113 | y[1] = (z-y[0]) + 4*pio2_1t; 114 | return -4; 115 | } 116 | } 117 | } 118 | if (ix < 0x413921fb) { /* |x| ~< 2^20*(pi/2), medium size */ 119 | medium: 120 | /* rint(x/(pi/2)), Assume round-to-nearest. */ 121 | fn = (double_t)x*invpio2 + toint - toint; 122 | n = (int32_t)fn; 123 | r = x - fn*pio2_1; 124 | w = fn*pio2_1t; /* 1st round, good to 85 bits */ 125 | y[0] = r - w; 126 | u.f = y[0]; 127 | ey = u.i>>52 & 0x7ff; 128 | ex = ix>>20; 129 | if (ex - ey > 16) { /* 2nd round, good to 118 bits */ 130 | t = r; 131 | w = fn*pio2_2; 132 | r = t - w; 133 | w = fn*pio2_2t - ((t-r)-w); 134 | y[0] = r - w; 135 | u.f = y[0]; 136 | ey = u.i>>52 & 0x7ff; 137 | if (ex - ey > 49) { /* 3rd round, good to 151 bits, covers all cases */ 138 | t = r; 139 | w = fn*pio2_3; 140 | r = t - w; 141 | w = fn*pio2_3t - ((t-r)-w); 142 | y[0] = r - w; 143 | } 144 | } 145 | y[1] = (r - y[0]) - w; 146 | return n; 147 | } 148 | /* 149 | * all other (large) arguments 150 | */ 151 | if (ix >= 0x7ff00000) { /* x is inf or NaN */ 152 | y[0] = y[1] = x - x; 153 | return 0; 154 | } 155 | /* set z = scalbn(|x|,-ilogb(x)+23) */ 156 | u.f = x; 157 | u.i &= (uint64_t)-1>>12; 158 | u.i |= (uint64_t)(0x3ff + 23)<<52; 159 | z = u.f; 160 | for (i=0; i < 2; i++) { 161 | tx[i] = (double)(int32_t)z; 162 | z = (z-tx[i])*0x1p24; 163 | } 164 | tx[i] = z; 165 | /* skip zero terms, first term is non-zero */ 166 | while (tx[i] == 0.0) 167 | i--; 168 | n = __rem_pio2_large(tx,ty,(int)(ix>>20)-(0x3ff+23),i+1,1); 169 | if (sign) { 170 | y[0] = -ty[0]; 171 | y[1] = -ty[1]; 172 | return -n; 173 | } 174 | y[0] = ty[0]; 175 | y[1] = ty[1]; 176 | return n; 177 | } 178 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/__rem_pio2_large.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/k_rem_pio2.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunSoft, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* 13 | * __rem_pio2_large(x,y,e0,nx,prec) 14 | * double x[],y[]; int e0,nx,prec; 15 | * 16 | * __rem_pio2_large return the last three digits of N with 17 | * y = x - N*pi/2 18 | * so that |y| < pi/2. 19 | * 20 | * The method is to compute the integer (mod 8) and fraction parts of 21 | * (2/pi)*x without doing the full multiplication. In general we 22 | * skip the part of the product that are known to be a huge integer ( 23 | * more accurately, = 0 mod 8 ). Thus the number of operations are 24 | * independent of the exponent of the input. 25 | * 26 | * (2/pi) is represented by an array of 24-bit integers in ipio2[]. 27 | * 28 | * Input parameters: 29 | * x[] The input value (must be positive) is broken into nx 30 | * pieces of 24-bit integers in double precision format. 31 | * x[i] will be the i-th 24 bit of x. The scaled exponent 32 | * of x[0] is given in input parameter e0 (i.e., x[0]*2^e0 33 | * match x's up to 24 bits. 34 | * 35 | * Example of breaking a double positive z into x[0]+x[1]+x[2]: 36 | * e0 = ilogb(z)-23 37 | * z = scalbn(z,-e0) 38 | * for i = 0,1,2 39 | * x[i] = floor(z) 40 | * z = (z-x[i])*2**24 41 | * 42 | * 43 | * y[] ouput result in an array of double precision numbers. 44 | * The dimension of y[] is: 45 | * 24-bit precision 1 46 | * 53-bit precision 2 47 | * 64-bit precision 2 48 | * 113-bit precision 3 49 | * The actual value is the sum of them. Thus for 113-bit 50 | * precison, one may have to do something like: 51 | * 52 | * long double t,w,r_head, r_tail; 53 | * t = (long double)y[2] + (long double)y[1]; 54 | * w = (long double)y[0]; 55 | * r_head = t+w; 56 | * r_tail = w - (r_head - t); 57 | * 58 | * e0 The exponent of x[0]. Must be <= 16360 or you need to 59 | * expand the ipio2 table. 60 | * 61 | * nx dimension of x[] 62 | * 63 | * prec an integer indicating the precision: 64 | * 0 24 bits (single) 65 | * 1 53 bits (double) 66 | * 2 64 bits (extended) 67 | * 3 113 bits (quad) 68 | * 69 | * External function: 70 | * double scalbn(), floor(); 71 | * 72 | * 73 | * Here is the description of some local variables: 74 | * 75 | * jk jk+1 is the initial number of terms of ipio2[] needed 76 | * in the computation. The minimum and recommended value 77 | * for jk is 3,4,4,6 for single, double, extended, and quad. 78 | * jk+1 must be 2 larger than you might expect so that our 79 | * recomputation test works. (Up to 24 bits in the integer 80 | * part (the 24 bits of it that we compute) and 23 bits in 81 | * the fraction part may be lost to cancelation before we 82 | * recompute.) 83 | * 84 | * jz local integer variable indicating the number of 85 | * terms of ipio2[] used. 86 | * 87 | * jx nx - 1 88 | * 89 | * jv index for pointing to the suitable ipio2[] for the 90 | * computation. In general, we want 91 | * ( 2^e0*x[0] * ipio2[jv-1]*2^(-24jv) )/8 92 | * is an integer. Thus 93 | * e0-3-24*jv >= 0 or (e0-3)/24 >= jv 94 | * Hence jv = max(0,(e0-3)/24). 95 | * 96 | * jp jp+1 is the number of terms in PIo2[] needed, jp = jk. 97 | * 98 | * q[] double array with integral value, representing the 99 | * 24-bits chunk of the product of x and 2/pi. 100 | * 101 | * q0 the corresponding exponent of q[0]. Note that the 102 | * exponent for q[i] would be q0-24*i. 103 | * 104 | * PIo2[] double precision array, obtained by cutting pi/2 105 | * into 24 bits chunks. 106 | * 107 | * f[] ipio2[] in floating point 108 | * 109 | * iq[] integer array by breaking up q[] in 24-bits chunk. 110 | * 111 | * fq[] final product of x*(2/pi) in fq[0],..,fq[jk] 112 | * 113 | * ih integer. If >0 it indicates q[] is >= 0.5, hence 114 | * it also indicates the *sign* of the result. 115 | * 116 | */ 117 | /* 118 | * Constants: 119 | * The hexadecimal values are the intended ones for the following 120 | * constants. The decimal values may be used, provided that the 121 | * compiler will convert from decimal to binary accurately enough 122 | * to produce the hexadecimal values shown. 123 | */ 124 | 125 | #include "..\libmd.h" 126 | 127 | static const int init_jk[] = {3,4,4,6}; /* initial value for jk */ 128 | 129 | /* 130 | * Table of constants for 2/pi, 396 Hex digits (476 decimal) of 2/pi 131 | * 132 | * integer array, contains the (24*i)-th to (24*i+23)-th 133 | * bit of 2/pi after binary point. The corresponding 134 | * floating value is 135 | * 136 | * ipio2[i] * 2^(-24(i+1)). 137 | * 138 | * NB: This table must have at least (e0-3)/24 + jk terms. 139 | * For quad precision (e0 <= 16360, jk = 6), this is 686. 140 | */ 141 | static const int32_t ipio2[] = { 142 | 0xA2F983, 0x6E4E44, 0x1529FC, 0x2757D1, 0xF534DD, 0xC0DB62, 143 | 0x95993C, 0x439041, 0xFE5163, 0xABDEBB, 0xC561B7, 0x246E3A, 144 | 0x424DD2, 0xE00649, 0x2EEA09, 0xD1921C, 0xFE1DEB, 0x1CB129, 145 | 0xA73EE8, 0x8235F5, 0x2EBB44, 0x84E99C, 0x7026B4, 0x5F7E41, 146 | 0x3991D6, 0x398353, 0x39F49C, 0x845F8B, 0xBDF928, 0x3B1FF8, 147 | 0x97FFDE, 0x05980F, 0xEF2F11, 0x8B5A0A, 0x6D1F6D, 0x367ECF, 148 | 0x27CB09, 0xB74F46, 0x3F669E, 0x5FEA2D, 0x7527BA, 0xC7EBE5, 149 | 0xF17B3D, 0x0739F7, 0x8A5292, 0xEA6BFB, 0x5FB11F, 0x8D5D08, 150 | 0x560330, 0x46FC7B, 0x6BABF0, 0xCFBC20, 0x9AF436, 0x1DA9E3, 151 | 0x91615E, 0xE61B08, 0x659985, 0x5F14A0, 0x68408D, 0xFFD880, 152 | 0x4D7327, 0x310606, 0x1556CA, 0x73A8C9, 0x60E27B, 0xC08C6B, 153 | 154 | #if LDBL_MAX_EXP > 1024 155 | 0x47C419, 0xC367CD, 0xDCE809, 0x2A8359, 0xC4768B, 0x961CA6, 156 | 0xDDAF44, 0xD15719, 0x053EA5, 0xFF0705, 0x3F7E33, 0xE832C2, 157 | 0xDE4F98, 0x327DBB, 0xC33D26, 0xEF6B1E, 0x5EF89F, 0x3A1F35, 158 | 0xCAF27F, 0x1D87F1, 0x21907C, 0x7C246A, 0xFA6ED5, 0x772D30, 159 | 0x433B15, 0xC614B5, 0x9D19C3, 0xC2C4AD, 0x414D2C, 0x5D000C, 160 | 0x467D86, 0x2D71E3, 0x9AC69B, 0x006233, 0x7CD2B4, 0x97A7B4, 161 | 0xD55537, 0xF63ED7, 0x1810A3, 0xFC764D, 0x2A9D64, 0xABD770, 162 | 0xF87C63, 0x57B07A, 0xE71517, 0x5649C0, 0xD9D63B, 0x3884A7, 163 | 0xCB2324, 0x778AD6, 0x23545A, 0xB91F00, 0x1B0AF1, 0xDFCE19, 164 | 0xFF319F, 0x6A1E66, 0x615799, 0x47FBAC, 0xD87F7E, 0xB76522, 165 | 0x89E832, 0x60BFE6, 0xCDC4EF, 0x09366C, 0xD43F5D, 0xD7DE16, 166 | 0xDE3B58, 0x929BDE, 0x2822D2, 0xE88628, 0x4D58E2, 0x32CAC6, 167 | 0x16E308, 0xCB7DE0, 0x50C017, 0xA71DF3, 0x5BE018, 0x34132E, 168 | 0x621283, 0x014883, 0x5B8EF5, 0x7FB0AD, 0xF2E91E, 0x434A48, 169 | 0xD36710, 0xD8DDAA, 0x425FAE, 0xCE616A, 0xA4280A, 0xB499D3, 170 | 0xF2A606, 0x7F775C, 0x83C2A3, 0x883C61, 0x78738A, 0x5A8CAF, 171 | 0xBDD76F, 0x63A62D, 0xCBBFF4, 0xEF818D, 0x67C126, 0x45CA55, 172 | 0x36D9CA, 0xD2A828, 0x8D61C2, 0x77C912, 0x142604, 0x9B4612, 173 | 0xC459C4, 0x44C5C8, 0x91B24D, 0xF31700, 0xAD43D4, 0xE54929, 174 | 0x10D5FD, 0xFCBE00, 0xCC941E, 0xEECE70, 0xF53E13, 0x80F1EC, 175 | 0xC3E7B3, 0x28F8C7, 0x940593, 0x3E71C1, 0xB3092E, 0xF3450B, 176 | 0x9C1288, 0x7B20AB, 0x9FB52E, 0xC29247, 0x2F327B, 0x6D550C, 177 | 0x90A772, 0x1FE76B, 0x96CB31, 0x4A1679, 0xE27941, 0x89DFF4, 178 | 0x9794E8, 0x84E6E2, 0x973199, 0x6BED88, 0x365F5F, 0x0EFDBB, 179 | 0xB49A48, 0x6CA467, 0x427271, 0x325D8D, 0xB8159F, 0x09E5BC, 180 | 0x25318D, 0x3974F7, 0x1C0530, 0x010C0D, 0x68084B, 0x58EE2C, 181 | 0x90AA47, 0x02E774, 0x24D6BD, 0xA67DF7, 0x72486E, 0xEF169F, 182 | 0xA6948E, 0xF691B4, 0x5153D1, 0xF20ACF, 0x339820, 0x7E4BF5, 183 | 0x6863B2, 0x5F3EDD, 0x035D40, 0x7F8985, 0x295255, 0xC06437, 184 | 0x10D86D, 0x324832, 0x754C5B, 0xD4714E, 0x6E5445, 0xC1090B, 185 | 0x69F52A, 0xD56614, 0x9D0727, 0x50045D, 0xDB3BB4, 0xC576EA, 186 | 0x17F987, 0x7D6B49, 0xBA271D, 0x296996, 0xACCCC6, 0x5414AD, 187 | 0x6AE290, 0x89D988, 0x50722C, 0xBEA404, 0x940777, 0x7030F3, 188 | 0x27FC00, 0xA871EA, 0x49C266, 0x3DE064, 0x83DD97, 0x973FA3, 189 | 0xFD9443, 0x8C860D, 0xDE4131, 0x9D3992, 0x8C70DD, 0xE7B717, 190 | 0x3BDF08, 0x2B3715, 0xA0805C, 0x93805A, 0x921110, 0xD8E80F, 191 | 0xAF806C, 0x4BFFDB, 0x0F9038, 0x761859, 0x15A562, 0xBBCB61, 192 | 0xB989C7, 0xBD4010, 0x04F2D2, 0x277549, 0xF6B6EB, 0xBB22DB, 193 | 0xAA140A, 0x2F2689, 0x768364, 0x333B09, 0x1A940E, 0xAA3A51, 194 | 0xC2A31D, 0xAEEDAF, 0x12265C, 0x4DC26D, 0x9C7A2D, 0x9756C0, 195 | 0x833F03, 0xF6F009, 0x8C402B, 0x99316D, 0x07B439, 0x15200C, 196 | 0x5BC3D8, 0xC492F5, 0x4BADC6, 0xA5CA4E, 0xCD37A7, 0x36A9E6, 197 | 0x9492AB, 0x6842DD, 0xDE6319, 0xEF8C76, 0x528B68, 0x37DBFC, 198 | 0xABA1AE, 0x3115DF, 0xA1AE00, 0xDAFB0C, 0x664D64, 0xB705ED, 199 | 0x306529, 0xBF5657, 0x3AFF47, 0xB9F96A, 0xF3BE75, 0xDF9328, 200 | 0x3080AB, 0xF68C66, 0x15CB04, 0x0622FA, 0x1DE4D9, 0xA4B33D, 201 | 0x8F1B57, 0x09CD36, 0xE9424E, 0xA4BE13, 0xB52333, 0x1AAAF0, 202 | 0xA8654F, 0xA5C1D2, 0x0F3F0B, 0xCD785B, 0x76F923, 0x048B7B, 203 | 0x721789, 0x53A6C6, 0xE26E6F, 0x00EBEF, 0x584A9B, 0xB7DAC4, 204 | 0xBA66AA, 0xCFCF76, 0x1D02D1, 0x2DF1B1, 0xC1998C, 0x77ADC3, 205 | 0xDA4886, 0xA05DF7, 0xF480C6, 0x2FF0AC, 0x9AECDD, 0xBC5C3F, 206 | 0x6DDED0, 0x1FC790, 0xB6DB2A, 0x3A25A3, 0x9AAF00, 0x9353AD, 207 | 0x0457B6, 0xB42D29, 0x7E804B, 0xA707DA, 0x0EAA76, 0xA1597B, 208 | 0x2A1216, 0x2DB7DC, 0xFDE5FA, 0xFEDB89, 0xFDBE89, 0x6C76E4, 209 | 0xFCA906, 0x70803E, 0x156E85, 0xFF87FD, 0x073E28, 0x336761, 210 | 0x86182A, 0xEABD4D, 0xAFE7B3, 0x6E6D8F, 0x396795, 0x5BBF31, 211 | 0x48D784, 0x16DF30, 0x432DC7, 0x356125, 0xCE70C9, 0xB8CB30, 212 | 0xFD6CBF, 0xA200A4, 0xE46C05, 0xA0DD5A, 0x476F21, 0xD21262, 213 | 0x845CB9, 0x496170, 0xE0566B, 0x015299, 0x375550, 0xB7D51E, 214 | 0xC4F133, 0x5F6E13, 0xE4305D, 0xA92E85, 0xC3B21D, 0x3632A1, 215 | 0xA4B708, 0xD4B1EA, 0x21F716, 0xE4698F, 0x77FF27, 0x80030C, 216 | 0x2D408D, 0xA0CD4F, 0x99A520, 0xD3A2B3, 0x0A5D2F, 0x42F9B4, 217 | 0xCBDA11, 0xD0BE7D, 0xC1DB9B, 0xBD17AB, 0x81A2CA, 0x5C6A08, 218 | 0x17552E, 0x550027, 0xF0147F, 0x8607E1, 0x640B14, 0x8D4196, 219 | 0xDEBE87, 0x2AFDDA, 0xB6256B, 0x34897B, 0xFEF305, 0x9EBFB9, 220 | 0x4F6A68, 0xA82A4A, 0x5AC44F, 0xBCF82D, 0x985AD7, 0x95C7F4, 221 | 0x8D4D0D, 0xA63A20, 0x5F57A4, 0xB13F14, 0x953880, 0x0120CC, 222 | 0x86DD71, 0xB6DEC9, 0xF560BF, 0x11654D, 0x6B0701, 0xACB08C, 223 | 0xD0C0B2, 0x485551, 0x0EFB1E, 0xC37295, 0x3B06A3, 0x3540C0, 224 | 0x7BDC06, 0xCC45E0, 0xFA294E, 0xC8CAD6, 0x41F3E8, 0xDE647C, 225 | 0xD8649B, 0x31BED9, 0xC397A4, 0xD45877, 0xC5E369, 0x13DAF0, 226 | 0x3C3ABA, 0x461846, 0x5F7555, 0xF5BDD2, 0xC6926E, 0x5D2EAC, 227 | 0xED440E, 0x423E1C, 0x87C461, 0xE9FD29, 0xF3D6E7, 0xCA7C22, 228 | 0x35916F, 0xC5E008, 0x8DD7FF, 0xE26A6E, 0xC6FDB0, 0xC10893, 229 | 0x745D7C, 0xB2AD6B, 0x9D6ECD, 0x7B723E, 0x6A11C6, 0xA9CFF7, 230 | 0xDF7329, 0xBAC9B5, 0x5100B7, 0x0DB2E2, 0x24BA74, 0x607DE5, 231 | 0x8AD874, 0x2C150D, 0x0C1881, 0x94667E, 0x162901, 0x767A9F, 232 | 0xBEFDFD, 0xEF4556, 0x367ED9, 0x13D9EC, 0xB9BA8B, 0xFC97C4, 233 | 0x27A831, 0xC36EF1, 0x36C594, 0x56A8D8, 0xB5A8B4, 0x0ECCCF, 234 | 0x2D8912, 0x34576F, 0x89562C, 0xE3CE99, 0xB920D6, 0xAA5E6B, 235 | 0x9C2A3E, 0xCC5F11, 0x4A0BFD, 0xFBF4E1, 0x6D3B8E, 0x2C86E2, 236 | 0x84D4E9, 0xA9B4FC, 0xD1EEEF, 0xC9352E, 0x61392F, 0x442138, 237 | 0xC8D91B, 0x0AFC81, 0x6A4AFB, 0xD81C2F, 0x84B453, 0x8C994E, 238 | 0xCC2254, 0xDC552A, 0xD6C6C0, 0x96190B, 0xB8701A, 0x649569, 239 | 0x605A26, 0xEE523F, 0x0F117F, 0x11B5F4, 0xF5CBFC, 0x2DBC34, 240 | 0xEEBC34, 0xCC5DE8, 0x605EDD, 0x9B8E67, 0xEF3392, 0xB817C9, 241 | 0x9B5861, 0xBC57E1, 0xC68351, 0x103ED8, 0x4871DD, 0xDD1C2D, 242 | 0xA118AF, 0x462C21, 0xD7F359, 0x987AD9, 0xC0549E, 0xFA864F, 243 | 0xFC0656, 0xAE79E5, 0x362289, 0x22AD38, 0xDC9367, 0xAAE855, 244 | 0x382682, 0x9BE7CA, 0xA40D51, 0xB13399, 0x0ED7A9, 0x480569, 245 | 0xF0B265, 0xA7887F, 0x974C88, 0x36D1F9, 0xB39221, 0x4A827B, 246 | 0x21CF98, 0xDC9F40, 0x5547DC, 0x3A74E1, 0x42EB67, 0xDF9DFE, 247 | 0x5FD45E, 0xA4677B, 0x7AACBA, 0xA2F655, 0x23882B, 0x55BA41, 248 | 0x086E59, 0x862A21, 0x834739, 0xE6E389, 0xD49EE5, 0x40FB49, 249 | 0xE956FF, 0xCA0F1C, 0x8A59C5, 0x2BFA94, 0xC5C1D3, 0xCFC50F, 250 | 0xAE5ADB, 0x86C547, 0x624385, 0x3B8621, 0x94792C, 0x876110, 251 | 0x7B4C2A, 0x1A2C80, 0x12BF43, 0x902688, 0x893C78, 0xE4C4A8, 252 | 0x7BDBE5, 0xC23AC4, 0xEAF426, 0x8A67F7, 0xBF920D, 0x2BA365, 253 | 0xB1933D, 0x0B7CBD, 0xDC51A4, 0x63DD27, 0xDDE169, 0x19949A, 254 | 0x9529A8, 0x28CE68, 0xB4ED09, 0x209F44, 0xCA984E, 0x638270, 255 | 0x237C7E, 0x32B90F, 0x8EF5A7, 0xE75614, 0x08F121, 0x2A9DB5, 256 | 0x4D7E6F, 0x5119A5, 0xABF9B5, 0xD6DF82, 0x61DD96, 0x023616, 257 | 0x9F3AC4, 0xA1A283, 0x6DED72, 0x7A8D39, 0xA9B882, 0x5C326B, 258 | 0x5B2746, 0xED3400, 0x7700D2, 0x55F4FC, 0x4D5901, 0x8071E0, 259 | #endif 260 | }; 261 | 262 | static const double PIo2[] = { 263 | 1.57079625129699707031e+00, /* 0x3FF921FB, 0x40000000 */ 264 | 7.54978941586159635335e-08, /* 0x3E74442D, 0x00000000 */ 265 | 5.39030252995776476554e-15, /* 0x3CF84698, 0x80000000 */ 266 | 3.28200341580791294123e-22, /* 0x3B78CC51, 0x60000000 */ 267 | 1.27065575308067607349e-29, /* 0x39F01B83, 0x80000000 */ 268 | 1.22933308981111328932e-36, /* 0x387A2520, 0x40000000 */ 269 | 2.73370053816464559624e-44, /* 0x36E38222, 0x80000000 */ 270 | 2.16741683877804819444e-51, /* 0x3569F31D, 0x00000000 */ 271 | }; 272 | 273 | int __rem_pio2_large(double *x, double *y, int e0, int nx, int prec) 274 | { 275 | int32_t jz,jx,jv,jp,jk,carry,n,iq[20],i,j,k,m,q0,ih; 276 | double z,fw,f[20],fq[20],q[20]; 277 | 278 | /* initialize jk*/ 279 | jk = init_jk[prec]; 280 | jp = jk; 281 | 282 | /* determine jx,jv,q0, note that 3>q0 */ 283 | jx = nx-1; 284 | jv = (e0-3)/24; if(jv<0) jv=0; 285 | q0 = e0-24*(jv+1); 286 | 287 | /* set up f[0] to f[jx+jk] where f[jx+jk] = ipio2[jv+jk] */ 288 | j = jv-jx; m = jx+jk; 289 | for (i=0; i<=m; i++,j++) 290 | f[i] = j<0 ? 0.0 : (double)ipio2[j]; 291 | 292 | /* compute q[0],q[1],...q[jk] */ 293 | for (i=0; i<=jk; i++) { 294 | for (j=0,fw=0.0; j<=jx; j++) 295 | fw += x[j]*f[jx+i-j]; 296 | q[i] = fw; 297 | } 298 | 299 | jz = jk; 300 | recompute: 301 | /* distill q[] into iq[] reversingly */ 302 | for (i=0,j=jz,z=q[jz]; j>0; i++,j--) { 303 | fw = (double)(int32_t)(0x1p-24*z); 304 | iq[i] = (int32_t)(z - 0x1p24*fw); 305 | z = q[j-1]+fw; 306 | } 307 | 308 | /* compute n */ 309 | z = scalbn(z,q0); /* actual value of z */ 310 | z -= 8.0*floor(z*0.125); /* trim off integer >= 8 */ 311 | n = (int32_t)z; 312 | z -= (double)n; 313 | ih = 0; 314 | if (q0 > 0) { /* need iq[jz-1] to determine n */ 315 | i = iq[jz-1]>>(24-q0); n += i; 316 | iq[jz-1] -= i<<(24-q0); 317 | ih = iq[jz-1]>>(23-q0); 318 | } 319 | else if (q0 == 0) ih = iq[jz-1]>>23; 320 | else if (z >= 0.5) ih = 2; 321 | 322 | if (ih > 0) { /* q > 0.5 */ 323 | n += 1; carry = 0; 324 | for (i=0; i 0) { /* rare case: chance is 1 in 12 */ 335 | switch(q0) { 336 | case 1: 337 | iq[jz-1] &= 0x7fffff; break; 338 | case 2: 339 | iq[jz-1] &= 0x3fffff; break; 340 | } 341 | } 342 | if (ih == 2) { 343 | z = 1.0 - z; 344 | if (carry != 0) 345 | z -= scalbn(1.0,q0); 346 | } 347 | } 348 | 349 | /* check if recomputation is needed */ 350 | if (z == 0.0) { 351 | j = 0; 352 | for (i=jz-1; i>=jk; i--) j |= iq[i]; 353 | if (j == 0) { /* need recomputation */ 354 | for (k=1; iq[jk-k]==0; k++); /* k = no. of terms needed */ 355 | 356 | for (i=jz+1; i<=jz+k; i++) { /* add q[jz+1] to q[jz+k] */ 357 | f[jx+i] = (double)ipio2[jv+i]; 358 | for (j=0,fw=0.0; j<=jx; j++) 359 | fw += x[j]*f[jx+i-j]; 360 | q[i] = fw; 361 | } 362 | jz += k; 363 | goto recompute; 364 | } 365 | } 366 | 367 | /* chop off zero terms */ 368 | if (z == 0.0) { 369 | jz -= 1; 370 | q0 -= 24; 371 | while (iq[jz] == 0) { 372 | jz--; 373 | q0 -= 24; 374 | } 375 | } else { /* break z into 24-bit if necessary */ 376 | z = scalbn(z,-q0); 377 | if (z >= 0x1p24) { 378 | fw = (double)(int32_t)(0x1p-24*z); 379 | iq[jz] = (int32_t)(z - 0x1p24*fw); 380 | jz += 1; 381 | q0 += 24; 382 | iq[jz] = (int32_t)fw; 383 | } else 384 | iq[jz] = (int32_t)z; 385 | } 386 | 387 | /* convert integer "bit" chunk to floating-point value */ 388 | fw = scalbn(1.0,q0); 389 | for (i=jz; i>=0; i--) { 390 | q[i] = fw*(double)iq[i]; 391 | fw *= 0x1p-24; 392 | } 393 | 394 | /* compute PIo2[0,...,jp]*q[jz,...,0] */ 395 | for(i=jz; i>=0; i--) { 396 | for (fw=0.0,k=0; k<=jp && k<=jz-i; k++) 397 | fw += PIo2[k]*q[i+k]; 398 | fq[jz-i] = fw; 399 | } 400 | 401 | /* compress fq[] into y[] */ 402 | switch(prec) { 403 | case 0: 404 | fw = 0.0; 405 | for (i=jz; i>=0; i--) 406 | fw += fq[i]; 407 | y[0] = ih==0 ? fw : -fw; 408 | break; 409 | case 1: 410 | case 2: 411 | fw = 0.0; 412 | for (i=jz; i>=0; i--) 413 | fw += fq[i]; 414 | // TODO: drop excess precision here once double_t is used 415 | fw = (double)fw; 416 | y[0] = ih==0 ? fw : -fw; 417 | fw = fq[0]-fw; 418 | for (i=1; i<=jz; i++) 419 | fw += fq[i]; 420 | y[1] = ih==0 ? fw : -fw; 421 | break; 422 | case 3: /* painful */ 423 | for (i=jz; i>0; i--) { 424 | fw = fq[i-1]+fq[i]; 425 | fq[i] += fq[i-1]-fw; 426 | fq[i-1] = fw; 427 | } 428 | for (i=jz; i>1; i--) { 429 | fw = fq[i-1]+fq[i]; 430 | fq[i] += fq[i-1]-fw; 431 | fq[i-1] = fw; 432 | } 433 | for (fw=0.0,i=jz; i>=2; i--) 434 | fw += fq[i]; 435 | if (ih==0) { 436 | y[0] = fq[0]; y[1] = fq[1]; y[2] = fw; 437 | } else { 438 | y[0] = -fq[0]; y[1] = -fq[1]; y[2] = -fw; 439 | } 440 | } 441 | return n&7; 442 | } 443 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/__sin.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/k_sin.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunSoft, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* __sin( x, y, iy) 13 | * kernel sin function on ~[-pi/4, pi/4] (except on -0), pi/4 ~ 0.7854 14 | * Input x is assumed to be bounded by ~pi/4 in magnitude. 15 | * Input y is the tail of x. 16 | * Input iy indicates whether y is 0. (if iy=0, y assume to be 0). 17 | * 18 | * Algorithm 19 | * 1. Since sin(-x) = -sin(x), we need only to consider positive x. 20 | * 2. Callers must return sin(-0) = -0 without calling here since our 21 | * odd polynomial is not evaluated in a way that preserves -0. 22 | * Callers may do the optimization sin(x) ~ x for tiny x. 23 | * 3. sin(x) is approximated by a polynomial of degree 13 on 24 | * [0,pi/4] 25 | * 3 13 26 | * sin(x) ~ x + S1*x + ... + S6*x 27 | * where 28 | * 29 | * |sin(x) 2 4 6 8 10 12 | -58 30 | * |----- - (1+S1*x +S2*x +S3*x +S4*x +S5*x +S6*x )| <= 2 31 | * | x | 32 | * 33 | * 4. sin(x+y) = sin(x) + sin'(x')*y 34 | * ~ sin(x) + (1-x*x/2)*y 35 | * For better accuracy, let 36 | * 3 2 2 2 2 37 | * r = x *(S2+x *(S3+x *(S4+x *(S5+x *S6)))) 38 | * then 3 2 39 | * sin(x) = x + (S1*x + (x *(r-y/2)+y)) 40 | */ 41 | 42 | #include "..\libmd.h" 43 | 44 | static const double 45 | S1 = -1.66666666666666324348e-01, /* 0xBFC55555, 0x55555549 */ 46 | S2 = 8.33333333332248946124e-03, /* 0x3F811111, 0x1110F8A6 */ 47 | S3 = -1.98412698298579493134e-04, /* 0xBF2A01A0, 0x19C161D5 */ 48 | S4 = 2.75573137070700676789e-06, /* 0x3EC71DE3, 0x57B1FE7D */ 49 | S5 = -2.50507602534068634195e-08, /* 0xBE5AE5E6, 0x8A2B9CEB */ 50 | S6 = 1.58969099521155010221e-10; /* 0x3DE5D93A, 0x5ACFD57C */ 51 | 52 | double __sin(double x, double y, int iy) 53 | { 54 | double_t z,r,v,w; 55 | 56 | z = x*x; 57 | w = z*z; 58 | r = S2 + z*(S3 + z*S4) + z*w*(S5 + z*S6); 59 | v = z*x; 60 | if (iy == 0) 61 | return x + v*(S1 + z*r); 62 | else 63 | return x - ((z*(0.5*y - v*r) - y) - v*S1); 64 | } 65 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/__tan.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/k_tan.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright 2004 Sun Microsystems, Inc. All Rights Reserved. 5 | * 6 | * Permission to use, copy, modify, and distribute this 7 | * software is freely granted, provided that this notice 8 | * is preserved. 9 | * ==================================================== 10 | */ 11 | /* __tan( x, y, k ) 12 | * kernel tan function on ~[-pi/4, pi/4] (except on -0), pi/4 ~ 0.7854 13 | * Input x is assumed to be bounded by ~pi/4 in magnitude. 14 | * Input y is the tail of x. 15 | * Input odd indicates whether tan (if odd = 0) or -1/tan (if odd = 1) is returned. 16 | * 17 | * Algorithm 18 | * 1. Since tan(-x) = -tan(x), we need only to consider positive x. 19 | * 2. Callers must return tan(-0) = -0 without calling here since our 20 | * odd polynomial is not evaluated in a way that preserves -0. 21 | * Callers may do the optimization tan(x) ~ x for tiny x. 22 | * 3. tan(x) is approximated by a odd polynomial of degree 27 on 23 | * [0,0.67434] 24 | * 3 27 25 | * tan(x) ~ x + T1*x + ... + T13*x 26 | * where 27 | * 28 | * |tan(x) 2 4 26 | -59.2 29 | * |----- - (1+T1*x +T2*x +.... +T13*x )| <= 2 30 | * | x | 31 | * 32 | * Note: tan(x+y) = tan(x) + tan'(x)*y 33 | * ~ tan(x) + (1+x*x)*y 34 | * Therefore, for better accuracy in computing tan(x+y), let 35 | * 3 2 2 2 2 36 | * r = x *(T2+x *(T3+x *(...+x *(T12+x *T13)))) 37 | * then 38 | * 3 2 39 | * tan(x+y) = x + (T1*x + (x *(r+y)+y)) 40 | * 41 | * 4. For x in [0.67434,pi/4], let y = pi/4 - x, then 42 | * tan(x) = tan(pi/4-y) = (1-tan(y))/(1+tan(y)) 43 | * = 1 - 2*(tan(y) - (tan(y)^2)/(1+tan(y))) 44 | */ 45 | 46 | #include "..\libmd.h" 47 | 48 | static const double T[] = { 49 | 3.33333333333334091986e-01, /* 3FD55555, 55555563 */ 50 | 1.33333333333201242699e-01, /* 3FC11111, 1110FE7A */ 51 | 5.39682539762260521377e-02, /* 3FABA1BA, 1BB341FE */ 52 | 2.18694882948595424599e-02, /* 3F9664F4, 8406D637 */ 53 | 8.86323982359930005737e-03, /* 3F8226E3, E96E8493 */ 54 | 3.59207910759131235356e-03, /* 3F6D6D22, C9560328 */ 55 | 1.45620945432529025516e-03, /* 3F57DBC8, FEE08315 */ 56 | 5.88041240820264096874e-04, /* 3F4344D8, F2F26501 */ 57 | 2.46463134818469906812e-04, /* 3F3026F7, 1A8D1068 */ 58 | 7.81794442939557092300e-05, /* 3F147E88, A03792A6 */ 59 | 7.14072491382608190305e-05, /* 3F12B80F, 32F0A7E9 */ 60 | -1.85586374855275456654e-05, /* BEF375CB, DB605373 */ 61 | 2.59073051863633712884e-05, /* 3EFB2A70, 74BF7AD4 */ 62 | }, 63 | pio4 = 7.85398163397448278999e-01, /* 3FE921FB, 54442D18 */ 64 | pio4lo = 3.06161699786838301793e-17; /* 3C81A626, 33145C07 */ 65 | 66 | double __tan(double x, double y, int odd) 67 | { 68 | double_t z, r, v, w, s, a; 69 | double w0, a0; 70 | uint32_t hx; 71 | int big, sign; 72 | 73 | GET_HIGH_WORD(hx,x); 74 | big = (hx&0x7fffffff) >= 0x3FE59428; /* |x| >= 0.6744 */ 75 | if (big) { 76 | sign = hx>>31; 77 | if (sign) { 78 | x = -x; 79 | y = -y; 80 | } 81 | x = (pio4 - x) + (pio4lo - y); 82 | y = 0.0; 83 | } 84 | z = x * x; 85 | w = z * z; 86 | /* 87 | * Break x^5*(T[1]+x^2*T[2]+...) into 88 | * x^5(T[1]+x^4*T[3]+...+x^20*T[11]) + 89 | * x^5(x^2*(T[2]+x^4*T[4]+...+x^22*[T12])) 90 | */ 91 | r = T[1] + w*(T[3] + w*(T[5] + w*(T[7] + w*(T[9] + w*T[11])))); 92 | v = z*(T[2] + w*(T[4] + w*(T[6] + w*(T[8] + w*(T[10] + w*T[12]))))); 93 | s = z * x; 94 | r = y + z*(s*(r + v) + y) + s*T[0]; 95 | w = x + r; 96 | if (big) { 97 | s = 1 - 2*odd; 98 | v = s - 2.0 * (x + (r - w*w/(w + s))); 99 | return sign ? -v : v; 100 | } 101 | if (!odd) 102 | return w; 103 | /* -1.0/(x+r) has up to 2ulp error, so compute it accurately */ 104 | w0 = w; 105 | SET_LOW_WORD(w0, 0); 106 | v = r - (w0 - x); /* w0+v = r+x */ 107 | a0 = a = -1.0 / w; 108 | SET_LOW_WORD(a0, 0); 109 | return a0 + a*(1.0 + a0*w0 + a0*v); 110 | } 111 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/_fltused.c: -------------------------------------------------------------------------------- 1 | extern "C" char _fltused = 1; -------------------------------------------------------------------------------- /NtLisp/crt/libmd/acos.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/e_acos.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunSoft, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* acos(x) 13 | * Method : 14 | * acos(x) = pi/2 - asin(x) 15 | * acos(-x) = pi/2 + asin(x) 16 | * For |x|<=0.5 17 | * acos(x) = pi/2 - (x + x*x^2*R(x^2)) (see asin.c) 18 | * For x>0.5 19 | * acos(x) = pi/2 - (pi/2 - 2asin(sqrt((1-x)/2))) 20 | * = 2asin(sqrt((1-x)/2)) 21 | * = 2s + 2s*z*R(z) ...z=(1-x)/2, s=sqrt(z) 22 | * = 2f + (2c + 2s*z*R(z)) 23 | * where f=hi part of s, and c = (z-f*f)/(s+f) is the correction term 24 | * for f so that f+c ~ sqrt(z). 25 | * For x<-0.5 26 | * acos(x) = pi - 2asin(sqrt((1-|x|)/2)) 27 | * = pi - 0.5*(s+s*z*R(z)), where z=(1-|x|)/2,s=sqrt(z) 28 | * 29 | * Special cases: 30 | * if x is NaN, return x itself; 31 | * if |x|>1, return NaN with invalid signal. 32 | * 33 | * Function needed: sqrt 34 | */ 35 | 36 | #include "..\libmd.h" 37 | 38 | static const double 39 | pio2_hi = 1.57079632679489655800e+00, /* 0x3FF921FB, 0x54442D18 */ 40 | pio2_lo = 6.12323399573676603587e-17, /* 0x3C91A626, 0x33145C07 */ 41 | pS0 = 1.66666666666666657415e-01, /* 0x3FC55555, 0x55555555 */ 42 | pS1 = -3.25565818622400915405e-01, /* 0xBFD4D612, 0x03EB6F7D */ 43 | pS2 = 2.01212532134862925881e-01, /* 0x3FC9C155, 0x0E884455 */ 44 | pS3 = -4.00555345006794114027e-02, /* 0xBFA48228, 0xB5688F3B */ 45 | pS4 = 7.91534994289814532176e-04, /* 0x3F49EFE0, 0x7501B288 */ 46 | pS5 = 3.47933107596021167570e-05, /* 0x3F023DE1, 0x0DFDF709 */ 47 | qS1 = -2.40339491173441421878e+00, /* 0xC0033A27, 0x1C8A2D4B */ 48 | qS2 = 2.02094576023350569471e+00, /* 0x40002AE5, 0x9C598AC8 */ 49 | qS3 = -6.88283971605453293030e-01, /* 0xBFE6066C, 0x1B8D0159 */ 50 | qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ 51 | 52 | static double R(double z) 53 | { 54 | double_t p, q; 55 | p = z*(pS0+z*(pS1+z*(pS2+z*(pS3+z*(pS4+z*pS5))))); 56 | q = 1.0+z*(qS1+z*(qS2+z*(qS3+z*qS4))); 57 | return p/q; 58 | } 59 | 60 | double acos(double x) 61 | { 62 | double z,w,s,c,df; 63 | uint32_t hx,ix; 64 | 65 | GET_HIGH_WORD(hx, x); 66 | ix = hx & 0x7fffffff; 67 | /* |x| >= 1 or nan */ 68 | if (ix >= 0x3ff00000) { 69 | uint32_t lx; 70 | 71 | GET_LOW_WORD(lx,x); 72 | if (((ix-0x3ff00000) | lx) == 0) { 73 | /* acos(1)=0, acos(-1)=pi */ 74 | if (hx >> 31) 75 | return 2*pio2_hi + 0x1p-120f; 76 | return 0; 77 | } 78 | return 0/(x-x); 79 | } 80 | /* |x| < 0.5 */ 81 | if (ix < 0x3fe00000) { 82 | if (ix <= 0x3c600000) /* |x| < 2**-57 */ 83 | return pio2_hi + 0x1p-120f; 84 | return pio2_hi - (x - (pio2_lo-x*R(x*x))); 85 | } 86 | /* x < -0.5 */ 87 | if (hx >> 31) { 88 | z = (1.0+x)*0.5; 89 | s = sqrt(z); 90 | w = R(z)*s-pio2_lo; 91 | return 2*(pio2_hi - (s+w)); 92 | } 93 | /* x > 0.5 */ 94 | z = (1.0-x)*0.5; 95 | s = sqrt(z); 96 | df = s; 97 | SET_LOW_WORD(df,0); 98 | c = (z-df*df)/(s+df); 99 | w = R(z)*s+c; 100 | return 2*(df+w); 101 | } 102 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/acosh.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | #if FLT_EVAL_METHOD==2 4 | #undef sqrt 5 | #define sqrt sqrtl 6 | #endif 7 | 8 | /* acosh(x) = log(x + sqrt(x*x-1)) */ 9 | double acosh(double x) 10 | { 11 | union {double f; uint64_t i;} u = { x }; 12 | unsigned e = u.i >> 52 & 0x7ff; 13 | 14 | /* x < 1 domain error is handled in the called functions */ 15 | 16 | if (e < 0x3ff + 1) 17 | /* |x| < 2, up to 2ulp error in [1,1.125] */ 18 | return log1p(x-1 + sqrt((x-1)*(x-1)+2*(x-1))); 19 | if (e < 0x3ff + 26) 20 | /* |x| < 0x1p26 */ 21 | return log(2*x - 1/(x+sqrt(x*x-1))); 22 | /* |x| >= 0x1p26 or nan */ 23 | return log(x) + 0.693147180559945309417232121458176568; 24 | } 25 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/asin.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/e_asin.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunSoft, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* asin(x) 13 | * Method : 14 | * Since asin(x) = x + x^3/6 + x^5*3/40 + x^7*15/336 + ... 15 | * we approximate asin(x) on [0,0.5] by 16 | * asin(x) = x + x*x^2*R(x^2) 17 | * where 18 | * R(x^2) is a rational approximation of (asin(x)-x)/x^3 19 | * and its remez error is bounded by 20 | * |(asin(x)-x)/x^3 - R(x^2)| < 2^(-58.75) 21 | * 22 | * For x in [0.5,1] 23 | * asin(x) = pi/2-2*asin(sqrt((1-x)/2)) 24 | * Let y = (1-x), z = y/2, s := sqrt(z), and pio2_hi+pio2_lo=pi/2; 25 | * then for x>0.98 26 | * asin(x) = pi/2 - 2*(s+s*z*R(z)) 27 | * = pio2_hi - (2*(s+s*z*R(z)) - pio2_lo) 28 | * For x<=0.98, let pio4_hi = pio2_hi/2, then 29 | * f = hi part of s; 30 | * c = sqrt(z) - f = (z-f*f)/(s+f) ...f+c=sqrt(z) 31 | * and 32 | * asin(x) = pi/2 - 2*(s+s*z*R(z)) 33 | * = pio4_hi+(pio4-2s)-(2s*z*R(z)-pio2_lo) 34 | * = pio4_hi+(pio4-2f)-(2s*z*R(z)-(pio2_lo+2c)) 35 | * 36 | * Special cases: 37 | * if x is NaN, return x itself; 38 | * if |x|>1, return NaN with invalid signal. 39 | * 40 | */ 41 | 42 | #include "..\libmd.h" 43 | 44 | static const double 45 | pio2_hi = 1.57079632679489655800e+00, /* 0x3FF921FB, 0x54442D18 */ 46 | pio2_lo = 6.12323399573676603587e-17, /* 0x3C91A626, 0x33145C07 */ 47 | /* coefficients for R(x^2) */ 48 | pS0 = 1.66666666666666657415e-01, /* 0x3FC55555, 0x55555555 */ 49 | pS1 = -3.25565818622400915405e-01, /* 0xBFD4D612, 0x03EB6F7D */ 50 | pS2 = 2.01212532134862925881e-01, /* 0x3FC9C155, 0x0E884455 */ 51 | pS3 = -4.00555345006794114027e-02, /* 0xBFA48228, 0xB5688F3B */ 52 | pS4 = 7.91534994289814532176e-04, /* 0x3F49EFE0, 0x7501B288 */ 53 | pS5 = 3.47933107596021167570e-05, /* 0x3F023DE1, 0x0DFDF709 */ 54 | qS1 = -2.40339491173441421878e+00, /* 0xC0033A27, 0x1C8A2D4B */ 55 | qS2 = 2.02094576023350569471e+00, /* 0x40002AE5, 0x9C598AC8 */ 56 | qS3 = -6.88283971605453293030e-01, /* 0xBFE6066C, 0x1B8D0159 */ 57 | qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ 58 | 59 | static double R(double z) 60 | { 61 | double_t p, q; 62 | p = z*(pS0+z*(pS1+z*(pS2+z*(pS3+z*(pS4+z*pS5))))); 63 | q = 1.0+z*(qS1+z*(qS2+z*(qS3+z*qS4))); 64 | return p/q; 65 | } 66 | 67 | double asin(double x) 68 | { 69 | double z,r,s; 70 | uint32_t hx,ix; 71 | 72 | GET_HIGH_WORD(hx, x); 73 | ix = hx & 0x7fffffff; 74 | /* |x| >= 1 or nan */ 75 | if (ix >= 0x3ff00000) { 76 | uint32_t lx; 77 | GET_LOW_WORD(lx, x); 78 | if (((ix-0x3ff00000) | lx) == 0) 79 | /* asin(1) = +-pi/2 with inexact */ 80 | return x*pio2_hi + 0x1p-120f; 81 | return 0/(x-x); 82 | } 83 | /* |x| < 0.5 */ 84 | if (ix < 0x3fe00000) { 85 | /* if 0x1p-1022 <= |x| < 0x1p-26, avoid raising underflow */ 86 | if (ix < 0x3e500000 && ix >= 0x00100000) 87 | return x; 88 | return x + x*R(x*x); 89 | } 90 | /* 1 > |x| >= 0.5 */ 91 | z = (1 - fabs(x))*0.5; 92 | s = sqrt(z); 93 | r = R(z); 94 | if (ix >= 0x3fef3333) { /* if |x| > 0.975 */ 95 | x = pio2_hi-(2*(s+s*r)-pio2_lo); 96 | } else { 97 | double f,c; 98 | /* f+c = sqrt(z) */ 99 | f = s; 100 | SET_LOW_WORD(f,0); 101 | c = (z-f*f)/(s+f); 102 | x = 0.5*pio2_hi - (2*s*r - (pio2_lo-2*c) - (0.5*pio2_hi-2*f)); 103 | } 104 | if (hx >> 31) 105 | return -x; 106 | return x; 107 | } 108 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/asinh.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | /* asinh(x) = sign(x)*log(|x|+sqrt(x*x+1)) ~= x - x^3/6 + o(x^5) */ 4 | double asinh(double x) 5 | { 6 | union {double f; uint64_t i;} u = { x }; 7 | unsigned e = u.i >> 52 & 0x7ff; 8 | unsigned s = u.i >> 63; 9 | 10 | /* |x| */ 11 | u.i &= (uint64_t)-1/2; 12 | x = u.f; 13 | 14 | if (e >= 0x3ff + 26) { 15 | /* |x| >= 0x1p26 or inf or nan */ 16 | x = log(x) + 0.693147180559945309417232121458176568; 17 | } else if (e >= 0x3ff + 1) { 18 | /* |x| >= 2 */ 19 | x = log(2*x + 1/(sqrt(x*x+1)+x)); 20 | } else if (e >= 0x3ff - 26) { 21 | /* |x| >= 0x1p-26, up to 1.6ulp error in [0.125,0.5] */ 22 | x = log1p(x + x*x/(sqrt(x*x+1)+1)); 23 | } else { 24 | /* |x| < 0x1p-26, raise inexact if x != 0 */ 25 | FORCE_EVAL(x + 0x1p120f); 26 | } 27 | return s ? -x : x; 28 | } 29 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/atan.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/s_atan.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunPro, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* atan(x) 13 | * Method 14 | * 1. Reduce x to positive by atan(x) = -atan(-x). 15 | * 2. According to the integer k=4t+0.25 chopped, t=x, the argument 16 | * is further reduced to one of the following intervals and the 17 | * arctangent of t is evaluated by the corresponding formula: 18 | * 19 | * [0,7/16] atan(x) = t-t^3*(a1+t^2*(a2+...(a10+t^2*a11)...) 20 | * [7/16,11/16] atan(x) = atan(1/2) + atan( (t-0.5)/(1+t/2) ) 21 | * [11/16.19/16] atan(x) = atan( 1 ) + atan( (t-1)/(1+t) ) 22 | * [19/16,39/16] atan(x) = atan(3/2) + atan( (t-1.5)/(1+1.5t) ) 23 | * [39/16,INF] atan(x) = atan(INF) + atan( -1/t ) 24 | * 25 | * Constants: 26 | * The hexadecimal values are the intended ones for the following 27 | * constants. The decimal values may be used, provided that the 28 | * compiler will convert from decimal to binary accurately enough 29 | * to produce the hexadecimal values shown. 30 | */ 31 | 32 | 33 | #include "..\libmd.h" 34 | 35 | static const double atanhi[] = { 36 | 4.63647609000806093515e-01, /* atan(0.5)hi 0x3FDDAC67, 0x0561BB4F */ 37 | 7.85398163397448278999e-01, /* atan(1.0)hi 0x3FE921FB, 0x54442D18 */ 38 | 9.82793723247329054082e-01, /* atan(1.5)hi 0x3FEF730B, 0xD281F69B */ 39 | 1.57079632679489655800e+00, /* atan(inf)hi 0x3FF921FB, 0x54442D18 */ 40 | }; 41 | 42 | static const double atanlo[] = { 43 | 2.26987774529616870924e-17, /* atan(0.5)lo 0x3C7A2B7F, 0x222F65E2 */ 44 | 3.06161699786838301793e-17, /* atan(1.0)lo 0x3C81A626, 0x33145C07 */ 45 | 1.39033110312309984516e-17, /* atan(1.5)lo 0x3C700788, 0x7AF0CBBD */ 46 | 6.12323399573676603587e-17, /* atan(inf)lo 0x3C91A626, 0x33145C07 */ 47 | }; 48 | 49 | static const double aT[] = { 50 | 3.33333333333329318027e-01, /* 0x3FD55555, 0x5555550D */ 51 | -1.99999999998764832476e-01, /* 0xBFC99999, 0x9998EBC4 */ 52 | 1.42857142725034663711e-01, /* 0x3FC24924, 0x920083FF */ 53 | -1.11111104054623557880e-01, /* 0xBFBC71C6, 0xFE231671 */ 54 | 9.09088713343650656196e-02, /* 0x3FB745CD, 0xC54C206E */ 55 | -7.69187620504482999495e-02, /* 0xBFB3B0F2, 0xAF749A6D */ 56 | 6.66107313738753120669e-02, /* 0x3FB10D66, 0xA0D03D51 */ 57 | -5.83357013379057348645e-02, /* 0xBFADDE2D, 0x52DEFD9A */ 58 | 4.97687799461593236017e-02, /* 0x3FA97B4B, 0x24760DEB */ 59 | -3.65315727442169155270e-02, /* 0xBFA2B444, 0x2C6A6C2F */ 60 | 1.62858201153657823623e-02, /* 0x3F90AD3A, 0xE322DA11 */ 61 | }; 62 | 63 | double atan(double x) 64 | { 65 | double_t w,s1,s2,z; 66 | uint32_t ix,sign; 67 | int id; 68 | 69 | GET_HIGH_WORD(ix, x); 70 | sign = ix >> 31; 71 | ix &= 0x7fffffff; 72 | if (ix >= 0x44100000) { /* if |x| >= 2^66 */ 73 | if (isnan(x)) 74 | return x; 75 | z = atanhi[3] + 0x1p-120f; 76 | return sign ? -z : z; 77 | } 78 | if (ix < 0x3fdc0000) { /* |x| < 0.4375 */ 79 | if (ix < 0x3e400000) { /* |x| < 2^-27 */ 80 | if (ix < 0x00100000) 81 | /* raise underflow for subnormal x */ 82 | FORCE_EVAL((float)x); 83 | return x; 84 | } 85 | id = -1; 86 | } else { 87 | x = fabs(x); 88 | if (ix < 0x3ff30000) { /* |x| < 1.1875 */ 89 | if (ix < 0x3fe60000) { /* 7/16 <= |x| < 11/16 */ 90 | id = 0; 91 | x = (2.0*x-1.0)/(2.0+x); 92 | } else { /* 11/16 <= |x| < 19/16 */ 93 | id = 1; 94 | x = (x-1.0)/(x+1.0); 95 | } 96 | } else { 97 | if (ix < 0x40038000) { /* |x| < 2.4375 */ 98 | id = 2; 99 | x = (x-1.5)/(1.0+1.5*x); 100 | } else { /* 2.4375 <= |x| < 2^66 */ 101 | id = 3; 102 | x = -1.0/x; 103 | } 104 | } 105 | } 106 | /* end of argument reduction */ 107 | z = x*x; 108 | w = z*z; 109 | /* break sum from i=0 to 10 aT[i]z**(i+1) into odd and even poly */ 110 | s1 = z*(aT[0]+w*(aT[2]+w*(aT[4]+w*(aT[6]+w*(aT[8]+w*aT[10]))))); 111 | s2 = w*(aT[1]+w*(aT[3]+w*(aT[5]+w*(aT[7]+w*aT[9])))); 112 | if (id < 0) 113 | return x - x*(s1+s2); 114 | z = atanhi[id] - (x*(s1+s2) - atanlo[id] - x); 115 | return sign ? -z : z; 116 | } 117 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/atan2.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/e_atan2.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunSoft, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | * 12 | */ 13 | /* atan2(y,x) 14 | * Method : 15 | * 1. Reduce y to positive by atan2(y,x)=-atan2(-y,x). 16 | * 2. Reduce x to positive by (if x and y are unexceptional): 17 | * ARG (x+iy) = arctan(y/x) ... if x > 0, 18 | * ARG (x+iy) = pi - arctan[y/(-x)] ... if x < 0, 19 | * 20 | * Special cases: 21 | * 22 | * ATAN2((anything), NaN ) is NaN; 23 | * ATAN2(NAN , (anything) ) is NaN; 24 | * ATAN2(+-0, +(anything but NaN)) is +-0 ; 25 | * ATAN2(+-0, -(anything but NaN)) is +-pi ; 26 | * ATAN2(+-(anything but 0 and NaN), 0) is +-pi/2; 27 | * ATAN2(+-(anything but INF and NaN), +INF) is +-0 ; 28 | * ATAN2(+-(anything but INF and NaN), -INF) is +-pi; 29 | * ATAN2(+-INF,+INF ) is +-pi/4 ; 30 | * ATAN2(+-INF,-INF ) is +-3pi/4; 31 | * ATAN2(+-INF, (anything but,0,NaN, and INF)) is +-pi/2; 32 | * 33 | * Constants: 34 | * The hexadecimal values are the intended ones for the following 35 | * constants. The decimal values may be used, provided that the 36 | * compiler will convert from decimal to binary accurately enough 37 | * to produce the hexadecimal values shown. 38 | */ 39 | 40 | #include "..\libmd.h" 41 | 42 | static const double 43 | pi = 3.1415926535897931160E+00, /* 0x400921FB, 0x54442D18 */ 44 | pi_lo = 1.2246467991473531772E-16; /* 0x3CA1A626, 0x33145C07 */ 45 | 46 | double atan2(double y, double x) 47 | { 48 | double z; 49 | uint32_t m,lx,ly,ix,iy; 50 | 51 | if (isnan(x) || isnan(y)) 52 | return x+y; 53 | EXTRACT_WORDS(ix, lx, x); 54 | EXTRACT_WORDS(iy, ly, y); 55 | if (((ix-0x3ff00000) | lx) == 0) /* x = 1.0 */ 56 | return atan(y); 57 | m = ((iy>>31)&1) | ((ix>>30)&2); /* 2*sign(x)+sign(y) */ 58 | ix = ix & 0x7fffffff; 59 | iy = iy & 0x7fffffff; 60 | 61 | /* when y = 0 */ 62 | if ((iy|ly) == 0) { 63 | switch(m) { 64 | case 0: 65 | case 1: return y; /* atan(+-0,+anything)=+-0 */ 66 | case 2: return pi; /* atan(+0,-anything) = pi */ 67 | case 3: return -pi; /* atan(-0,-anything) =-pi */ 68 | } 69 | } 70 | /* when x = 0 */ 71 | if ((ix|lx) == 0) 72 | return m&1 ? -pi/2 : pi/2; 73 | /* when x is INF */ 74 | if (ix == 0x7ff00000) { 75 | if (iy == 0x7ff00000) { 76 | switch(m) { 77 | case 0: return pi/4; /* atan(+INF,+INF) */ 78 | case 1: return -pi/4; /* atan(-INF,+INF) */ 79 | case 2: return 3*pi/4; /* atan(+INF,-INF) */ 80 | case 3: return -3*pi/4; /* atan(-INF,-INF) */ 81 | } 82 | } else { 83 | switch(m) { 84 | case 0: return 0.0; /* atan(+...,+INF) */ 85 | case 1: return -0.0; /* atan(-...,+INF) */ 86 | case 2: return pi; /* atan(+...,-INF) */ 87 | case 3: return -pi; /* atan(-...,-INF) */ 88 | } 89 | } 90 | } 91 | /* |y/x| > 0x1p64 */ 92 | if (ix+(64<<20) < iy || iy == 0x7ff00000) 93 | return m&1 ? -pi/2 : pi/2; 94 | 95 | /* z = atan(|y/x|) without spurious underflow */ 96 | if ((m&2) && iy+(64<<20) < ix) /* |y/x| < 0x1p-64, x<0 */ 97 | z = 0; 98 | else 99 | z = atan(fabs(y/x)); 100 | switch (m) { 101 | case 0: return z; /* atan(+,+) */ 102 | case 1: return -z; /* atan(-,+) */ 103 | case 2: return pi - (z-pi_lo); /* atan(+,-) */ 104 | default: /* case 3 */ 105 | return (z-pi_lo) - pi; /* atan(-,-) */ 106 | } 107 | } 108 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/atanh.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | /* atanh(x) = log((1+x)/(1-x))/2 = log1p(2x/(1-x))/2 ~= x + x^3/3 + o(x^5) */ 4 | double atanh(double x) 5 | { 6 | union {double f; uint64_t i;} u = { x }; 7 | unsigned e = u.i >> 52 & 0x7ff; 8 | unsigned s = u.i >> 63; 9 | double_t y; 10 | 11 | /* |x| */ 12 | u.i &= (uint64_t)-1/2; 13 | y = u.f; 14 | 15 | if (e < 0x3ff - 1) { 16 | if (e < 0x3ff - 32) { 17 | /* handle underflow */ 18 | if (e == 0) 19 | FORCE_EVAL((float)y); 20 | } else { 21 | /* |x| < 0.5, up to 1.7ulp error */ 22 | y = 0.5*log1p(2*y + 2*y*y/(1-y)); 23 | } 24 | } else { 25 | /* avoid overflow */ 26 | y = 0.5*log1p(2*(y/(1-y))); 27 | } 28 | return s ? -y : y; 29 | } 30 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/ceil.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | #if FLT_EVAL_METHOD==0 || FLT_EVAL_METHOD==1 4 | #define EPS DBL_EPSILON 5 | #elif FLT_EVAL_METHOD==2 6 | #define EPS LDBL_EPSILON 7 | #endif 8 | static const double_t toint = 1/EPS; 9 | 10 | double ceil(double x) 11 | { 12 | union {double f; uint64_t i;} u = {x}; 13 | int e = u.i >> 52 & 0x7ff; 14 | double_t y; 15 | 16 | if (e >= 0x3ff+52 || x == 0) 17 | return x; 18 | /* y = int(x) - x, where int(x) is an integer neighbor of x */ 19 | if (u.i >> 63) 20 | y = x - toint + toint - x; 21 | else 22 | y = x + toint - toint - x; 23 | /* special case because of non-nearest rounding modes */ 24 | if (e <= 0x3ff-1) { 25 | FORCE_EVAL(y); 26 | return u.i >> 63 ? -0.0 : 1; 27 | } 28 | if (y < 0) 29 | return x + y + 1; 30 | return x + y; 31 | } 32 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/copysign.c: -------------------------------------------------------------------------------- 1 | /* 2 | * This file is part of the MicroPython project, http://micropython.org/ 3 | * 4 | * The MIT License (MIT) 5 | * 6 | * Copyright (c) 2013, 2014 Damien P. George 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in 16 | * all copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 24 | * THE SOFTWARE. 25 | */ 26 | 27 | #include "..\libmd.h" 28 | 29 | typedef union { 30 | double d; 31 | struct { 32 | uint64_t m : 52; 33 | uint64_t e : 11; 34 | uint64_t s : 1; 35 | }; 36 | } double_s_t; 37 | 38 | double copysign(double x, double y) { 39 | double_s_t dx = { x }; 40 | double_s_t dy = { y }; 41 | 42 | // copy sign bit; 43 | dx.s = dy.s; 44 | 45 | return dx.d; 46 | } -------------------------------------------------------------------------------- /NtLisp/crt/libmd/cos.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/s_cos.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunPro, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* cos(x) 13 | * Return cosine function of x. 14 | * 15 | * kernel function: 16 | * __sin ... sine function on [-pi/4,pi/4] 17 | * __cos ... cosine function on [-pi/4,pi/4] 18 | * __rem_pio2 ... argument reduction routine 19 | * 20 | * Method. 21 | * Let S,C and T denote the sin, cos and tan respectively on 22 | * [-PI/4, +PI/4]. Reduce the argument x to y1+y2 = x-k*pi/2 23 | * in [-pi/4 , +pi/4], and let n = k mod 4. 24 | * We have 25 | * 26 | * n sin(x) cos(x) tan(x) 27 | * ---------------------------------------------------------- 28 | * 0 S C T 29 | * 1 C -S -1/T 30 | * 2 -S -C T 31 | * 3 -C S -1/T 32 | * ---------------------------------------------------------- 33 | * 34 | * Special cases: 35 | * Let trig be any of sin, cos, or tan. 36 | * trig(+-INF) is NaN, with signals; 37 | * trig(NaN) is that NaN; 38 | * 39 | * Accuracy: 40 | * TRIG(x) returns trig(x) nearly rounded 41 | */ 42 | 43 | #include "..\libmd.h" 44 | 45 | double cos(double x) 46 | { 47 | double y[2]; 48 | uint32_t ix; 49 | unsigned n; 50 | 51 | GET_HIGH_WORD(ix, x); 52 | ix &= 0x7fffffff; 53 | 54 | /* |x| ~< pi/4 */ 55 | if (ix <= 0x3fe921fb) { 56 | if (ix < 0x3e46a09e) { /* |x| < 2**-27 * sqrt(2) */ 57 | /* raise inexact if x!=0 */ 58 | FORCE_EVAL(x + 0x1p120f); 59 | return 1.0; 60 | } 61 | return __cos(x, 0); 62 | } 63 | 64 | /* cos(Inf or NaN) is NaN */ 65 | if (ix >= 0x7ff00000) 66 | return x-x; 67 | 68 | /* argument reduction */ 69 | n = __rem_pio2(x, y); 70 | switch (n&3) { 71 | case 0: return __cos(y[0], y[1]); 72 | case 1: return -__sin(y[0], y[1], 1); 73 | case 2: return -__cos(y[0], y[1]); 74 | default: 75 | return __sin(y[0], y[1], 1); 76 | } 77 | } 78 | 79 | float cosf(float f) 80 | { 81 | return cos(f); 82 | } -------------------------------------------------------------------------------- /NtLisp/crt/libmd/cosh.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | /* cosh(x) = (exp(x) + 1/exp(x))/2 4 | * = 1 + 0.5*(exp(x)-1)*(exp(x)-1)/exp(x) 5 | * = 1 + x*x/2 + o(x^4) 6 | */ 7 | double cosh(double x) 8 | { 9 | union {double f; uint64_t i;} u = { x }; 10 | uint32_t w; 11 | double t; 12 | 13 | /* |x| */ 14 | u.i &= (uint64_t)-1/2; 15 | x = u.f; 16 | w = u.i >> 32; 17 | 18 | /* |x| < log(2) */ 19 | if (w < 0x3fe62e42) { 20 | if (w < 0x3ff00000 - (26<<20)) { 21 | /* raise inexact if x!=0 */ 22 | FORCE_EVAL(x + 0x1p120f); 23 | return 1; 24 | } 25 | t = expm1(x); 26 | return 1 + t*t/(2*(1+t)); 27 | } 28 | 29 | /* |x| < log(DBL_MAX) */ 30 | if (w < 0x40862e42) { 31 | t = exp(x); 32 | /* note: if x>log(0x1p26) then the 1/t is not needed */ 33 | return 0.5*(t + 1/t); 34 | } 35 | 36 | /* |x| > log(DBL_MAX) or nan */ 37 | /* note: the result is stored to handle overflow */ 38 | t = __expo2(x); 39 | return t; 40 | } 41 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/erf.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/s_erf.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunPro, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* double erf(double x) 13 | * double erfc(double x) 14 | * x 15 | * 2 |\ 16 | * erf(x) = --------- | exp(-t*t)dt 17 | * sqrt(pi) \| 18 | * 0 19 | * 20 | * erfc(x) = 1-erf(x) 21 | * Note that 22 | * erf(-x) = -erf(x) 23 | * erfc(-x) = 2 - erfc(x) 24 | * 25 | * Method: 26 | * 1. For |x| in [0, 0.84375] 27 | * erf(x) = x + x*R(x^2) 28 | * erfc(x) = 1 - erf(x) if x in [-.84375,0.25] 29 | * = 0.5 + ((0.5-x)-x*R) if x in [0.25,0.84375] 30 | * where R = P/Q where P is an odd poly of degree 8 and 31 | * Q is an odd poly of degree 10. 32 | * -57.90 33 | * | R - (erf(x)-x)/x | <= 2 34 | * 35 | * 36 | * Remark. The formula is derived by noting 37 | * erf(x) = (2/sqrt(pi))*(x - x^3/3 + x^5/10 - x^7/42 + ....) 38 | * and that 39 | * 2/sqrt(pi) = 1.128379167095512573896158903121545171688 40 | * is close to one. The interval is chosen because the fix 41 | * point of erf(x) is near 0.6174 (i.e., erf(x)=x when x is 42 | * near 0.6174), and by some experiment, 0.84375 is chosen to 43 | * guarantee the error is less than one ulp for erf. 44 | * 45 | * 2. For |x| in [0.84375,1.25], let s = |x| - 1, and 46 | * c = 0.84506291151 rounded to single (24 bits) 47 | * erf(x) = sign(x) * (c + P1(s)/Q1(s)) 48 | * erfc(x) = (1-c) - P1(s)/Q1(s) if x > 0 49 | * 1+(c+P1(s)/Q1(s)) if x < 0 50 | * |P1/Q1 - (erf(|x|)-c)| <= 2**-59.06 51 | * Remark: here we use the taylor series expansion at x=1. 52 | * erf(1+s) = erf(1) + s*Poly(s) 53 | * = 0.845.. + P1(s)/Q1(s) 54 | * That is, we use rational approximation to approximate 55 | * erf(1+s) - (c = (single)0.84506291151) 56 | * Note that |P1/Q1|< 0.078 for x in [0.84375,1.25] 57 | * where 58 | * P1(s) = degree 6 poly in s 59 | * Q1(s) = degree 6 poly in s 60 | * 61 | * 3. For x in [1.25,1/0.35(~2.857143)], 62 | * erfc(x) = (1/x)*exp(-x*x-0.5625+R1/S1) 63 | * erf(x) = 1 - erfc(x) 64 | * where 65 | * R1(z) = degree 7 poly in z, (z=1/x^2) 66 | * S1(z) = degree 8 poly in z 67 | * 68 | * 4. For x in [1/0.35,28] 69 | * erfc(x) = (1/x)*exp(-x*x-0.5625+R2/S2) if x > 0 70 | * = 2.0 - (1/x)*exp(-x*x-0.5625+R2/S2) if -6 x >= 28 96 | * erf(x) = sign(x) *(1 - tiny) (raise inexact) 97 | * erfc(x) = tiny*tiny (raise underflow) if x > 0 98 | * = 2 - tiny if x<0 99 | * 100 | * 7. Special case: 101 | * erf(0) = 0, erf(inf) = 1, erf(-inf) = -1, 102 | * erfc(0) = 1, erfc(inf) = 0, erfc(-inf) = 2, 103 | * erfc/erf(NaN) is NaN 104 | */ 105 | 106 | #include "..\libmd.h" 107 | 108 | static const double 109 | erx = 8.45062911510467529297e-01, /* 0x3FEB0AC1, 0x60000000 */ 110 | /* 111 | * Coefficients for approximation to erf on [0,0.84375] 112 | */ 113 | efx8 = 1.02703333676410069053e+00, /* 0x3FF06EBA, 0x8214DB69 */ 114 | pp0 = 1.28379167095512558561e-01, /* 0x3FC06EBA, 0x8214DB68 */ 115 | pp1 = -3.25042107247001499370e-01, /* 0xBFD4CD7D, 0x691CB913 */ 116 | pp2 = -2.84817495755985104766e-02, /* 0xBF9D2A51, 0xDBD7194F */ 117 | pp3 = -5.77027029648944159157e-03, /* 0xBF77A291, 0x236668E4 */ 118 | pp4 = -2.37630166566501626084e-05, /* 0xBEF8EAD6, 0x120016AC */ 119 | qq1 = 3.97917223959155352819e-01, /* 0x3FD97779, 0xCDDADC09 */ 120 | qq2 = 6.50222499887672944485e-02, /* 0x3FB0A54C, 0x5536CEBA */ 121 | qq3 = 5.08130628187576562776e-03, /* 0x3F74D022, 0xC4D36B0F */ 122 | qq4 = 1.32494738004321644526e-04, /* 0x3F215DC9, 0x221C1A10 */ 123 | qq5 = -3.96022827877536812320e-06, /* 0xBED09C43, 0x42A26120 */ 124 | /* 125 | * Coefficients for approximation to erf in [0.84375,1.25] 126 | */ 127 | pa0 = -2.36211856075265944077e-03, /* 0xBF6359B8, 0xBEF77538 */ 128 | pa1 = 4.14856118683748331666e-01, /* 0x3FDA8D00, 0xAD92B34D */ 129 | pa2 = -3.72207876035701323847e-01, /* 0xBFD7D240, 0xFBB8C3F1 */ 130 | pa3 = 3.18346619901161753674e-01, /* 0x3FD45FCA, 0x805120E4 */ 131 | pa4 = -1.10894694282396677476e-01, /* 0xBFBC6398, 0x3D3E28EC */ 132 | pa5 = 3.54783043256182359371e-02, /* 0x3FA22A36, 0x599795EB */ 133 | pa6 = -2.16637559486879084300e-03, /* 0xBF61BF38, 0x0A96073F */ 134 | qa1 = 1.06420880400844228286e-01, /* 0x3FBB3E66, 0x18EEE323 */ 135 | qa2 = 5.40397917702171048937e-01, /* 0x3FE14AF0, 0x92EB6F33 */ 136 | qa3 = 7.18286544141962662868e-02, /* 0x3FB2635C, 0xD99FE9A7 */ 137 | qa4 = 1.26171219808761642112e-01, /* 0x3FC02660, 0xE763351F */ 138 | qa5 = 1.36370839120290507362e-02, /* 0x3F8BEDC2, 0x6B51DD1C */ 139 | qa6 = 1.19844998467991074170e-02, /* 0x3F888B54, 0x5735151D */ 140 | /* 141 | * Coefficients for approximation to erfc in [1.25,1/0.35] 142 | */ 143 | ra0 = -9.86494403484714822705e-03, /* 0xBF843412, 0x600D6435 */ 144 | ra1 = -6.93858572707181764372e-01, /* 0xBFE63416, 0xE4BA7360 */ 145 | ra2 = -1.05586262253232909814e+01, /* 0xC0251E04, 0x41B0E726 */ 146 | ra3 = -6.23753324503260060396e+01, /* 0xC04F300A, 0xE4CBA38D */ 147 | ra4 = -1.62396669462573470355e+02, /* 0xC0644CB1, 0x84282266 */ 148 | ra5 = -1.84605092906711035994e+02, /* 0xC067135C, 0xEBCCABB2 */ 149 | ra6 = -8.12874355063065934246e+01, /* 0xC0545265, 0x57E4D2F2 */ 150 | ra7 = -9.81432934416914548592e+00, /* 0xC023A0EF, 0xC69AC25C */ 151 | sa1 = 1.96512716674392571292e+01, /* 0x4033A6B9, 0xBD707687 */ 152 | sa2 = 1.37657754143519042600e+02, /* 0x4061350C, 0x526AE721 */ 153 | sa3 = 4.34565877475229228821e+02, /* 0x407B290D, 0xD58A1A71 */ 154 | sa4 = 6.45387271733267880336e+02, /* 0x40842B19, 0x21EC2868 */ 155 | sa5 = 4.29008140027567833386e+02, /* 0x407AD021, 0x57700314 */ 156 | sa6 = 1.08635005541779435134e+02, /* 0x405B28A3, 0xEE48AE2C */ 157 | sa7 = 6.57024977031928170135e+00, /* 0x401A47EF, 0x8E484A93 */ 158 | sa8 = -6.04244152148580987438e-02, /* 0xBFAEEFF2, 0xEE749A62 */ 159 | /* 160 | * Coefficients for approximation to erfc in [1/.35,28] 161 | */ 162 | rb0 = -9.86494292470009928597e-03, /* 0xBF843412, 0x39E86F4A */ 163 | rb1 = -7.99283237680523006574e-01, /* 0xBFE993BA, 0x70C285DE */ 164 | rb2 = -1.77579549177547519889e+01, /* 0xC031C209, 0x555F995A */ 165 | rb3 = -1.60636384855821916062e+02, /* 0xC064145D, 0x43C5ED98 */ 166 | rb4 = -6.37566443368389627722e+02, /* 0xC083EC88, 0x1375F228 */ 167 | rb5 = -1.02509513161107724954e+03, /* 0xC0900461, 0x6A2E5992 */ 168 | rb6 = -4.83519191608651397019e+02, /* 0xC07E384E, 0x9BDC383F */ 169 | sb1 = 3.03380607434824582924e+01, /* 0x403E568B, 0x261D5190 */ 170 | sb2 = 3.25792512996573918826e+02, /* 0x40745CAE, 0x221B9F0A */ 171 | sb3 = 1.53672958608443695994e+03, /* 0x409802EB, 0x189D5118 */ 172 | sb4 = 3.19985821950859553908e+03, /* 0x40A8FFB7, 0x688C246A */ 173 | sb5 = 2.55305040643316442583e+03, /* 0x40A3F219, 0xCEDF3BE6 */ 174 | sb6 = 4.74528541206955367215e+02, /* 0x407DA874, 0xE79FE763 */ 175 | sb7 = -2.24409524465858183362e+01; /* 0xC03670E2, 0x42712D62 */ 176 | 177 | static double erfc1(double x) 178 | { 179 | double_t s,P,Q; 180 | 181 | s = fabs(x) - 1; 182 | P = pa0+s*(pa1+s*(pa2+s*(pa3+s*(pa4+s*(pa5+s*pa6))))); 183 | Q = 1+s*(qa1+s*(qa2+s*(qa3+s*(qa4+s*(qa5+s*qa6))))); 184 | return 1 - erx - P/Q; 185 | } 186 | 187 | static double erfc2(uint32_t ix, double x) 188 | { 189 | double_t s,R,S; 190 | double z; 191 | 192 | if (ix < 0x3ff40000) /* |x| < 1.25 */ 193 | return erfc1(x); 194 | 195 | x = fabs(x); 196 | s = 1/(x*x); 197 | if (ix < 0x4006db6d) { /* |x| < 1/.35 ~ 2.85714 */ 198 | R = ra0+s*(ra1+s*(ra2+s*(ra3+s*(ra4+s*( 199 | ra5+s*(ra6+s*ra7)))))); 200 | S = 1.0+s*(sa1+s*(sa2+s*(sa3+s*(sa4+s*( 201 | sa5+s*(sa6+s*(sa7+s*sa8))))))); 202 | } else { /* |x| > 1/.35 */ 203 | R = rb0+s*(rb1+s*(rb2+s*(rb3+s*(rb4+s*( 204 | rb5+s*rb6))))); 205 | S = 1.0+s*(sb1+s*(sb2+s*(sb3+s*(sb4+s*( 206 | sb5+s*(sb6+s*sb7)))))); 207 | } 208 | z = x; 209 | SET_LOW_WORD(z,0); 210 | return exp(-z*z-0.5625)*exp((z-x)*(z+x)+R/S)/x; 211 | } 212 | 213 | double erf(double x) 214 | { 215 | double r,s,z,y; 216 | uint32_t ix; 217 | int sign; 218 | 219 | GET_HIGH_WORD(ix, x); 220 | sign = ix>>31; 221 | ix &= 0x7fffffff; 222 | if (ix >= 0x7ff00000) { 223 | /* erf(nan)=nan, erf(+-inf)=+-1 */ 224 | return 1-2*sign + 1/x; 225 | } 226 | if (ix < 0x3feb0000) { /* |x| < 0.84375 */ 227 | if (ix < 0x3e300000) { /* |x| < 2**-28 */ 228 | /* avoid underflow */ 229 | return 0.125*(8*x + efx8*x); 230 | } 231 | z = x*x; 232 | r = pp0+z*(pp1+z*(pp2+z*(pp3+z*pp4))); 233 | s = 1.0+z*(qq1+z*(qq2+z*(qq3+z*(qq4+z*qq5)))); 234 | y = r/s; 235 | return x + x*y; 236 | } 237 | if (ix < 0x40180000) /* 0.84375 <= |x| < 6 */ 238 | y = 1 - erfc2(ix,x); 239 | else 240 | y = 1 - 0x1p-1022; 241 | return sign ? -y : y; 242 | } 243 | 244 | double erfc(double x) 245 | { 246 | double r,s,z,y; 247 | uint32_t ix; 248 | int sign; 249 | 250 | GET_HIGH_WORD(ix, x); 251 | sign = ix>>31; 252 | ix &= 0x7fffffff; 253 | if (ix >= 0x7ff00000) { 254 | /* erfc(nan)=nan, erfc(+-inf)=0,2 */ 255 | return 2*sign + 1/x; 256 | } 257 | if (ix < 0x3feb0000) { /* |x| < 0.84375 */ 258 | if (ix < 0x3c700000) /* |x| < 2**-56 */ 259 | return 1.0 - x; 260 | z = x*x; 261 | r = pp0+z*(pp1+z*(pp2+z*(pp3+z*pp4))); 262 | s = 1.0+z*(qq1+z*(qq2+z*(qq3+z*(qq4+z*qq5)))); 263 | y = r/s; 264 | if (sign || ix < 0x3fd00000) { /* x < 1/4 */ 265 | return 1.0 - (x+x*y); 266 | } 267 | return 0.5 - (x - 0.5 + x*y); 268 | } 269 | if (ix < 0x403c0000) { /* 0.84375 <= |x| < 28 */ 270 | return sign ? 2 - erfc2(ix,x) : erfc2(ix,x); 271 | } 272 | return sign ? 2 - 0x1p-1022 : 0x1p-1022*0x1p-1022; 273 | } 274 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/exp.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/e_exp.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 2004 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Permission to use, copy, modify, and distribute this 7 | * software is freely granted, provided that this notice 8 | * is preserved. 9 | * ==================================================== 10 | */ 11 | /* exp(x) 12 | * Returns the exponential of x. 13 | * 14 | * Method 15 | * 1. Argument reduction: 16 | * Reduce x to an r so that |r| <= 0.5*ln2 ~ 0.34658. 17 | * Given x, find r and integer k such that 18 | * 19 | * x = k*ln2 + r, |r| <= 0.5*ln2. 20 | * 21 | * Here r will be represented as r = hi-lo for better 22 | * accuracy. 23 | * 24 | * 2. Approximation of exp(r) by a special rational function on 25 | * the interval [0,0.34658]: 26 | * Write 27 | * R(r**2) = r*(exp(r)+1)/(exp(r)-1) = 2 + r*r/6 - r**4/360 + ... 28 | * We use a special Remez algorithm on [0,0.34658] to generate 29 | * a polynomial of degree 5 to approximate R. The maximum error 30 | * of this polynomial approximation is bounded by 2**-59. In 31 | * other words, 32 | * R(z) ~ 2.0 + P1*z + P2*z**2 + P3*z**3 + P4*z**4 + P5*z**5 33 | * (where z=r*r, and the values of P1 to P5 are listed below) 34 | * and 35 | * | 5 | -59 36 | * | 2.0+P1*z+...+P5*z - R(z) | <= 2 37 | * | | 38 | * The computation of exp(r) thus becomes 39 | * 2*r 40 | * exp(r) = 1 + ---------- 41 | * R(r) - r 42 | * r*c(r) 43 | * = 1 + r + ----------- (for better accuracy) 44 | * 2 - c(r) 45 | * where 46 | * 2 4 10 47 | * c(r) = r - (P1*r + P2*r + ... + P5*r ). 48 | * 49 | * 3. Scale back to obtain exp(x): 50 | * From step 1, we have 51 | * exp(x) = 2^k * exp(r) 52 | * 53 | * Special cases: 54 | * exp(INF) is INF, exp(NaN) is NaN; 55 | * exp(-INF) is 0, and 56 | * for finite argument, only exp(0)=1 is exact. 57 | * 58 | * Accuracy: 59 | * according to an error analysis, the error is always less than 60 | * 1 ulp (unit in the last place). 61 | * 62 | * Misc. info. 63 | * For IEEE double 64 | * if x > 709.782712893383973096 then exp(x) overflows 65 | * if x < -745.133219101941108420 then exp(x) underflows 66 | */ 67 | 68 | #include "..\libmd.h" 69 | 70 | static const double 71 | half[2] = {0.5,-0.5}, 72 | ln2hi = 6.93147180369123816490e-01, /* 0x3fe62e42, 0xfee00000 */ 73 | ln2lo = 1.90821492927058770002e-10, /* 0x3dea39ef, 0x35793c76 */ 74 | invln2 = 1.44269504088896338700e+00, /* 0x3ff71547, 0x652b82fe */ 75 | P1 = 1.66666666666666019037e-01, /* 0x3FC55555, 0x5555553E */ 76 | P2 = -2.77777777770155933842e-03, /* 0xBF66C16C, 0x16BEBD93 */ 77 | P3 = 6.61375632143793436117e-05, /* 0x3F11566A, 0xAF25DE2C */ 78 | P4 = -1.65339022054652515390e-06, /* 0xBEBBBD41, 0xC5D26BF1 */ 79 | P5 = 4.13813679705723846039e-08; /* 0x3E663769, 0x72BEA4D0 */ 80 | 81 | double exp(double x) 82 | { 83 | double_t hi, lo, c, xx, y; 84 | int k, sign; 85 | uint32_t hx; 86 | 87 | GET_HIGH_WORD(hx, x); 88 | sign = hx>>31; 89 | hx &= 0x7fffffff; /* high word of |x| */ 90 | 91 | /* special cases */ 92 | if (hx >= 0x4086232b) { /* if |x| >= 708.39... */ 93 | if (isnan(x)) 94 | return x; 95 | if (x > 709.782712893383973096) { 96 | /* overflow if x!=inf */ 97 | x *= 0x1p1023; 98 | return x; 99 | } 100 | if (x < -708.39641853226410622) { 101 | /* underflow if x!=-inf */ 102 | FORCE_EVAL((float)(-0x1p-149/x)); 103 | if (x < -745.13321910194110842) 104 | return 0; 105 | } 106 | } 107 | 108 | /* argument reduction */ 109 | if (hx > 0x3fd62e42) { /* if |x| > 0.5 ln2 */ 110 | if (hx >= 0x3ff0a2b2) /* if |x| >= 1.5 ln2 */ 111 | k = (int)(invln2*x + half[sign]); 112 | else 113 | k = 1 - sign - sign; 114 | hi = x - k*ln2hi; /* k*ln2hi is exact here */ 115 | lo = k*ln2lo; 116 | x = hi - lo; 117 | } else if (hx > 0x3e300000) { /* if |x| > 2**-28 */ 118 | k = 0; 119 | hi = x; 120 | lo = 0; 121 | } else { 122 | /* inexact if x!=0 */ 123 | FORCE_EVAL(0x1p1023 + x); 124 | return 1 + x; 125 | } 126 | 127 | /* x is now in primary range */ 128 | xx = x*x; 129 | c = x - xx*(P1+xx*(P2+xx*(P3+xx*(P4+xx*P5)))); 130 | y = 1 + (x*c/(2-c) - lo + hi); 131 | if (k == 0) 132 | return y; 133 | return scalbn(y, k); 134 | } 135 | 136 | float expf(float f) 137 | { 138 | return exp(f); 139 | } -------------------------------------------------------------------------------- /NtLisp/crt/libmd/expm1.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/s_expm1.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunPro, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* expm1(x) 13 | * Returns exp(x)-1, the exponential of x minus 1. 14 | * 15 | * Method 16 | * 1. Argument reduction: 17 | * Given x, find r and integer k such that 18 | * 19 | * x = k*ln2 + r, |r| <= 0.5*ln2 ~ 0.34658 20 | * 21 | * Here a correction term c will be computed to compensate 22 | * the error in r when rounded to a floating-point number. 23 | * 24 | * 2. Approximating expm1(r) by a special rational function on 25 | * the interval [0,0.34658]: 26 | * Since 27 | * r*(exp(r)+1)/(exp(r)-1) = 2+ r^2/6 - r^4/360 + ... 28 | * we define R1(r*r) by 29 | * r*(exp(r)+1)/(exp(r)-1) = 2+ r^2/6 * R1(r*r) 30 | * That is, 31 | * R1(r**2) = 6/r *((exp(r)+1)/(exp(r)-1) - 2/r) 32 | * = 6/r * ( 1 + 2.0*(1/(exp(r)-1) - 1/r)) 33 | * = 1 - r^2/60 + r^4/2520 - r^6/100800 + ... 34 | * We use a special Remez algorithm on [0,0.347] to generate 35 | * a polynomial of degree 5 in r*r to approximate R1. The 36 | * maximum error of this polynomial approximation is bounded 37 | * by 2**-61. In other words, 38 | * R1(z) ~ 1.0 + Q1*z + Q2*z**2 + Q3*z**3 + Q4*z**4 + Q5*z**5 39 | * where Q1 = -1.6666666666666567384E-2, 40 | * Q2 = 3.9682539681370365873E-4, 41 | * Q3 = -9.9206344733435987357E-6, 42 | * Q4 = 2.5051361420808517002E-7, 43 | * Q5 = -6.2843505682382617102E-9; 44 | * z = r*r, 45 | * with error bounded by 46 | * | 5 | -61 47 | * | 1.0+Q1*z+...+Q5*z - R1(z) | <= 2 48 | * | | 49 | * 50 | * expm1(r) = exp(r)-1 is then computed by the following 51 | * specific way which minimize the accumulation rounding error: 52 | * 2 3 53 | * r r [ 3 - (R1 + R1*r/2) ] 54 | * expm1(r) = r + --- + --- * [--------------------] 55 | * 2 2 [ 6 - r*(3 - R1*r/2) ] 56 | * 57 | * To compensate the error in the argument reduction, we use 58 | * expm1(r+c) = expm1(r) + c + expm1(r)*c 59 | * ~ expm1(r) + c + r*c 60 | * Thus c+r*c will be added in as the correction terms for 61 | * expm1(r+c). Now rearrange the term to avoid optimization 62 | * screw up: 63 | * ( 2 2 ) 64 | * ({ ( r [ R1 - (3 - R1*r/2) ] ) } r ) 65 | * expm1(r+c)~r - ({r*(--- * [--------------------]-c)-c} - --- ) 66 | * ({ ( 2 [ 6 - r*(3 - R1*r/2) ] ) } 2 ) 67 | * ( ) 68 | * 69 | * = r - E 70 | * 3. Scale back to obtain expm1(x): 71 | * From step 1, we have 72 | * expm1(x) = either 2^k*[expm1(r)+1] - 1 73 | * = or 2^k*[expm1(r) + (1-2^-k)] 74 | * 4. Implementation notes: 75 | * (A). To save one multiplication, we scale the coefficient Qi 76 | * to Qi*2^i, and replace z by (x^2)/2. 77 | * (B). To achieve maximum accuracy, we compute expm1(x) by 78 | * (i) if x < -56*ln2, return -1.0, (raise inexact if x!=inf) 79 | * (ii) if k=0, return r-E 80 | * (iii) if k=-1, return 0.5*(r-E)-0.5 81 | * (iv) if k=1 if r < -0.25, return 2*((r+0.5)- E) 82 | * else return 1.0+2.0*(r-E); 83 | * (v) if (k<-2||k>56) return 2^k(1-(E-r)) - 1 (or exp(x)-1) 84 | * (vi) if k <= 20, return 2^k((1-2^-k)-(E-r)), else 85 | * (vii) return 2^k(1-((E+2^-k)-r)) 86 | * 87 | * Special cases: 88 | * expm1(INF) is INF, expm1(NaN) is NaN; 89 | * expm1(-INF) is -1, and 90 | * for finite argument, only expm1(0)=0 is exact. 91 | * 92 | * Accuracy: 93 | * according to an error analysis, the error is always less than 94 | * 1 ulp (unit in the last place). 95 | * 96 | * Misc. info. 97 | * For IEEE double 98 | * if x > 7.09782712893383973096e+02 then expm1(x) overflow 99 | * 100 | * Constants: 101 | * The hexadecimal values are the intended ones for the following 102 | * constants. The decimal values may be used, provided that the 103 | * compiler will convert from decimal to binary accurately enough 104 | * to produce the hexadecimal values shown. 105 | */ 106 | 107 | #include "..\libmd.h" 108 | 109 | static const double 110 | o_threshold = 7.09782712893383973096e+02, /* 0x40862E42, 0xFEFA39EF */ 111 | ln2_hi = 6.93147180369123816490e-01, /* 0x3fe62e42, 0xfee00000 */ 112 | ln2_lo = 1.90821492927058770002e-10, /* 0x3dea39ef, 0x35793c76 */ 113 | invln2 = 1.44269504088896338700e+00, /* 0x3ff71547, 0x652b82fe */ 114 | /* Scaled Q's: Qn_here = 2**n * Qn_above, for R(2*z) where z = hxs = x*x/2: */ 115 | Q1 = -3.33333333333331316428e-02, /* BFA11111 111110F4 */ 116 | Q2 = 1.58730158725481460165e-03, /* 3F5A01A0 19FE5585 */ 117 | Q3 = -7.93650757867487942473e-05, /* BF14CE19 9EAADBB7 */ 118 | Q4 = 4.00821782732936239552e-06, /* 3ED0CFCA 86E65239 */ 119 | Q5 = -2.01099218183624371326e-07; /* BE8AFDB7 6E09C32D */ 120 | 121 | double expm1(double x) 122 | { 123 | double_t y,hi,lo,c,t,e,hxs,hfx,r1,twopk; 124 | union {double f; uint64_t i;} u = {x}; 125 | uint32_t hx = u.i>>32 & 0x7fffffff; 126 | int k, sign = u.i>>63; 127 | 128 | /* filter out huge and non-finite argument */ 129 | if (hx >= 0x4043687A) { /* if |x|>=56*ln2 */ 130 | if (isnan(x)) 131 | return x; 132 | if (sign) 133 | return -1; 134 | if (x > o_threshold) { 135 | x *= 0x1p1023; 136 | return x; 137 | } 138 | } 139 | 140 | /* argument reduction */ 141 | if (hx > 0x3fd62e42) { /* if |x| > 0.5 ln2 */ 142 | if (hx < 0x3FF0A2B2) { /* and |x| < 1.5 ln2 */ 143 | if (!sign) { 144 | hi = x - ln2_hi; 145 | lo = ln2_lo; 146 | k = 1; 147 | } else { 148 | hi = x + ln2_hi; 149 | lo = -ln2_lo; 150 | k = -1; 151 | } 152 | } else { 153 | k = invln2*x + (sign ? -0.5 : 0.5); 154 | t = k; 155 | hi = x - t*ln2_hi; /* t*ln2_hi is exact here */ 156 | lo = t*ln2_lo; 157 | } 158 | x = hi-lo; 159 | c = (hi-x)-lo; 160 | } else if (hx < 0x3c900000) { /* |x| < 2**-54, return x */ 161 | if (hx < 0x00100000) 162 | FORCE_EVAL((float)x); 163 | return x; 164 | } else 165 | k = 0; 166 | 167 | /* x is now in primary range */ 168 | hfx = 0.5*x; 169 | hxs = x*hfx; 170 | r1 = 1.0+hxs*(Q1+hxs*(Q2+hxs*(Q3+hxs*(Q4+hxs*Q5)))); 171 | t = 3.0-r1*hfx; 172 | e = hxs*((r1-t)/(6.0 - x*t)); 173 | if (k == 0) /* c is 0 */ 174 | return x - (x*e-hxs); 175 | e = x*(e-c) - c; 176 | e -= hxs; 177 | /* exp(x) ~ 2^k (x_reduced - e + 1) */ 178 | if (k == -1) 179 | return 0.5*(x-e) - 0.5; 180 | if (k == 1) { 181 | if (x < -0.25) 182 | return -2.0*(e-(x+0.5)); 183 | return 1.0+2.0*(x-e); 184 | } 185 | u.i = (uint64_t)(0x3ff + k)<<52; /* 2^k */ 186 | twopk = u.f; 187 | if (k < 0 || k > 56) { /* suffice to return exp(x)-1 */ 188 | y = x - e + 1.0; 189 | if (k == 1024) 190 | y = y*2.0*0x1p1023; 191 | else 192 | y = y*twopk; 193 | return y - 1.0; 194 | } 195 | u.i = (uint64_t)(0x3ff - k)<<52; /* 2^-k */ 196 | if (k < 20) 197 | y = (x-e+(1-u.f))*twopk; 198 | else 199 | y = (x-(e+u.f)+1)*twopk; 200 | return y; 201 | } 202 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/fabs.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | typedef union 4 | { 5 | double d; 6 | struct 7 | { 8 | uint64_t m : 52; 9 | uint64_t e : 11; 10 | uint64_t s : 1; 11 | }; 12 | } double_s_t; 13 | 14 | double fabs( double x ) 15 | { 16 | double_s_t dx = { x }; 17 | dx.s = 0; 18 | return dx.d; 19 | } -------------------------------------------------------------------------------- /NtLisp/crt/libmd/floor.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | #if FLT_EVAL_METHOD==0 || FLT_EVAL_METHOD==1 4 | #define EPS DBL_EPSILON 5 | #elif FLT_EVAL_METHOD==2 6 | #define EPS LDBL_EPSILON 7 | #endif 8 | static const double_t toint = 1/EPS; 9 | 10 | double floor(double x) 11 | { 12 | union {double f; uint64_t i;} u = {x}; 13 | int e = u.i >> 52 & 0x7ff; 14 | double_t y; 15 | 16 | if (e >= 0x3ff+52 || x == 0) 17 | return x; 18 | /* y = int(x) - x, where int(x) is an integer neighbor of x */ 19 | if (u.i >> 63) 20 | y = x - toint + toint - x; 21 | else 22 | y = x + toint - toint - x; 23 | /* special case because of non-nearest rounding modes */ 24 | if (e <= 0x3ff-1) { 25 | FORCE_EVAL(y); 26 | return u.i >> 63 ? -1 : 0; 27 | } 28 | if (y > 0) 29 | return x + y - 1; 30 | return x + y; 31 | } 32 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/fmod.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | double fmod(double x, double y) 4 | { 5 | union {double f; uint64_t i;} ux = {x}, uy = {y}; 6 | int ex = ux.i>>52 & 0x7ff; 7 | int ey = uy.i>>52 & 0x7ff; 8 | int sx = ux.i>>63; 9 | uint64_t i; 10 | 11 | /* in the followings uxi should be ux.i, but then gcc wrongly adds */ 12 | /* float load/store to inner loops ruining performance and code size */ 13 | uint64_t uxi = ux.i; 14 | 15 | if (uy.i<<1 == 0 || isnan(y) || ex == 0x7ff) 16 | return (x*y)/(x*y); 17 | if (uxi<<1 <= uy.i<<1) { 18 | if (uxi<<1 == uy.i<<1) 19 | return 0*x; 20 | return x; 21 | } 22 | 23 | /* normalize x and y */ 24 | if (!ex) { 25 | for (i = uxi<<12; i>>63 == 0; ex--, i <<= 1); 26 | uxi <<= -ex + 1; 27 | } else { 28 | uxi &= -1ULL >> 12; 29 | uxi |= 1ULL << 52; 30 | } 31 | if (!ey) { 32 | for (i = uy.i<<12; i>>63 == 0; ey--, i <<= 1); 33 | uy.i <<= -ey + 1; 34 | } else { 35 | uy.i &= -1ULL >> 12; 36 | uy.i |= 1ULL << 52; 37 | } 38 | 39 | /* x mod y */ 40 | for (; ex > ey; ex--) { 41 | i = uxi - uy.i; 42 | if (i >> 63 == 0) { 43 | if (i == 0) 44 | return 0*x; 45 | uxi = i; 46 | } 47 | uxi <<= 1; 48 | } 49 | i = uxi - uy.i; 50 | if (i >> 63 == 0) { 51 | if (i == 0) 52 | return 0*x; 53 | uxi = i; 54 | } 55 | for (; uxi>>52 == 0; uxi <<= 1, ex--); 56 | 57 | /* scale result */ 58 | if (ex > 0) { 59 | uxi -= 1ULL << 52; 60 | uxi |= (uint64_t)ex << 52; 61 | } else { 62 | uxi >>= -ex + 1; 63 | } 64 | uxi |= (uint64_t)sx << 63; 65 | ux.i = uxi; 66 | return ux.f; 67 | } 68 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/fpclassify.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | int fpclassify(double x) 4 | { 5 | union {double f; uint64_t i;} u = {x}; 6 | int e = u.i>>52 & 0x7ff; 7 | if (!e) return u.i<<1 ? FP_SUBNORMAL : FP_ZERO; 8 | if (e==0x7ff) return u.i<<12 ? FP_NAN : FP_INFINITE; 9 | return FP_NORMAL; 10 | } 11 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/frexp.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | double frexp(double x, int *e) 4 | { 5 | union { double d; uint64_t i; } y = { x }; 6 | int ee = y.i>>52 & 0x7ff; 7 | 8 | if (!ee) { 9 | if (x) { 10 | x = frexp(x*0x1p64, e); 11 | *e -= 64; 12 | } else *e = 0; 13 | return x; 14 | } else if (ee == 0x7ff) { 15 | return x; 16 | } 17 | 18 | *e = ee - 0x3fe; 19 | y.i &= 0x800fffffffffffffull; 20 | y.i |= 0x3fe0000000000000ull; 21 | return y.d; 22 | } 23 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/ldexp.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | double ldexp(double x, int n) 4 | { 5 | return scalbn(x, n); 6 | } 7 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/lgamma.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | double __lgamma_r(double, int*); 4 | 5 | double lgamma(double x) { 6 | int sign; 7 | return __lgamma_r(x, &sign); 8 | } 9 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/log.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/e_log.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunSoft, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* log(x) 13 | * Return the logarithm of x 14 | * 15 | * Method : 16 | * 1. Argument Reduction: find k and f such that 17 | * x = 2^k * (1+f), 18 | * where sqrt(2)/2 < 1+f < sqrt(2) . 19 | * 20 | * 2. Approximation of log(1+f). 21 | * Let s = f/(2+f) ; based on log(1+f) = log(1+s) - log(1-s) 22 | * = 2s + 2/3 s**3 + 2/5 s**5 + ....., 23 | * = 2s + s*R 24 | * We use a special Remez algorithm on [0,0.1716] to generate 25 | * a polynomial of degree 14 to approximate R The maximum error 26 | * of this polynomial approximation is bounded by 2**-58.45. In 27 | * other words, 28 | * 2 4 6 8 10 12 14 29 | * R(z) ~ Lg1*s +Lg2*s +Lg3*s +Lg4*s +Lg5*s +Lg6*s +Lg7*s 30 | * (the values of Lg1 to Lg7 are listed in the program) 31 | * and 32 | * | 2 14 | -58.45 33 | * | Lg1*s +...+Lg7*s - R(z) | <= 2 34 | * | | 35 | * Note that 2s = f - s*f = f - hfsq + s*hfsq, where hfsq = f*f/2. 36 | * In order to guarantee error in log below 1ulp, we compute log 37 | * by 38 | * log(1+f) = f - s*(f - R) (if f is not too large) 39 | * log(1+f) = f - (hfsq - s*(hfsq+R)). (better accuracy) 40 | * 41 | * 3. Finally, log(x) = k*ln2 + log(1+f). 42 | * = k*ln2_hi+(f-(hfsq-(s*(hfsq+R)+k*ln2_lo))) 43 | * Here ln2 is split into two floating point number: 44 | * ln2_hi + ln2_lo, 45 | * where n*ln2_hi is always exact for |n| < 2000. 46 | * 47 | * Special cases: 48 | * log(x) is NaN with signal if x < 0 (including -INF) ; 49 | * log(+INF) is +INF; log(0) is -INF with signal; 50 | * log(NaN) is that NaN with no signal. 51 | * 52 | * Accuracy: 53 | * according to an error analysis, the error is always less than 54 | * 1 ulp (unit in the last place). 55 | * 56 | * Constants: 57 | * The hexadecimal values are the intended ones for the following 58 | * constants. The decimal values may be used, provided that the 59 | * compiler will convert from decimal to binary accurately enough 60 | * to produce the hexadecimal values shown. 61 | */ 62 | 63 | #include "..\libmd.h" 64 | 65 | static const double 66 | ln2_hi = 6.93147180369123816490e-01, /* 3fe62e42 fee00000 */ 67 | ln2_lo = 1.90821492927058770002e-10, /* 3dea39ef 35793c76 */ 68 | Lg1 = 6.666666666666735130e-01, /* 3FE55555 55555593 */ 69 | Lg2 = 3.999999999940941908e-01, /* 3FD99999 9997FA04 */ 70 | Lg3 = 2.857142874366239149e-01, /* 3FD24924 94229359 */ 71 | Lg4 = 2.222219843214978396e-01, /* 3FCC71C5 1D8E78AF */ 72 | Lg5 = 1.818357216161805012e-01, /* 3FC74664 96CB03DE */ 73 | Lg6 = 1.531383769920937332e-01, /* 3FC39A09 D078C69F */ 74 | Lg7 = 1.479819860511658591e-01; /* 3FC2F112 DF3E5244 */ 75 | 76 | double log(double x) 77 | { 78 | union {double f; uint64_t i;} u = {x}; 79 | double_t hfsq,f,s,z,R,w,t1,t2,dk; 80 | uint32_t hx; 81 | int k; 82 | 83 | hx = u.i>>32; 84 | k = 0; 85 | if (hx < 0x00100000 || hx>>31) { 86 | if (u.i<<1 == 0) 87 | return -1/(x*x); /* log(+-0)=-inf */ 88 | if (hx>>31) 89 | return (x-x)/0.0; /* log(-#) = NaN */ 90 | /* subnormal number, scale x up */ 91 | k -= 54; 92 | x *= 0x1p54; 93 | u.f = x; 94 | hx = u.i>>32; 95 | } else if (hx >= 0x7ff00000) { 96 | return x; 97 | } else if (hx == 0x3ff00000 && u.i<<32 == 0) 98 | return 0; 99 | 100 | /* reduce x into [sqrt(2)/2, sqrt(2)] */ 101 | hx += 0x3ff00000 - 0x3fe6a09e; 102 | k += (int)(hx>>20) - 0x3ff; 103 | hx = (hx&0x000fffff) + 0x3fe6a09e; 104 | u.i = (uint64_t)hx<<32 | (u.i&0xffffffff); 105 | x = u.f; 106 | 107 | f = x - 1.0; 108 | hfsq = 0.5*f*f; 109 | s = f/(2.0+f); 110 | z = s*s; 111 | w = z*z; 112 | t1 = w*(Lg2+w*(Lg4+w*Lg6)); 113 | t2 = z*(Lg1+w*(Lg3+w*(Lg5+w*Lg7))); 114 | R = t2 + t1; 115 | dk = k; 116 | return s*(hfsq+R) + dk*ln2_lo - hfsq + f + dk*ln2_hi; 117 | } 118 | 119 | float logf(float f) 120 | { 121 | return log(f); 122 | } -------------------------------------------------------------------------------- /NtLisp/crt/libmd/log10.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | static const double _M_LN10 = 2.302585092994046; 4 | 5 | double log10(double x) { 6 | return log(x) / (double)_M_LN10; 7 | } 8 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/log1p.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/s_log1p.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunPro, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* double log1p(double x) 13 | * Return the natural logarithm of 1+x. 14 | * 15 | * Method : 16 | * 1. Argument Reduction: find k and f such that 17 | * 1+x = 2^k * (1+f), 18 | * where sqrt(2)/2 < 1+f < sqrt(2) . 19 | * 20 | * Note. If k=0, then f=x is exact. However, if k!=0, then f 21 | * may not be representable exactly. In that case, a correction 22 | * term is need. Let u=1+x rounded. Let c = (1+x)-u, then 23 | * log(1+x) - log(u) ~ c/u. Thus, we proceed to compute log(u), 24 | * and add back the correction term c/u. 25 | * (Note: when x > 2**53, one can simply return log(x)) 26 | * 27 | * 2. Approximation of log(1+f): See log.c 28 | * 29 | * 3. Finally, log1p(x) = k*ln2 + log(1+f) + c/u. See log.c 30 | * 31 | * Special cases: 32 | * log1p(x) is NaN with signal if x < -1 (including -INF) ; 33 | * log1p(+INF) is +INF; log1p(-1) is -INF with signal; 34 | * log1p(NaN) is that NaN with no signal. 35 | * 36 | * Accuracy: 37 | * according to an error analysis, the error is always less than 38 | * 1 ulp (unit in the last place). 39 | * 40 | * Constants: 41 | * The hexadecimal values are the intended ones for the following 42 | * constants. The decimal values may be used, provided that the 43 | * compiler will convert from decimal to binary accurately enough 44 | * to produce the hexadecimal values shown. 45 | * 46 | * Note: Assuming log() return accurate answer, the following 47 | * algorithm can be used to compute log1p(x) to within a few ULP: 48 | * 49 | * u = 1+x; 50 | * if(u==1.0) return x ; else 51 | * return log(u)*(x/(u-1.0)); 52 | * 53 | * See HP-15C Advanced Functions Handbook, p.193. 54 | */ 55 | 56 | #include "..\libmd.h" 57 | 58 | static const double 59 | ln2_hi = 6.93147180369123816490e-01, /* 3fe62e42 fee00000 */ 60 | ln2_lo = 1.90821492927058770002e-10, /* 3dea39ef 35793c76 */ 61 | Lg1 = 6.666666666666735130e-01, /* 3FE55555 55555593 */ 62 | Lg2 = 3.999999999940941908e-01, /* 3FD99999 9997FA04 */ 63 | Lg3 = 2.857142874366239149e-01, /* 3FD24924 94229359 */ 64 | Lg4 = 2.222219843214978396e-01, /* 3FCC71C5 1D8E78AF */ 65 | Lg5 = 1.818357216161805012e-01, /* 3FC74664 96CB03DE */ 66 | Lg6 = 1.531383769920937332e-01, /* 3FC39A09 D078C69F */ 67 | Lg7 = 1.479819860511658591e-01; /* 3FC2F112 DF3E5244 */ 68 | 69 | double log1p(double x) 70 | { 71 | union {double f; uint64_t i;} u = {x}; 72 | double_t hfsq,f,c,s,z,R,w,t1,t2,dk; 73 | uint32_t hx,hu; 74 | int k; 75 | 76 | hx = u.i>>32; 77 | k = 1; 78 | if (hx < 0x3fda827a || hx>>31) { /* 1+x < sqrt(2)+ */ 79 | if (hx >= 0xbff00000) { /* x <= -1.0 */ 80 | if (x == -1) 81 | return x/0.0; /* log1p(-1) = -inf */ 82 | return (x-x)/0.0; /* log1p(x<-1) = NaN */ 83 | } 84 | if (hx<<1 < 0x3ca00000<<1) { /* |x| < 2**-53 */ 85 | /* underflow if subnormal */ 86 | if ((hx&0x7ff00000) == 0) 87 | FORCE_EVAL((float)x); 88 | return x; 89 | } 90 | if (hx <= 0xbfd2bec4) { /* sqrt(2)/2- <= 1+x < sqrt(2)+ */ 91 | k = 0; 92 | c = 0; 93 | f = x; 94 | } 95 | } else if (hx >= 0x7ff00000) 96 | return x; 97 | if (k) { 98 | u.f = 1 + x; 99 | hu = u.i>>32; 100 | hu += 0x3ff00000 - 0x3fe6a09e; 101 | k = (int)(hu>>20) - 0x3ff; 102 | /* correction term ~ log(1+x)-log(u), avoid underflow in c/u */ 103 | if (k < 54) { 104 | c = k >= 2 ? 1-(u.f-x) : x-(u.f-1); 105 | c /= u.f; 106 | } else 107 | c = 0; 108 | /* reduce u into [sqrt(2)/2, sqrt(2)] */ 109 | hu = (hu&0x000fffff) + 0x3fe6a09e; 110 | u.i = (uint64_t)hu<<32 | (u.i&0xffffffff); 111 | f = u.f - 1; 112 | } 113 | hfsq = 0.5*f*f; 114 | s = f/(2.0+f); 115 | z = s*s; 116 | w = z*z; 117 | t1 = w*(Lg2+w*(Lg4+w*Lg6)); 118 | t2 = z*(Lg1+w*(Lg3+w*(Lg5+w*Lg7))); 119 | R = t2 + t1; 120 | dk = k; 121 | return s*(hfsq+R) + (dk*ln2_lo+c) - hfsq + f + dk*ln2_hi; 122 | } 123 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/modf.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | double modf(double x, double *iptr) 4 | { 5 | union {double f; uint64_t i;} u = {x}; 6 | uint64_t mask; 7 | int e = (int)(u.i>>52 & 0x7ff) - 0x3ff; 8 | 9 | /* no fractional part */ 10 | if (e >= 52) { 11 | *iptr = x; 12 | if (e == 0x400 && u.i<<12 != 0) /* nan */ 13 | return x; 14 | u.i &= 1ULL<<63; 15 | return u.f; 16 | } 17 | 18 | /* no integral part*/ 19 | if (e < 0) { 20 | u.i &= 1ULL<<63; 21 | *iptr = u.f; 22 | return x; 23 | } 24 | 25 | mask = -1ULL>>12>>e; 26 | if ((u.i & mask) == 0) { 27 | *iptr = x; 28 | u.i &= 1ULL<<63; 29 | return u.f; 30 | } 31 | u.i &= ~mask; 32 | *iptr = u.f; 33 | return x - u.f; 34 | } 35 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/nearbyint.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | /* nearbyint is the same as rint, but it must not raise the inexact exception */ 4 | 5 | double nearbyint(double x) 6 | { 7 | #ifdef FE_INEXACT 8 | #pragma STDC FENV_ACCESS ON 9 | int e; 10 | 11 | e = fetestexcept(FE_INEXACT); 12 | #endif 13 | x = rint(x); 14 | #ifdef FE_INEXACT 15 | if (!e) 16 | feclearexcept(FE_INEXACT); 17 | #endif 18 | return x; 19 | } 20 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/pow.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/e_pow.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 2004 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Permission to use, copy, modify, and distribute this 7 | * software is freely granted, provided that this notice 8 | * is preserved. 9 | * ==================================================== 10 | */ 11 | /* pow(x,y) return x**y 12 | * 13 | * n 14 | * Method: Let x = 2 * (1+f) 15 | * 1. Compute and return log2(x) in two pieces: 16 | * log2(x) = w1 + w2, 17 | * where w1 has 53-24 = 29 bit trailing zeros. 18 | * 2. Perform y*log2(x) = n+y' by simulating muti-precision 19 | * arithmetic, where |y'|<=0.5. 20 | * 3. Return x**y = 2**n*exp(y'*log2) 21 | * 22 | * Special cases: 23 | * 1. (anything) ** 0 is 1 24 | * 2. 1 ** (anything) is 1 25 | * 3. (anything except 1) ** NAN is NAN 26 | * 4. NAN ** (anything except 0) is NAN 27 | * 5. +-(|x| > 1) ** +INF is +INF 28 | * 6. +-(|x| > 1) ** -INF is +0 29 | * 7. +-(|x| < 1) ** +INF is +0 30 | * 8. +-(|x| < 1) ** -INF is +INF 31 | * 9. -1 ** +-INF is 1 32 | * 10. +0 ** (+anything except 0, NAN) is +0 33 | * 11. -0 ** (+anything except 0, NAN, odd integer) is +0 34 | * 12. +0 ** (-anything except 0, NAN) is +INF, raise divbyzero 35 | * 13. -0 ** (-anything except 0, NAN, odd integer) is +INF, raise divbyzero 36 | * 14. -0 ** (+odd integer) is -0 37 | * 15. -0 ** (-odd integer) is -INF, raise divbyzero 38 | * 16. +INF ** (+anything except 0,NAN) is +INF 39 | * 17. +INF ** (-anything except 0,NAN) is +0 40 | * 18. -INF ** (+odd integer) is -INF 41 | * 19. -INF ** (anything) = -0 ** (-anything), (anything except odd integer) 42 | * 20. (anything) ** 1 is (anything) 43 | * 21. (anything) ** -1 is 1/(anything) 44 | * 22. (-anything) ** (integer) is (-1)**(integer)*(+anything**integer) 45 | * 23. (-anything except 0 and inf) ** (non-integer) is NAN 46 | * 47 | * Accuracy: 48 | * pow(x,y) returns x**y nearly rounded. In particular 49 | * pow(integer,integer) 50 | * always returns the correct integer provided it is 51 | * representable. 52 | * 53 | * Constants : 54 | * The hexadecimal values are the intended ones for the following 55 | * constants. The decimal values may be used, provided that the 56 | * compiler will convert from decimal to binary accurately enough 57 | * to produce the hexadecimal values shown. 58 | */ 59 | 60 | #include "..\libmd.h" 61 | 62 | static const double 63 | bp[] = {1.0, 1.5,}, 64 | dp_h[] = { 0.0, 5.84962487220764160156e-01,}, /* 0x3FE2B803, 0x40000000 */ 65 | dp_l[] = { 0.0, 1.35003920212974897128e-08,}, /* 0x3E4CFDEB, 0x43CFD006 */ 66 | two53 = 9007199254740992.0, /* 0x43400000, 0x00000000 */ 67 | huge = 1.0e300, 68 | tiny = 1.0e-300, 69 | /* poly coefs for (3/2)*(log(x)-2s-2/3*s**3 */ 70 | L1 = 5.99999999999994648725e-01, /* 0x3FE33333, 0x33333303 */ 71 | L2 = 4.28571428578550184252e-01, /* 0x3FDB6DB6, 0xDB6FABFF */ 72 | L3 = 3.33333329818377432918e-01, /* 0x3FD55555, 0x518F264D */ 73 | L4 = 2.72728123808534006489e-01, /* 0x3FD17460, 0xA91D4101 */ 74 | L5 = 2.30660745775561754067e-01, /* 0x3FCD864A, 0x93C9DB65 */ 75 | L6 = 2.06975017800338417784e-01, /* 0x3FCA7E28, 0x4A454EEF */ 76 | P1 = 1.66666666666666019037e-01, /* 0x3FC55555, 0x5555553E */ 77 | P2 = -2.77777777770155933842e-03, /* 0xBF66C16C, 0x16BEBD93 */ 78 | P3 = 6.61375632143793436117e-05, /* 0x3F11566A, 0xAF25DE2C */ 79 | P4 = -1.65339022054652515390e-06, /* 0xBEBBBD41, 0xC5D26BF1 */ 80 | P5 = 4.13813679705723846039e-08, /* 0x3E663769, 0x72BEA4D0 */ 81 | lg2 = 6.93147180559945286227e-01, /* 0x3FE62E42, 0xFEFA39EF */ 82 | lg2_h = 6.93147182464599609375e-01, /* 0x3FE62E43, 0x00000000 */ 83 | lg2_l = -1.90465429995776804525e-09, /* 0xBE205C61, 0x0CA86C39 */ 84 | ovt = 8.0085662595372944372e-017, /* -(1024-log2(ovfl+.5ulp)) */ 85 | cp = 9.61796693925975554329e-01, /* 0x3FEEC709, 0xDC3A03FD =2/(3ln2) */ 86 | cp_h = 9.61796700954437255859e-01, /* 0x3FEEC709, 0xE0000000 =(float)cp */ 87 | cp_l = -7.02846165095275826516e-09, /* 0xBE3E2FE0, 0x145B01F5 =tail of cp_h*/ 88 | ivln2 = 1.44269504088896338700e+00, /* 0x3FF71547, 0x652B82FE =1/ln2 */ 89 | ivln2_h = 1.44269502162933349609e+00, /* 0x3FF71547, 0x60000000 =24b 1/ln2*/ 90 | ivln2_l = 1.92596299112661746887e-08; /* 0x3E54AE0B, 0xF85DDF44 =1/ln2 tail*/ 91 | 92 | double pow(double x, double y) 93 | { 94 | double z,ax,z_h,z_l,p_h,p_l; 95 | double y1,t1,t2,r,s,t,u,v,w; 96 | int32_t i,j,k,yisint,n; 97 | int32_t hx,hy,ix,iy; 98 | uint32_t lx,ly; 99 | 100 | EXTRACT_WORDS(hx, lx, x); 101 | EXTRACT_WORDS(hy, ly, y); 102 | ix = hx & 0x7fffffff; 103 | iy = hy & 0x7fffffff; 104 | 105 | /* x**0 = 1, even if x is NaN */ 106 | if ((iy|ly) == 0) 107 | return 1.0; 108 | /* 1**y = 1, even if y is NaN */ 109 | if (hx == 0x3ff00000 && lx == 0) 110 | return 1.0; 111 | /* NaN if either arg is NaN */ 112 | if (ix > 0x7ff00000 || (ix == 0x7ff00000 && lx != 0) || 113 | iy > 0x7ff00000 || (iy == 0x7ff00000 && ly != 0)) 114 | return x + y; 115 | 116 | /* determine if y is an odd int when x < 0 117 | * yisint = 0 ... y is not an integer 118 | * yisint = 1 ... y is an odd int 119 | * yisint = 2 ... y is an even int 120 | */ 121 | yisint = 0; 122 | if (hx < 0) { 123 | if (iy >= 0x43400000) 124 | yisint = 2; /* even integer y */ 125 | else if (iy >= 0x3ff00000) { 126 | k = (iy>>20) - 0x3ff; /* exponent */ 127 | if (k > 20) { 128 | uint32_t j = ly>>(52-k); 129 | if ((j<<(52-k)) == ly) 130 | yisint = 2 - (j&1); 131 | } else if (ly == 0) { 132 | uint32_t j = iy>>(20-k); 133 | if ((j<<(20-k)) == iy) 134 | yisint = 2 - (j&1); 135 | } 136 | } 137 | } 138 | 139 | /* special value of y */ 140 | if (ly == 0) { 141 | if (iy == 0x7ff00000) { /* y is +-inf */ 142 | if (((ix-0x3ff00000)|lx) == 0) /* (-1)**+-inf is 1 */ 143 | return 1.0; 144 | else if (ix >= 0x3ff00000) /* (|x|>1)**+-inf = inf,0 */ 145 | return hy >= 0 ? y : 0.0; 146 | else /* (|x|<1)**+-inf = 0,inf */ 147 | return hy >= 0 ? 0.0 : -y; 148 | } 149 | if (iy == 0x3ff00000) { /* y is +-1 */ 150 | if (hy >= 0) 151 | return x; 152 | y = 1/x; 153 | #if FLT_EVAL_METHOD!=0 154 | { 155 | union {double f; uint64_t i;} u = {y}; 156 | uint64_t i = u.i & -1ULL/2; 157 | if (i>>52 == 0 && (i&(i-1))) 158 | FORCE_EVAL((float)y); 159 | } 160 | #endif 161 | return y; 162 | } 163 | if (hy == 0x40000000) /* y is 2 */ 164 | return x*x; 165 | if (hy == 0x3fe00000) { /* y is 0.5 */ 166 | if (hx >= 0) /* x >= +0 */ 167 | return sqrt(x); 168 | } 169 | } 170 | 171 | ax = fabs(x); 172 | /* special value of x */ 173 | if (lx == 0) { 174 | if (ix == 0x7ff00000 || ix == 0 || ix == 0x3ff00000) { /* x is +-0,+-inf,+-1 */ 175 | z = ax; 176 | if (hy < 0) /* z = (1/|x|) */ 177 | z = 1.0/z; 178 | if (hx < 0) { 179 | if (((ix-0x3ff00000)|yisint) == 0) { 180 | z = (z-z)/(z-z); /* (-1)**non-int is NaN */ 181 | } else if (yisint == 1) 182 | z = -z; /* (x<0)**odd = -(|x|**odd) */ 183 | } 184 | return z; 185 | } 186 | } 187 | 188 | s = 1.0; /* sign of result */ 189 | if (hx < 0) { 190 | if (yisint == 0) /* (x<0)**(non-int) is NaN */ 191 | return (x-x)/(x-x); 192 | if (yisint == 1) /* (x<0)**(odd int) */ 193 | s = -1.0; 194 | } 195 | 196 | /* |y| is huge */ 197 | if (iy > 0x41e00000) { /* if |y| > 2**31 */ 198 | if (iy > 0x43f00000) { /* if |y| > 2**64, must o/uflow */ 199 | if (ix <= 0x3fefffff) 200 | return hy < 0 ? huge*huge : tiny*tiny; 201 | if (ix >= 0x3ff00000) 202 | return hy > 0 ? huge*huge : tiny*tiny; 203 | } 204 | /* over/underflow if x is not close to one */ 205 | if (ix < 0x3fefffff) 206 | return hy < 0 ? s*huge*huge : s*tiny*tiny; 207 | if (ix > 0x3ff00000) 208 | return hy > 0 ? s*huge*huge : s*tiny*tiny; 209 | /* now |1-x| is tiny <= 2**-20, suffice to compute 210 | log(x) by x-x^2/2+x^3/3-x^4/4 */ 211 | t = ax - 1.0; /* t has 20 trailing zeros */ 212 | w = (t*t)*(0.5 - t*(0.3333333333333333333333-t*0.25)); 213 | u = ivln2_h*t; /* ivln2_h has 21 sig. bits */ 214 | v = t*ivln2_l - w*ivln2; 215 | t1 = u + v; 216 | SET_LOW_WORD(t1, 0); 217 | t2 = v - (t1-u); 218 | } else { 219 | double ss,s2,s_h,s_l,t_h,t_l; 220 | n = 0; 221 | /* take care subnormal number */ 222 | if (ix < 0x00100000) { 223 | ax *= two53; 224 | n -= 53; 225 | GET_HIGH_WORD(ix,ax); 226 | } 227 | n += ((ix)>>20) - 0x3ff; 228 | j = ix & 0x000fffff; 229 | /* determine interval */ 230 | ix = j | 0x3ff00000; /* normalize ix */ 231 | if (j <= 0x3988E) /* |x|>1)|0x20000000) + 0x00080000 + (k<<18)); 251 | t_l = ax - (t_h-bp[k]); 252 | s_l = v*((u-s_h*t_h)-s_h*t_l); 253 | /* compute log(ax) */ 254 | s2 = ss*ss; 255 | r = s2*s2*(L1+s2*(L2+s2*(L3+s2*(L4+s2*(L5+s2*L6))))); 256 | r += s_l*(s_h+ss); 257 | s2 = s_h*s_h; 258 | t_h = 3.0 + s2 + r; 259 | SET_LOW_WORD(t_h, 0); 260 | t_l = r - ((t_h-3.0)-s2); 261 | /* u+v = ss*(1+...) */ 262 | u = s_h*t_h; 263 | v = s_l*t_h + t_l*ss; 264 | /* 2/(3log2)*(ss+...) */ 265 | p_h = u + v; 266 | SET_LOW_WORD(p_h, 0); 267 | p_l = v - (p_h-u); 268 | z_h = cp_h*p_h; /* cp_h+cp_l = 2/(3*log2) */ 269 | z_l = cp_l*p_h+p_l*cp + dp_l[k]; 270 | /* log2(ax) = (ss+..)*2/(3*log2) = n + dp_h + z_h + z_l */ 271 | t = (double)n; 272 | t1 = ((z_h + z_l) + dp_h[k]) + t; 273 | SET_LOW_WORD(t1, 0); 274 | t2 = z_l - (((t1 - t) - dp_h[k]) - z_h); 275 | } 276 | 277 | /* split up y into y1+y2 and compute (y1+y2)*(t1+t2) */ 278 | y1 = y; 279 | SET_LOW_WORD(y1, 0); 280 | p_l = (y-y1)*t1 + y*t2; 281 | p_h = y1*t1; 282 | z = p_l + p_h; 283 | EXTRACT_WORDS(j, i, z); 284 | if (j >= 0x40900000) { /* z >= 1024 */ 285 | if (((j-0x40900000)|i) != 0) /* if z > 1024 */ 286 | return s*huge*huge; /* overflow */ 287 | if (p_l + ovt > z - p_h) 288 | return s*huge*huge; /* overflow */ 289 | } else if ((j&0x7fffffff) >= 0x4090cc00) { /* z <= -1075 */ // FIXME: instead of abs(j) use unsigned j 290 | if (((j-0xc090cc00)|i) != 0) /* z < -1075 */ 291 | return s*tiny*tiny; /* underflow */ 292 | if (p_l <= z - p_h) 293 | return s*tiny*tiny; /* underflow */ 294 | } 295 | /* 296 | * compute 2**(p_h+p_l) 297 | */ 298 | i = j & 0x7fffffff; 299 | k = (i>>20) - 0x3ff; 300 | n = 0; 301 | if (i > 0x3fe00000) { /* if |z| > 0.5, set n = [z+0.5] */ 302 | n = j + (0x00100000>>(k+1)); 303 | k = ((n&0x7fffffff)>>20) - 0x3ff; /* new k for n */ 304 | t = 0.0; 305 | SET_HIGH_WORD(t, n & ~(0x000fffff>>k)); 306 | n = ((n&0x000fffff)|0x00100000)>>(20-k); 307 | if (j < 0) 308 | n = -n; 309 | p_h -= t; 310 | } 311 | t = p_l + p_h; 312 | SET_LOW_WORD(t, 0); 313 | u = t*lg2_h; 314 | v = (p_l-(t-p_h))*lg2 + t*lg2_l; 315 | z = u + v; 316 | w = v - (z-u); 317 | t = z*z; 318 | t1 = z - t*(P1+t*(P2+t*(P3+t*(P4+t*P5)))); 319 | r = (z*t1)/(t1-2.0) - (w + z*w); 320 | z = 1.0 - (r-z); 321 | GET_HIGH_WORD(j, z); 322 | j += n<<20; 323 | if ((j>>20) <= 0) /* subnormal output */ 324 | z = scalbn(z,n); 325 | else 326 | SET_HIGH_WORD(z, j); 327 | return s*z; 328 | } 329 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/rint.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "..\libmd.h" 3 | 4 | #if FLT_EVAL_METHOD==0 || FLT_EVAL_METHOD==1 5 | #define EPS DBL_EPSILON 6 | #elif FLT_EVAL_METHOD==2 7 | #define EPS LDBL_EPSILON 8 | #endif 9 | static const double_t toint = 1/EPS; 10 | 11 | double rint(double x) 12 | { 13 | union {double f; uint64_t i;} u = {x}; 14 | int e = u.i>>52 & 0x7ff; 15 | int s = u.i>>63; 16 | double_t y; 17 | 18 | if (e >= 0x3ff+52) 19 | return x; 20 | if (s) 21 | y = x - toint + toint; 22 | else 23 | y = x + toint - toint; 24 | if (y == 0) 25 | return s ? -0.0 : 0; 26 | return y; 27 | } 28 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/scalbn.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | double scalbn(double x, int n) 4 | { 5 | union {double f; uint64_t i;} u; 6 | double_t y = x; 7 | 8 | if (n > 1023) { 9 | y *= 0x1p1023; 10 | n -= 1023; 11 | if (n > 1023) { 12 | y *= 0x1p1023; 13 | n -= 1023; 14 | if (n > 1023) 15 | n = 1023; 16 | } 17 | } else if (n < -1022) { 18 | /* make sure final n < -53 to avoid double 19 | rounding in the subnormal range */ 20 | y *= 0x1p-1022 * 0x1p53; 21 | n += 1022 - 53; 22 | if (n < -1022) { 23 | y *= 0x1p-1022 * 0x1p53; 24 | n += 1022 - 53; 25 | if (n < -1022) 26 | n = -1022; 27 | } 28 | } 29 | u.i = (uint64_t)(0x3ff+n)<<52; 30 | x = y * u.f; 31 | return x; 32 | } 33 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/signbit.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | int signbit(double x) 4 | { 5 | union { 6 | double d; 7 | uint64_t i; 8 | } y = { x }; 9 | return y.i>>63; 10 | } 11 | 12 | 13 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/sin.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/s_sin.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunPro, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* sin(x) 13 | * Return sine function of x. 14 | * 15 | * kernel function: 16 | * __sin ... sine function on [-pi/4,pi/4] 17 | * __cos ... cose function on [-pi/4,pi/4] 18 | * __rem_pio2 ... argument reduction routine 19 | * 20 | * Method. 21 | * Let S,C and T denote the sin, cos and tan respectively on 22 | * [-PI/4, +PI/4]. Reduce the argument x to y1+y2 = x-k*pi/2 23 | * in [-pi/4 , +pi/4], and let n = k mod 4. 24 | * We have 25 | * 26 | * n sin(x) cos(x) tan(x) 27 | * ---------------------------------------------------------- 28 | * 0 S C T 29 | * 1 C -S -1/T 30 | * 2 -S -C T 31 | * 3 -C S -1/T 32 | * ---------------------------------------------------------- 33 | * 34 | * Special cases: 35 | * Let trig be any of sin, cos, or tan. 36 | * trig(+-INF) is NaN, with signals; 37 | * trig(NaN) is that NaN; 38 | * 39 | * Accuracy: 40 | * TRIG(x) returns trig(x) nearly rounded 41 | */ 42 | 43 | #include "..\libmd.h" 44 | 45 | double sin(double x) 46 | { 47 | double y[2]; 48 | uint32_t ix; 49 | unsigned n; 50 | 51 | /* High word of x. */ 52 | GET_HIGH_WORD(ix, x); 53 | ix &= 0x7fffffff; 54 | 55 | /* |x| ~< pi/4 */ 56 | if (ix <= 0x3fe921fb) { 57 | if (ix < 0x3e500000) { /* |x| < 2**-26 */ 58 | /* raise inexact if x != 0 and underflow if subnormal*/ 59 | FORCE_EVAL(ix < 0x00100000 ? x/0x1p120f : x+0x1p120f); 60 | return x; 61 | } 62 | return __sin(x, 0.0, 0); 63 | } 64 | 65 | /* sin(Inf or NaN) is NaN */ 66 | if (ix >= 0x7ff00000) 67 | return x - x; 68 | 69 | /* argument reduction needed */ 70 | n = __rem_pio2(x, y); 71 | switch (n&3) { 72 | case 0: return __sin(y[0], y[1], 1); 73 | case 1: return __cos(y[0], y[1]); 74 | case 2: return -__sin(y[0], y[1], 1); 75 | default: 76 | return -__cos(y[0], y[1]); 77 | } 78 | } 79 | 80 | float sinf(float f) 81 | { 82 | return sin(f); 83 | } -------------------------------------------------------------------------------- /NtLisp/crt/libmd/sinh.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | /* sinh(x) = (exp(x) - 1/exp(x))/2 4 | * = (exp(x)-1 + (exp(x)-1)/exp(x))/2 5 | * = x + x^3/6 + o(x^5) 6 | */ 7 | double sinh(double x) 8 | { 9 | union {double f; uint64_t i;} u = { x }; 10 | uint32_t w; 11 | double t, h, absx; 12 | 13 | h = 0.5; 14 | if (u.i >> 63) 15 | h = -h; 16 | /* |x| */ 17 | u.i &= (uint64_t)-1/2; 18 | absx = u.f; 19 | w = u.i >> 32; 20 | 21 | /* |x| < log(DBL_MAX) */ 22 | if (w < 0x40862e42) { 23 | t = expm1(absx); 24 | if (w < 0x3ff00000) { 25 | if (w < 0x3ff00000 - (26<<20)) 26 | /* note: inexact and underflow are raised by expm1 */ 27 | /* note: this branch avoids spurious underflow */ 28 | return x; 29 | return h*(2*t - t*t/(t+1)); 30 | } 31 | /* note: |x|>log(0x1p26)+eps could be just h*exp(x) */ 32 | return h*(t + t/(t+1)); 33 | } 34 | 35 | /* |x| > log(DBL_MAX) or nan */ 36 | /* note: the result is stored to handle overflow */ 37 | t = 2*h*__expo2(absx); 38 | return t; 39 | } 40 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/sqrt.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/e_sqrt.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunSoft, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* sqrt(x) 13 | * Return correctly rounded sqrt. 14 | * ------------------------------------------ 15 | * | Use the hardware sqrt if you have one | 16 | * ------------------------------------------ 17 | * Method: 18 | * Bit by bit method using integer arithmetic. (Slow, but portable) 19 | * 1. Normalization 20 | * Scale x to y in [1,4) with even powers of 2: 21 | * find an integer k such that 1 <= (y=x*2^(2k)) < 4, then 22 | * sqrt(x) = 2^k * sqrt(y) 23 | * 2. Bit by bit computation 24 | * Let q = sqrt(y) truncated to i bit after binary point (q = 1), 25 | * i 0 26 | * i+1 2 27 | * s = 2*q , and y = 2 * ( y - q ). (1) 28 | * i i i i 29 | * 30 | * To compute q from q , one checks whether 31 | * i+1 i 32 | * 33 | * -(i+1) 2 34 | * (q + 2 ) <= y. (2) 35 | * i 36 | * -(i+1) 37 | * If (2) is false, then q = q ; otherwise q = q + 2 . 38 | * i+1 i i+1 i 39 | * 40 | * With some algebric manipulation, it is not difficult to see 41 | * that (2) is equivalent to 42 | * -(i+1) 43 | * s + 2 <= y (3) 44 | * i i 45 | * 46 | * The advantage of (3) is that s and y can be computed by 47 | * i i 48 | * the following recurrence formula: 49 | * if (3) is false 50 | * 51 | * s = s , y = y ; (4) 52 | * i+1 i i+1 i 53 | * 54 | * otherwise, 55 | * -i -(i+1) 56 | * s = s + 2 , y = y - s - 2 (5) 57 | * i+1 i i+1 i i 58 | * 59 | * One may easily use induction to prove (4) and (5). 60 | * Note. Since the left hand side of (3) contain only i+2 bits, 61 | * it does not necessary to do a full (53-bit) comparison 62 | * in (3). 63 | * 3. Final rounding 64 | * After generating the 53 bits result, we compute one more bit. 65 | * Together with the remainder, we can decide whether the 66 | * result is exact, bigger than 1/2ulp, or less than 1/2ulp 67 | * (it will never equal to 1/2ulp). 68 | * The rounding mode can be detected by checking whether 69 | * huge + tiny is equal to huge, and whether huge - tiny is 70 | * equal to huge for some floating point number "huge" and "tiny". 71 | * 72 | * Special cases: 73 | * sqrt(+-0) = +-0 ... exact 74 | * sqrt(inf) = inf 75 | * sqrt(-ve) = NaN ... with invalid signal 76 | * sqrt(NaN) = NaN ... with invalid signal for signaling NaN 77 | */ 78 | 79 | #include "..\libmd.h" 80 | 81 | static const double tiny = 1.0e-300; 82 | 83 | double sqrt(double x) 84 | { 85 | double z; 86 | int32_t sign = (int)0x80000000; 87 | int32_t ix0,s0,q,m,t,i; 88 | uint32_t r,t1,s1,ix1,q1; 89 | 90 | EXTRACT_WORDS(ix0, ix1, x); 91 | 92 | /* take care of Inf and NaN */ 93 | if ((ix0&0x7ff00000) == 0x7ff00000) { 94 | return x*x + x; /* sqrt(NaN)=NaN, sqrt(+inf)=+inf, sqrt(-inf)=sNaN */ 95 | } 96 | /* take care of zero */ 97 | if (ix0 <= 0) { 98 | if (((ix0&~sign)|ix1) == 0) 99 | return x; /* sqrt(+-0) = +-0 */ 100 | if (ix0 < 0) 101 | return (x-x)/(x-x); /* sqrt(-ve) = sNaN */ 102 | } 103 | /* normalize x */ 104 | m = ix0>>20; 105 | if (m == 0) { /* subnormal x */ 106 | while (ix0 == 0) { 107 | m -= 21; 108 | ix0 |= (ix1>>11); 109 | ix1 <<= 21; 110 | } 111 | for (i=0; (ix0&0x00100000) == 0; i++) 112 | ix0<<=1; 113 | m -= i - 1; 114 | ix0 |= ix1>>(32-i); 115 | ix1 <<= i; 116 | } 117 | m -= 1023; /* unbias exponent */ 118 | ix0 = (ix0&0x000fffff)|0x00100000; 119 | if (m & 1) { /* odd m, double x to make it even */ 120 | ix0 += ix0 + ((ix1&sign)>>31); 121 | ix1 += ix1; 122 | } 123 | m >>= 1; /* m = [m/2] */ 124 | 125 | /* generate sqrt(x) bit by bit */ 126 | ix0 += ix0 + ((ix1&sign)>>31); 127 | ix1 += ix1; 128 | q = q1 = s0 = s1 = 0; /* [q,q1] = sqrt(x) */ 129 | r = 0x00200000; /* r = moving bit from right to left */ 130 | 131 | while (r != 0) { 132 | t = s0 + r; 133 | if (t <= ix0) { 134 | s0 = t + r; 135 | ix0 -= t; 136 | q += r; 137 | } 138 | ix0 += ix0 + ((ix1&sign)>>31); 139 | ix1 += ix1; 140 | r >>= 1; 141 | } 142 | 143 | r = sign; 144 | while (r != 0) { 145 | t1 = s1 + r; 146 | t = s0; 147 | if (t < ix0 || (t == ix0 && t1 <= ix1)) { 148 | s1 = t1 + r; 149 | if ((t1&sign) == sign && (s1&sign) == 0) 150 | s0++; 151 | ix0 -= t; 152 | if (ix1 < t1) 153 | ix0--; 154 | ix1 -= t1; 155 | q1 += r; 156 | } 157 | ix0 += ix0 + ((ix1&sign)>>31); 158 | ix1 += ix1; 159 | r >>= 1; 160 | } 161 | 162 | /* use floating add to find out rounding direction */ 163 | if ((ix0|ix1) != 0) { 164 | z = 1.0 - tiny; /* raise inexact flag */ 165 | if (z >= 1.0) { 166 | z = 1.0 + tiny; 167 | if (q1 == (uint32_t)0xffffffff) { 168 | q1 = 0; 169 | q++; 170 | } else if (z > 1.0) { 171 | if (q1 == (uint32_t)0xfffffffe) 172 | q++; 173 | q1 += 2; 174 | } else 175 | q1 += q1 & 1; 176 | } 177 | } 178 | ix0 = (q>>1) + 0x3fe00000; 179 | ix1 = q1>>1; 180 | if (q&1) 181 | ix1 |= sign; 182 | ix0 += m << 20; 183 | INSERT_WORDS(z, ix0, ix1); 184 | return z; 185 | } 186 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/tan.c: -------------------------------------------------------------------------------- 1 | /* origin: FreeBSD /usr/src/lib/msun/src/s_tan.c */ 2 | /* 3 | * ==================================================== 4 | * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. 5 | * 6 | * Developed at SunPro, a Sun Microsystems, Inc. business. 7 | * Permission to use, copy, modify, and distribute this 8 | * software is freely granted, provided that this notice 9 | * is preserved. 10 | * ==================================================== 11 | */ 12 | /* tan(x) 13 | * Return tangent function of x. 14 | * 15 | * kernel function: 16 | * __tan ... tangent function on [-pi/4,pi/4] 17 | * __rem_pio2 ... argument reduction routine 18 | * 19 | * Method. 20 | * Let S,C and T denote the sin, cos and tan respectively on 21 | * [-PI/4, +PI/4]. Reduce the argument x to y1+y2 = x-k*pi/2 22 | * in [-pi/4 , +pi/4], and let n = k mod 4. 23 | * We have 24 | * 25 | * n sin(x) cos(x) tan(x) 26 | * ---------------------------------------------------------- 27 | * 0 S C T 28 | * 1 C -S -1/T 29 | * 2 -S -C T 30 | * 3 -C S -1/T 31 | * ---------------------------------------------------------- 32 | * 33 | * Special cases: 34 | * Let trig be any of sin, cos, or tan. 35 | * trig(+-INF) is NaN, with signals; 36 | * trig(NaN) is that NaN; 37 | * 38 | * Accuracy: 39 | * TRIG(x) returns trig(x) nearly rounded 40 | */ 41 | 42 | #include "..\libmd.h" 43 | 44 | double tan(double x) 45 | { 46 | double y[2]; 47 | uint32_t ix; 48 | unsigned n; 49 | 50 | GET_HIGH_WORD(ix, x); 51 | ix &= 0x7fffffff; 52 | 53 | /* |x| ~< pi/4 */ 54 | if (ix <= 0x3fe921fb) { 55 | if (ix < 0x3e400000) { /* |x| < 2**-27 */ 56 | /* raise inexact if x!=0 and underflow if subnormal */ 57 | FORCE_EVAL(ix < 0x00100000 ? x/0x1p120f : x+0x1p120f); 58 | return x; 59 | } 60 | return __tan(x, 0.0, 0); 61 | } 62 | 63 | /* tan(Inf or NaN) is NaN */ 64 | if (ix >= 0x7ff00000) 65 | return x - x; 66 | 67 | /* argument reduction */ 68 | n = __rem_pio2(x, y); 69 | return __tan(y[0], y[1], n&1); 70 | } 71 | 72 | float tanf(float f) 73 | { 74 | return tan(f); 75 | } -------------------------------------------------------------------------------- /NtLisp/crt/libmd/tanh.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | double tanh(double x) { 4 | int sign = 0; 5 | if (x < 0) { 6 | sign = 1; 7 | x = -x; 8 | } 9 | x = expm1(-2 * x); 10 | x = x / (x + 2); 11 | return sign ? x : -x; 12 | } 13 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/tgamma.c: -------------------------------------------------------------------------------- 1 | /* 2 | "A Precision Approximation of the Gamma Function" - Cornelius Lanczos (1964) 3 | "Lanczos Implementation of the Gamma Function" - Paul Godfrey (2001) 4 | "An Analysis of the Lanczos Gamma Approximation" - Glendon Ralph Pugh (2004) 5 | 6 | approximation method: 7 | 8 | (x - 0.5) S(x) 9 | Gamma(x) = (x + g - 0.5) * ---------------- 10 | exp(x + g - 0.5) 11 | 12 | with 13 | a1 a2 a3 aN 14 | S(x) ~= [ a0 + ----- + ----- + ----- + ... + ----- ] 15 | x + 1 x + 2 x + 3 x + N 16 | 17 | with a0, a1, a2, a3,.. aN constants which depend on g. 18 | 19 | for x < 0 the following reflection formula is used: 20 | 21 | Gamma(x)*Gamma(-x) = -pi/(x sin(pi x)) 22 | 23 | most ideas and constants are from boost and python 24 | */ 25 | #include "..\libmd.h" 26 | 27 | static const double pi = 3.141592653589793238462643383279502884; 28 | 29 | /* sin(pi x) with x > 0x1p-100, if sin(pi*x)==0 the sign is arbitrary */ 30 | static double sinpi(double x) 31 | { 32 | int n; 33 | 34 | /* argument reduction: x = |x| mod 2 */ 35 | /* spurious inexact when x is odd int */ 36 | x = x * 0.5; 37 | x = 2 * (x - floor(x)); 38 | 39 | /* reduce x into [-.25,.25] */ 40 | n = 4 * x; 41 | n = (n+1)/2; 42 | x -= n * 0.5; 43 | 44 | x *= pi; 45 | switch (n) { 46 | default: /* case 4 */ 47 | case 0: 48 | return __sin(x, 0, 0); 49 | case 1: 50 | return __cos(x, 0); 51 | case 2: 52 | return __sin(-x, 0, 0); 53 | case 3: 54 | return -__cos(x, 0); 55 | } 56 | } 57 | 58 | #define N 12 59 | //static const double g = 6.024680040776729583740234375; 60 | static const double gmhalf = 5.524680040776729583740234375; 61 | static const double Snum[N+1] = { 62 | 23531376880.410759688572007674451636754734846804940, 63 | 42919803642.649098768957899047001988850926355848959, 64 | 35711959237.355668049440185451547166705960488635843, 65 | 17921034426.037209699919755754458931112671403265390, 66 | 6039542586.3520280050642916443072979210699388420708, 67 | 1439720407.3117216736632230727949123939715485786772, 68 | 248874557.86205415651146038641322942321632125127801, 69 | 31426415.585400194380614231628318205362874684987640, 70 | 2876370.6289353724412254090516208496135991145378768, 71 | 186056.26539522349504029498971604569928220784236328, 72 | 8071.6720023658162106380029022722506138218516325024, 73 | 210.82427775157934587250973392071336271166969580291, 74 | 2.5066282746310002701649081771338373386264310793408, 75 | }; 76 | static const double Sden[N+1] = { 77 | 0, 39916800, 120543840, 150917976, 105258076, 45995730, 13339535, 78 | 2637558, 357423, 32670, 1925, 66, 1, 79 | }; 80 | /* n! for small integer n */ 81 | static const double fact[] = { 82 | 1, 1, 2, 6, 24, 120, 720, 5040.0, 40320.0, 362880.0, 3628800.0, 39916800.0, 83 | 479001600.0, 6227020800.0, 87178291200.0, 1307674368000.0, 20922789888000.0, 84 | 355687428096000.0, 6402373705728000.0, 121645100408832000.0, 85 | 2432902008176640000.0, 51090942171709440000.0, 1124000727777607680000.0, 86 | }; 87 | 88 | /* S(x) rational function for positive x */ 89 | static double S(double x) 90 | { 91 | double_t num = 0, den = 0; 92 | int i; 93 | 94 | /* to avoid overflow handle large x differently */ 95 | if (x < 8) 96 | for (i = N; i >= 0; i--) { 97 | num = num * x + Snum[i]; 98 | den = den * x + Sden[i]; 99 | } 100 | else 101 | for (i = 0; i <= N; i++) { 102 | num = num / x + Snum[i]; 103 | den = den / x + Sden[i]; 104 | } 105 | return num/den; 106 | } 107 | 108 | double tgamma(double x) 109 | { 110 | union {double f; uint64_t i;} u = {x}; 111 | double absx, y; 112 | double_t dy, z, r; 113 | uint32_t ix = u.i>>32 & 0x7fffffff; 114 | int sign = u.i>>63; 115 | 116 | /* special cases */ 117 | if (ix >= 0x7ff00000) 118 | /* tgamma(nan)=nan, tgamma(inf)=inf, tgamma(-inf)=nan with invalid */ 119 | return x + INFINITY; 120 | if (ix < (0x3ff-54)<<20) 121 | /* |x| < 2^-54: tgamma(x) ~ 1/x, +-0 raises div-by-zero */ 122 | return 1/x; 123 | 124 | /* integer arguments */ 125 | /* raise inexact when non-integer */ 126 | if (x == floor(x)) { 127 | if (sign) 128 | return NAN; 129 | if (x <= sizeof fact/sizeof *fact) 130 | return fact[(int)x - 1]; 131 | } 132 | 133 | /* x >= 172: tgamma(x)=inf with overflow */ 134 | /* x =< -184: tgamma(x)=+-0 with underflow */ 135 | if (ix >= 0x40670000) { /* |x| >= 184 */ 136 | if (sign) { 137 | FORCE_EVAL((float)(0x1p-126/x)); 138 | if (floor(x) * 0.5 == floor(x * 0.5)) 139 | return 0; 140 | return -0.0; 141 | } 142 | x *= 0x1p1023; 143 | return x; 144 | } 145 | 146 | absx = sign ? -x : x; 147 | 148 | /* handle the error of x + g - 0.5 */ 149 | y = absx + gmhalf; 150 | if (absx > gmhalf) { 151 | dy = y - absx; 152 | dy -= gmhalf; 153 | } else { 154 | dy = y - gmhalf; 155 | dy -= absx; 156 | } 157 | 158 | z = absx - 0.5; 159 | r = S(absx) * exp(-y); 160 | if (x < 0) { 161 | /* reflection formula for negative x */ 162 | /* sinpi(absx) is not 0, integers are already handled */ 163 | r = -pi / (sinpi(absx) * absx * r); 164 | dy = -dy; 165 | z = -z; 166 | } 167 | r += dy * (gmhalf+0.5) * r / y; 168 | z = pow(y, 0.5*z); 169 | y = r * z * z; 170 | return y; 171 | } 172 | 173 | #if 1 174 | double __lgamma_r(double x, int *sign) 175 | { 176 | double r, absx; 177 | 178 | *sign = 1; 179 | 180 | /* special cases */ 181 | if (!isfinite(x)) 182 | /* lgamma(nan)=nan, lgamma(+-inf)=inf */ 183 | return x*x; 184 | 185 | /* integer arguments */ 186 | if (x == floor(x) && x <= 2) { 187 | /* n <= 0: lgamma(n)=inf with divbyzero */ 188 | /* n == 1,2: lgamma(n)=0 */ 189 | if (x <= 0) 190 | return INFINITY; 191 | return 0; 192 | } 193 | 194 | absx = fabs(x); 195 | 196 | /* lgamma(x) ~ -log(|x|) for tiny |x| */ 197 | if (absx < 0x1p-54) { 198 | *sign = 1 - 2*!!signbit(x); 199 | return -log(absx); 200 | } 201 | 202 | /* use tgamma for smaller |x| */ 203 | if (absx < 128) { 204 | x = tgamma(x); 205 | *sign = 1 - 2*!!signbit(x); 206 | return log(fabs(x)); 207 | } 208 | 209 | /* second term (log(S)-g) could be more precise here.. */ 210 | /* or with stirling: (|x|-0.5)*(log(|x|)-1) + poly(1/|x|) */ 211 | r = (absx-0.5)*(log(absx+gmhalf)-1) + (log(S(absx)) - (gmhalf+0.5)); 212 | if (x < 0) { 213 | /* reflection formula for negative x */ 214 | x = sinpi(absx); 215 | *sign = 2*!!signbit(x) - 1; 216 | r = log(pi/(fabs(x)*absx)) - r; 217 | } 218 | return r; 219 | } 220 | 221 | //weak_alias(__lgamma_r, lgamma_r); 222 | #endif 223 | -------------------------------------------------------------------------------- /NtLisp/crt/libmd/trunc.c: -------------------------------------------------------------------------------- 1 | #include "..\libmd.h" 2 | 3 | double trunc(double x) 4 | { 5 | union {double f; uint64_t i;} u = {x}; 6 | int e = (int)(u.i >> 52 & 0x7ff) - 0x3ff + 12; 7 | uint64_t m; 8 | 9 | if (e >= 52 + 12) 10 | return x; 11 | if (e < 12) 12 | e = 1; 13 | m = -1ULL >> e; 14 | if ((u.i & m) == 0) 15 | return x; 16 | FORCE_EVAL(x + 0x1p120f); 17 | u.i &= ~m; 18 | return u.f; 19 | } 20 | -------------------------------------------------------------------------------- /NtLisp/crt/memory.cpp: -------------------------------------------------------------------------------- 1 | #include "crt.h" 2 | 3 | __declspec( restrict ) void* malloc( size_t n ) 4 | { 5 | return ExAllocatePoolWithTag( NonPagedPool, n, 'NLUA' ); 6 | } 7 | 8 | void free( void* p ) 9 | { 10 | if ( p ) ExFreePoolWithTag( p, 'NLUA' ); 11 | } 12 | 13 | void* __cdecl operator new( size_t n ) 14 | { 15 | return malloc( n ); 16 | } 17 | 18 | void* operator new[ ] ( size_t n ) 19 | { 20 | return malloc( n ); 21 | } 22 | 23 | void __cdecl operator delete[ ] ( void* p ) 24 | { 25 | return free( p ); 26 | } 27 | 28 | void __cdecl operator delete( void* p, size_t n ) 29 | { 30 | return free( p ); 31 | } 32 | 33 | void __cdecl operator delete[ ] ( void* p, size_t n ) 34 | { 35 | return free( p ); 36 | } 37 | 38 | void __cdecl operator delete( void* p ) 39 | { 40 | return free( p ); 41 | } 42 | 43 | void* operator new( size_t, void* where ) 44 | { 45 | return where; 46 | } -------------------------------------------------------------------------------- /NtLisp/crt/misc.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "crt.h" 3 | 4 | void abort() 5 | { 6 | __debugbreak(); 7 | } 8 | 9 | char* getenv() 10 | { 11 | return "virtual://"; 12 | } 13 | 14 | typedef long clock_t; 15 | 16 | extern "C" clock_t clock() 17 | { 18 | ULARGE_INTEGER TickCount; 19 | 20 | while (TRUE) 21 | { 22 | TickCount.HighPart = (ULONG)SharedUserData->TickCount.High1Time; 23 | TickCount.LowPart = SharedUserData->TickCount.LowPart; 24 | 25 | if (TickCount.HighPart == (ULONG)SharedUserData->TickCount.High2Time) break; 26 | 27 | YieldProcessor(); 28 | } 29 | 30 | return (UInt32x32To64(TickCount.LowPart, SharedUserData->TickCountMultiplier) >> 24) + 31 | (UInt32x32To64(TickCount.HighPart, SharedUserData->TickCountMultiplier) << 8); 32 | } 33 | 34 | extern "C" time_t _time64(time_t* time) 35 | { 36 | LARGE_INTEGER SystemTime; 37 | 38 | do 39 | { 40 | SystemTime.HighPart = SharedUserData->SystemTime.High1Time; 41 | SystemTime.LowPart = SharedUserData->SystemTime.LowPart; 42 | } while (SystemTime.HighPart != SharedUserData->SystemTime.High2Time); 43 | 44 | // https://www.gamedev.net/forums/topic/565693-converting-filetime-to-time_t-on-windows/ 45 | return SystemTime.QuadPart / 10000000ULL - 11644473600ULL; 46 | } -------------------------------------------------------------------------------- /NtLisp/crt/stdint.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | typedef unsigned __int8 uint8_t; 3 | typedef unsigned __int16 uint16_t; 4 | typedef unsigned __int32 uint32_t; 5 | typedef unsigned __int64 uint64_t; 6 | typedef __int8 int8_t; 7 | typedef __int16 int16_t; 8 | typedef __int32 int32_t; 9 | typedef __int64 int64_t; -------------------------------------------------------------------------------- /NtLisp/crt/string.c: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include "crt.h" 3 | 4 | int isalpha( int c ) 5 | { 6 | return ( 'a' <= c && c <= 'z' ) || 7 | ( 'A' <= c && c <= 'Z' ); 8 | } 9 | 10 | int isdigit( int c ) 11 | { 12 | return ( '0' <= c && c <= '9' ); 13 | } 14 | 15 | int isalnum( int c ) 16 | { 17 | return isalpha( c ) || isdigit( c ); 18 | } 19 | 20 | int iscntrl( int c ) 21 | { 22 | return c <= 0x1F || c == 0x7F; 23 | } 24 | 25 | int isgraph( int c ) 26 | { 27 | return 0x21 <= c && c <= 0x7E; 28 | } 29 | 30 | int ispunct( int c ) 31 | { 32 | for ( auto o : "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" ) 33 | if ( o == c ) return 1; 34 | return 0; 35 | } 36 | 37 | double strtod( const char* str, const char** endptr ) 38 | { 39 | double v = 0; 40 | if ( sscanf_s( str, "%lf", &v ) && endptr ) 41 | *endptr = str + strlen( str ); 42 | return v; 43 | } 44 | 45 | double atof( const char* str ) 46 | { 47 | const char* endptr = 0; 48 | return strtod( str, &endptr ); 49 | } 50 | 51 | char* strpbrk( const char* s1, const char* s2 ) 52 | { 53 | while ( *s1 ) 54 | if ( strchr( s2, *s1++ ) ) 55 | return ( char* )--s1; 56 | return 0; 57 | } 58 | 59 | // haha locale go brrr 60 | // 61 | int strcoll( const char* a, const char* b ) 62 | { 63 | return strcmp( a, b ); 64 | } -------------------------------------------------------------------------------- /NtLisp/driver_io.hpp: -------------------------------------------------------------------------------- 1 | #pragma once 2 | 3 | // Assuming the platform specific header is included already. 4 | #define NTLISP_RUN CTL_CODE( 0x13, 0x37, METHOD_BUFFERED, FILE_ANY_ACCESS ) 5 | 6 | // Shared structures. 7 | // 8 | struct ntlisp_result 9 | { 10 | char* errors; 11 | char* outputs; 12 | }; -------------------------------------------------------------------------------- /NtLisp/logger.hpp: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | 4 | // Basic logger implementation. 5 | // 6 | namespace logger 7 | { 8 | struct string_buffer 9 | { 10 | static constexpr size_t buffer_length = 1024 * 1024 * 16; 11 | 12 | char raw[ buffer_length ]; 13 | size_t iterator = 0; 14 | 15 | void append( const void* ptr, size_t n ) 16 | { 17 | if ( ( iterator + n ) < buffer_length ) 18 | { 19 | memcpy( raw + iterator, ptr, n ); 20 | iterator += n; 21 | } 22 | } 23 | 24 | void reset() 25 | { 26 | iterator = 0; 27 | } 28 | }; 29 | 30 | inline string_buffer logs = {}; 31 | inline string_buffer errors = {}; 32 | 33 | template 34 | static auto error( const char* format, T... args ) 35 | { 36 | char buffer[ 512 ]; 37 | size_t n = sprintf_s( buffer, 512, format, args... ); 38 | errors.append( buffer, n ); 39 | return n; 40 | } 41 | template 42 | static auto log( const char* format, T... args ) 43 | { 44 | char buffer[ 512 ]; 45 | size_t n = sprintf_s( buffer, 512, format, args... ); 46 | logs.append( buffer, n ); 47 | return n; 48 | } 49 | }; -------------------------------------------------------------------------------- /NtLisp/main.cpp: -------------------------------------------------------------------------------- 1 | #include "crt/crt.h" 2 | #include 3 | #include "logger.hpp" 4 | #include "driver_io.hpp" 5 | extern "C" 6 | { 7 | #include 8 | } 9 | 10 | // Global Lisp context. 11 | // 12 | static LispContext ctx; 13 | 14 | // Device control handler. 15 | // 16 | static NTSTATUS device_control( PDEVICE_OBJECT device_object, PIRP irp ) 17 | { 18 | // If current control code is NTLUA_RUN: 19 | // 20 | PIO_STACK_LOCATION irp_sp = IoGetCurrentIrpStackLocation( irp ); 21 | if ( irp_sp->Parameters.DeviceIoControl.IoControlCode == NTLISP_RUN ) 22 | { 23 | const char* input = ( const char* ) irp->AssociatedIrp.SystemBuffer; 24 | ntlisp_result* result = ( ntlisp_result* ) irp->AssociatedIrp.SystemBuffer; 25 | 26 | size_t input_length = irp_sp->Parameters.DeviceIoControl.InputBufferLength; 27 | size_t output_length = irp_sp->Parameters.DeviceIoControl.OutputBufferLength; 28 | 29 | // Begin output size at 0. 30 | // 31 | irp->IoStatus.Information = 0; 32 | 33 | // If there is a valid, null-terminated buffer: 34 | // 35 | if ( input && input_length && input[ input_length - 1 ] == 0x0 ) 36 | { 37 | // Execute the code in the buffer. 38 | // 39 | LispError error; 40 | Lisp program = lisp_read(input, &error, ctx); 41 | if (error == LISP_ERROR_NONE) 42 | { 43 | // execute program using global environment 44 | Lisp lisp_result = lisp_eval(program, &error, ctx); 45 | if (error == LISP_ERROR_NONE) 46 | { 47 | // Print the result 48 | lisp_print(lisp_result); 49 | 50 | // Garbage collect 51 | lisp_collect(lisp_make_null(), ctx); 52 | } 53 | else 54 | { 55 | logger::error("lisp_eval error: %s\n", lisp_error_string(error)); 56 | } 57 | } 58 | else 59 | { 60 | logger::error("lisp_read error: %s\n", lisp_error_string(error)); 61 | } 62 | 63 | // Zero out the result. 64 | // 65 | result->errors = nullptr; 66 | result->outputs = nullptr; 67 | 68 | // Declare a helper exporting the buffer from KM memory to UM memory. 69 | // 70 | const auto export_buffer = [ ] ( logger::string_buffer& buf ) 71 | { 72 | // Allocate user-mode memory to hold this buffer. 73 | // 74 | void* region = nullptr; 75 | size_t size = buf.iterator; 76 | ZwAllocateVirtualMemory( NtCurrentProcess(), ( void** ) ®ion, 0, &size, MEM_COMMIT | MEM_RESERVE, PAGE_READWRITE ); 77 | 78 | // Copy the buffer if allocation was succesful. 79 | // 80 | if ( region ) 81 | { 82 | __try 83 | { 84 | memcpy( region, buf.raw, buf.iterator ); 85 | } 86 | __except ( 1 ) 87 | { 88 | 89 | } 90 | } 91 | 92 | // Reset the buffer and return the newly allocated region. 93 | // 94 | buf.reset(); 95 | return ( char* ) region; 96 | }; 97 | 98 | // If we have a valid output buffer: 99 | // 100 | if ( output_length >= sizeof( ntlisp_result ) ) 101 | { 102 | if ( logger::errors.iterator ) 103 | result->errors = export_buffer( logger::errors ); 104 | if ( logger::logs.iterator ) 105 | result->outputs = export_buffer( logger::logs ); 106 | irp->IoStatus.Information = sizeof( ntlisp_result ); 107 | } 108 | 109 | // Reset logger buffers. 110 | // 111 | logger::errors.reset(); 112 | logger::logs.reset(); 113 | } 114 | 115 | // Declare success and return. 116 | // 117 | irp->IoStatus.Status = STATUS_SUCCESS; 118 | IoCompleteRequest( irp, IO_NO_INCREMENT ); 119 | return STATUS_SUCCESS; 120 | } 121 | else 122 | { 123 | // Report failure. 124 | // 125 | irp->IoStatus.Status = STATUS_UNSUCCESSFUL; 126 | IoCompleteRequest( irp, IO_NO_INCREMENT ); 127 | return STATUS_UNSUCCESSFUL; 128 | } 129 | } 130 | 131 | // Unloads the driver. 132 | // 133 | static void unload_driver( PDRIVER_OBJECT driver ) 134 | { 135 | // Destroy the Lisp context. 136 | // 137 | lisp_shutdown(ctx); 138 | 139 | // Delete the symbolic link. 140 | // 141 | UNICODE_STRING sym_link; 142 | RtlInitUnicodeString( &sym_link, L"\\DosDevices\\NtLisp" ); 143 | IoDeleteSymbolicLink( &sym_link ); 144 | 145 | // Delete the device object. 146 | // 147 | if ( PDEVICE_OBJECT device_object = driver->DeviceObject ) 148 | IoDeleteDevice( device_object ); 149 | } 150 | 151 | // Execute corporate-level security check. 152 | // 153 | static NTSTATUS security_check( PDEVICE_OBJECT device_object, PIRP irp ) 154 | { 155 | irp->IoStatus.Status = STATUS_SUCCESS; 156 | irp->IoStatus.Information = 0; 157 | IoCompleteRequest( irp, IO_NO_INCREMENT ); 158 | return STATUS_SUCCESS; 159 | } 160 | 161 | // Entry-point. 162 | // 163 | extern "C" NTSTATUS DriverEntry( DRIVER_OBJECT* DriverObject, UNICODE_STRING* RegistryPath ) 164 | { 165 | // Run static initializers. 166 | // 167 | crt::initialize(); 168 | 169 | // Create a device object. 170 | // 171 | UNICODE_STRING device_name; 172 | RtlInitUnicodeString( &device_name, L"\\Device\\NtLisp" ); 173 | 174 | PDEVICE_OBJECT device_object; 175 | NTSTATUS nt_status = IoCreateDevice 176 | ( 177 | DriverObject, 178 | 0, 179 | &device_name, 180 | FILE_DEVICE_UNKNOWN, 181 | FILE_DEVICE_SECURE_OPEN, 182 | FALSE, 183 | &device_object 184 | ); 185 | if ( !NT_SUCCESS( nt_status ) ) 186 | return nt_status; 187 | 188 | // Set callbacks. 189 | // 190 | DriverObject->DriverUnload = &unload_driver; 191 | DriverObject->MajorFunction[ IRP_MJ_CREATE ] = &security_check; 192 | DriverObject->MajorFunction[ IRP_MJ_CLOSE ] = &security_check; 193 | DriverObject->MajorFunction[ IRP_MJ_DEVICE_CONTROL ] = &device_control; 194 | 195 | // Create a symbolic link. 196 | // 197 | UNICODE_STRING dos_device; 198 | RtlInitUnicodeString( &dos_device, L"\\DosDevices\\NtLisp" ); 199 | nt_status = IoCreateSymbolicLink( &dos_device, &device_name ); 200 | if ( !NT_SUCCESS( nt_status ) ) 201 | { 202 | IoDeleteDevice( device_object ); 203 | return nt_status; 204 | } 205 | 206 | // Initialize Lisp. 207 | // 208 | ctx = lisp_init_lib(); 209 | return STATUS_SUCCESS; 210 | } -------------------------------------------------------------------------------- /NtLispRepl/NtLispRepl.vcxproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Debug 6 | Win32 7 | 8 | 9 | Release 10 | Win32 11 | 12 | 13 | Debug 14 | x64 15 | 16 | 17 | Release 18 | x64 19 | 20 | 21 | 22 | 16.0 23 | Win32Proj 24 | {82b12053-4da0-440b-8af4-55f49658299e} 25 | ActualConsole 26 | 10.0 27 | 28 | 29 | 30 | Application 31 | true 32 | v142 33 | Unicode 34 | 35 | 36 | Application 37 | false 38 | v142 39 | true 40 | Unicode 41 | 42 | 43 | Application 44 | true 45 | v142 46 | Unicode 47 | 48 | 49 | Application 50 | false 51 | v142 52 | true 53 | Unicode 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | true 75 | 76 | 77 | false 78 | 79 | 80 | true 81 | 82 | 83 | false 84 | 85 | 86 | 87 | Level3 88 | true 89 | WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) 90 | true 91 | 92 | 93 | Console 94 | true 95 | 96 | 97 | 98 | 99 | Level3 100 | true 101 | true 102 | true 103 | WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) 104 | true 105 | 106 | 107 | Console 108 | true 109 | true 110 | true 111 | 112 | 113 | 114 | 115 | Level3 116 | true 117 | _DEBUG;_CONSOLE;%(PreprocessorDefinitions) 118 | true 119 | MultiThreadedDebug 120 | stdcpplatest 121 | 122 | 123 | Console 124 | true 125 | 126 | 127 | 128 | 129 | Level3 130 | true 131 | true 132 | true 133 | NDEBUG;_CONSOLE;%(PreprocessorDefinitions) 134 | true 135 | MultiThreaded 136 | stdcpplatest 137 | 138 | 139 | Console 140 | true 141 | true 142 | true 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | -------------------------------------------------------------------------------- /NtLispRepl/NtLispRepl.vcxproj.filters: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /NtLispRepl/main.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include "../NtLisp/driver_io.hpp" 7 | 8 | int main() 9 | { 10 | // Create a handle to the device. 11 | // 12 | HANDLE device = CreateFileA 13 | ( 14 | "\\\\.\\NtLisp", 15 | GENERIC_READ | GENERIC_WRITE, 16 | FILE_SHARE_READ | FILE_SHARE_WRITE, 17 | NULL, 18 | OPEN_EXISTING, 19 | FILE_ATTRIBUTE_NORMAL, 20 | NULL 21 | ); 22 | if ( device == INVALID_HANDLE_VALUE ) return 1; 23 | 24 | // Enter REPL: 25 | // 26 | while ( 1 ) 27 | { 28 | // Reset colors and ask user for input. 29 | // 30 | SetConsoleTextAttribute( GetStdHandle( STD_OUTPUT_HANDLE ), 7 ); 31 | std::string buffer; 32 | std::cout << "=> "; 33 | std::getline( std::cin, buffer ); 34 | 35 | // While shift is being held, allow multiple lines to be inputted. 36 | // 37 | while ( GetAsyncKeyState( VK_SHIFT ) & 0x8000 ) 38 | { 39 | std::string buffer2; 40 | std::cout << " "; 41 | std::getline( std::cin, buffer2 ); 42 | buffer += "\n" + buffer2; 43 | } 44 | 45 | // Send IOCTL. 46 | // 47 | ntlisp_result result = { 48 | nullptr, 49 | nullptr 50 | }; 51 | 52 | DWORD discarded = 0; 53 | DeviceIoControl( 54 | device, 55 | NTLISP_RUN, 56 | &buffer[0], buffer.size() + 1, 57 | &result, sizeof( result ), 58 | &discarded, nullptr 59 | ); 60 | 61 | // Print each buffer if relevant. 62 | // 63 | for ( auto& [buffer, color] : { std::pair{ result.errors, 12 }, 64 | std::pair{ result.outputs, 15 } } ) 65 | { 66 | if ( !buffer ) continue; 67 | SetConsoleTextAttribute( GetStdHandle( STD_OUTPUT_HANDLE ), color ); 68 | puts( buffer ); 69 | VirtualFree( buffer, 0, MEM_RELEASE ); 70 | } 71 | } 72 | } -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NtLisp 2 | 3 | Since [NtLua](https://github.com/can1357/NtLua) and [NtPhp](https://github.com/mrexodia/NtPhp) there has been an insatiable desire for more scripting languages in the kernel, so here is [lisp](https://github.com/justinmeiners/lisp-interpreter) in the kernel! 4 | 5 | ## ![](./vmware_03-17-34.png) 6 | -------------------------------------------------------------------------------- /vmware_03-17-34.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrexodia/NtLisp/41916fade5525aad448e2a602746d93fcef7d14d/vmware_03-17-34.png --------------------------------------------------------------------------------