├── .gitignore ├── LICENSE ├── README.md ├── src ├── base.scm ├── bignums.cpp ├── bignums.hpp ├── chars.cpp ├── charset.cpp ├── compare.cpp ├── compile.cpp ├── compile.hpp ├── execute.cpp ├── execute.hpp ├── filesys.cpp ├── foment.cpp ├── foment.hpp ├── gc.cpp ├── genpass.cpp ├── genprops.cpp ├── hashtbl.cpp ├── io.cpp ├── io.hpp ├── library.cpp ├── license.txt ├── main.cpp ├── midpass.cpp ├── numbers.cpp ├── pairs.cpp ├── process.cpp ├── random.cpp ├── read.cpp ├── srfi-1.scm ├── srfi-106.scm ├── srfi-125.scm ├── srfi-128.scm ├── srfi-133.scm ├── srfi-14.scm ├── srfi-151.scm ├── srfi-166.scm ├── srfi-193.scm ├── srfi-207.scm ├── srfi-60.scm ├── strings.cpp ├── syncthrd.cpp ├── syncthrd.hpp ├── synpass.cpp ├── synrules.cpp ├── txt2cpp.cpp ├── unicase.hpp ├── unicode.cpp ├── unicode.hpp ├── unicrng.hpp ├── vectors.cpp └── write.cpp ├── test ├── chibi-test.sld ├── eccentric.scm ├── exitcode.cpp ├── foment.scm ├── hang.cpp ├── include.scm ├── include2.scm ├── include3.scm ├── include4.scm ├── include5.scm ├── input.txt ├── lib-a-b-c.sld ├── lib │ ├── ce1.sld │ ├── ce2.sld │ ├── t1.sld │ ├── t10.sld │ ├── t11.sld │ ├── t12.sld │ ├── t13.sld │ ├── t14.sld │ ├── t15.sld │ ├── t2.sld │ ├── t3.sld │ ├── t4.scm │ ├── t5.sld │ ├── t6.sld │ ├── t7-ild.scm │ ├── t7.sld │ ├── t8.sld │ └── t9.sld ├── loadtest.scm ├── process.scm ├── r5rs_pitfall.scm ├── r7rs-eval.scm ├── r7rs-tests.scm ├── r7rs.scm ├── runtests.scm ├── srfi.scm ├── stdread.cpp ├── stdwrite.cpp ├── stress.scm ├── threads.scm └── unicode.scm ├── unidata ├── gencase.cpp ├── gencrng.cpp ├── genul.cpp └── makefile ├── unix └── makefile └── windows ├── .gitignore ├── makefile └── test.scm /.gitignore: -------------------------------------------------------------------------------- 1 | test/output* 2 | unix/debug 3 | unix/release 4 | windows/debug 5 | windows/release 6 | unidata/*.txt 7 | unidata/debug 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, 2014, 2015, 2016 Michael Montague 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [Foment](https://github.com/leftmike/foment/wiki/Foment) is an implementation of Scheme. 2 | 3 | * Full R7RS. 4 | * Libraries and programs work. 5 | * Native threads and some synchronization primitives. 6 | * [Proccess](Processes) is a subset of the [Racket](https://racket-lang.org/) 7 | [Processes API](https://docs.racket-lang.org/reference/subprocess.html). 8 | * Memory management including guardians. Guardians protect objects from being collected. 9 | * Full Unicode including reading and writing unicode characters to the console. Files in UTF-8 and UTF-16 encoding can be read and written. 10 | * The system is built around a compiler and VM. There is support for prompts and continuation marks. 11 | * Network support. 12 | * Editing at the REPL including ( ) matching. 13 | * Portable: Windows, Mac OS X, Linux, and FreeBSD. 14 | * [Package](https://gitlab.com/jpellegrini/openwrt-packages) for OpenWRT. 15 | * [Dockerfile](https://github.com/weinholt/scheme-docker/tree/foment/foment). 16 | * 32 bit and 64 bit. 17 | * SRFI 1: List Library 18 | * SRFI 14: Character-set Library 19 | * SRFI 18: Multithreading support 20 | * SRFI 22: Running Scheme Scripts on Unix 21 | * SRFI 27: Sources of Random Bits 22 | * SRFI 39: Parameter objects 23 | * SRFI 60: Integers as Bits 24 | * SRFI 106: Basic socket interface 25 | * SRFI 111: Boxes 26 | * SRFI 112: Environment Inquiry 27 | * SRFI 124: Ephemerons 28 | * SRFI 125: Hash Tables 29 | * SRFI 128: Comparators 30 | * SRFI 133: Vector Library (R7RS-compatible) 31 | * SRFI 151: Bitwise Operations 32 | * SRFI 157: Continuation marks 33 | * SRFI 166: Monadic Formatting 34 | * SRFI 176: Version flag 35 | * SRFI 181: Custom ports (including transcoded ports) 36 | * SRFI 192: Port Positioning 37 | * SRFI 193: Command line 38 | * SRFI 207: String-notated bytevectors 39 | * SRFI 229: Tagged Procedures 40 | 41 | See [Foment](https://github.com/leftmike/foment/wiki/Foment) for more details. 42 | 43 | Please note that this is very much a work in progress. Please let me know if 44 | you find bugs and omissions. I will do my best to fix them. 45 | 46 | mikemon@gmail.com 47 | -------------------------------------------------------------------------------- /src/bignums.hpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #ifndef __BIGNUMS_HPP__ 8 | #define __BIGNUMS_HPP__ 9 | 10 | #if defined(FOMENT_WINDOWS) && defined(NAN) 11 | #undef NAN 12 | #endif 13 | #ifdef FOMENT_WINDOWS 14 | #include 15 | #endif // FOMENT_WINDOWS 16 | #include 17 | #include 18 | 19 | // ---- Population Count ---- 20 | 21 | #ifdef FOMENT_UNIX 22 | #ifdef FOMENT_64BIT 23 | #define PopulationCount(x) __builtin_popcountl(x) 24 | #else // FOMENT_64BIT 25 | #define PopulationCount(x) __builtin_popcount(x) 26 | #endif // FOMENT_64BIT 27 | #endif // FOMENT_UNIX 28 | 29 | #ifdef FOMENT_WINDOWS 30 | #ifdef FOMENT_64BIT 31 | #define PopulationCount(x) __popcnt64(x) 32 | #endif // FOMENT_64BIT 33 | #ifdef FOMENT_32BIT 34 | #define PopulationCount(x) __popcnt(x) 35 | #endif // FOMENT_32BIT 36 | #endif // FOMENT_WINDOWS 37 | 38 | // popcount_3 from http://en.wikipedia.org/wiki/Hamming_weight#Efficient_implementation 39 | 40 | #ifndef PopulationCount 41 | const uint64_t m1 = 0x5555555555555555; //binary: 0101... 42 | const uint64_t m2 = 0x3333333333333333; //binary: 00110011.. 43 | const uint64_t m4 = 0x0f0f0f0f0f0f0f0f; //binary: 4 zeros, 4 ones ... 44 | const uint64_t h01 = 0x0101010101010101; //the sum of 256 to the power of 0,1,2,3... 45 | 46 | inline unsigned int PopulationCount(uint64_t x) 47 | { 48 | x -= (x >> 1) & m1; //put count of each 2 bits into those 2 bits 49 | x = (x & m2) + ((x >> 2) & m2); //put count of each 4 bits into those 4 bits 50 | x = (x + (x >> 4)) & m4; //put count of each 8 bits into those 8 bits 51 | return (x * h01) >> 56; //returns left 8 bits of x + (x<<8) + (x<<16) + (x<<24) + ... 52 | } 53 | #endif 54 | 55 | // ---- Highest Bit ---- 56 | 57 | inline unsigned int HighestBitUInt32(uint32_t n) 58 | { 59 | unsigned int b = 0; 60 | uint32_t t; 61 | 62 | if ((t = n & 0xFFFF0000) != 0) 63 | { 64 | b += 16; 65 | n = t; 66 | } 67 | if ((t = n & 0xFF00FF00) != 0) 68 | { 69 | b += 8; 70 | n = t; 71 | } 72 | if ((t = n & 0xF0F0F0F0) != 0) 73 | { 74 | b += 4; 75 | n = t; 76 | } 77 | if ((t = n & 0xCCCCCCCC) != 0) 78 | { 79 | b += 2; 80 | n = t; 81 | } 82 | return((n & 0xAAAAAAAA) ? b + 1 : b); 83 | } 84 | 85 | inline unsigned int HighestBitUInt64(uint64_t n) 86 | { 87 | unsigned int b = 0; 88 | uint64_t t; 89 | 90 | if ((t = n & 0xFFFFFFFF00000000) != 0) 91 | { 92 | b += 32; 93 | n = t; 94 | } 95 | if ((t = n & 0xFFFF0000FFFF0000) != 0) 96 | { 97 | b += 16; 98 | n = t; 99 | } 100 | if ((t = n & 0xFF00FF00FF00FF00) != 0) 101 | { 102 | b += 8; 103 | n = t; 104 | } 105 | if ((t = n & 0xF0F0F0F0F0F0F0F0) != 0) 106 | { 107 | b += 4; 108 | n = t; 109 | } 110 | if ((t = n & 0xCCCCCCCCCCCCCCCC) != 0) 111 | { 112 | b += 2; 113 | n = t; 114 | } 115 | return((n & 0xAAAAAAAAAAAAAAAA) ? b + 1 : b); 116 | } 117 | 118 | inline double64_t Truncate(double64_t n) 119 | { 120 | #ifdef FOMENT_WINDOWS 121 | return(((n) < 0) ? ceil((n)) : floor((n))); 122 | #else // FOMENT_WINDOWS 123 | return(trunc(n)); 124 | #endif // FOMENT_WINDOWS 125 | } 126 | 127 | long_t IsFinite(double64_t d); 128 | 129 | FObject MakeBignumFromLong(long_t n); 130 | FObject MakeBignumFromDouble(double64_t d); 131 | FObject CopyBignum(FObject n); 132 | FObject ToBignum(FObject obj); // should be static 133 | FObject Normalize(FObject num); // should be static inline 134 | double64_t BignumToDouble(FObject bn); // check who calls 135 | char * BignumToStringC(FObject bn, uint32_t rdx); 136 | FObject ToExactRatio(double64_t d); 137 | long_t ParseBignum(FCh * s, long_t sl, long_t sdx, long_t rdx, int16_t sgn, long_t n, 138 | FObject * punt); 139 | long_t BignumCompare(FObject bn1, FObject bn2); 140 | long_t BignumSign(FObject bn); 141 | FObject BignumAdd(FObject bn1, FObject bn2); 142 | FObject BignumAddLong(FObject bn, long_t n); 143 | FObject BignumMultiply(FObject bn1, FObject bn2); 144 | FObject BignumMultiplyLong(FObject bn, long_t n); 145 | FObject BignumSubtract(FObject bn1, FObject bn2); 146 | long_t BignumOddP(FObject n); 147 | ulong_t BignumHash(FObject n); 148 | FObject BignumDivide(FObject n, FObject d); 149 | FObject BignumRemainder(FObject n, FObject d); 150 | FObject BignumSqrt(FObject * rem, FObject bn); 151 | FObject BignumAnd(FObject bn1, FObject bn2); 152 | FObject BignumIOr(FObject bn1, FObject bn2); 153 | FObject BignumXOr(FObject bn1, FObject bn2); 154 | FObject BignumNot(FObject bn); 155 | ulong_t BignumBitCount(FObject bn); 156 | ulong_t BignumIntegerLength(FObject bn); 157 | FObject BignumArithmeticShift(FObject bn, long_t cnt); 158 | void SetupBignums(); 159 | 160 | #endif // __BIGNUMS_HPP__ 161 | -------------------------------------------------------------------------------- /src/chars.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #include "foment.hpp" 8 | #include "unicode.hpp" 9 | 10 | // ---- Characters ---- 11 | 12 | Define("char?", CharPPrimitive)(long_t argc, FObject argv[]) 13 | { 14 | OneArgCheck("char?", argc); 15 | 16 | return(CharacterP(argv[0]) ? TrueObject : FalseObject); 17 | } 18 | 19 | Define("char=?", CharEqualPPrimitive)(long_t argc, FObject argv[]) 20 | { 21 | AtLeastTwoArgsCheck("char=?", argc); 22 | CharacterArgCheck("char=?", argv[0]); 23 | 24 | for (long_t adx = 1; adx < argc; adx++) 25 | { 26 | CharacterArgCheck("char=?", argv[adx]); 27 | 28 | if (AsCharacter(argv[adx - 1]) != AsCharacter(argv[adx])) 29 | return(FalseObject); 30 | } 31 | 32 | return(TrueObject); 33 | } 34 | 35 | Define("char= AsCharacter(argv[adx])) 45 | return(FalseObject); 46 | } 47 | 48 | return(TrueObject); 49 | } 50 | 51 | Define("char>?", CharGreaterThanPPrimitive)(long_t argc, FObject argv[]) 52 | { 53 | AtLeastTwoArgsCheck("char>?", argc); 54 | CharacterArgCheck("char>?", argv[0]); 55 | 56 | for (long_t adx = 1; adx < argc; adx++) 57 | { 58 | CharacterArgCheck("char>?", argv[adx]); 59 | 60 | if (AsCharacter(argv[adx - 1]) <= AsCharacter(argv[adx])) 61 | return(FalseObject); 62 | } 63 | 64 | return(TrueObject); 65 | } 66 | 67 | Define("char<=?", CharLessThanEqualPPrimitive)(long_t argc, FObject argv[]) 68 | { 69 | AtLeastTwoArgsCheck("char<=?", argc); 70 | CharacterArgCheck("char<=?", argv[0]); 71 | 72 | for (long_t adx = 1; adx < argc; adx++) 73 | { 74 | CharacterArgCheck("char<=?", argv[adx]); 75 | 76 | if (AsCharacter(argv[adx - 1]) > AsCharacter(argv[adx])) 77 | return(FalseObject); 78 | } 79 | 80 | return(TrueObject); 81 | } 82 | 83 | Define("char>=?", CharGreaterThanEqualPPrimitive)(long_t argc, FObject argv[]) 84 | { 85 | AtLeastTwoArgsCheck("char>=?", argc); 86 | CharacterArgCheck("char>=?", argv[0]); 87 | 88 | for (long_t adx = 1; adx < argc; adx++) 89 | { 90 | CharacterArgCheck("char>=?", argv[adx]); 91 | 92 | if (AsCharacter(argv[adx - 1]) < AsCharacter(argv[adx])) 93 | return(FalseObject); 94 | } 95 | 96 | return(TrueObject); 97 | } 98 | 99 | Define("char-ci=?", CharCiEqualPPrimitive)(long_t argc, FObject argv[]) 100 | { 101 | AtLeastTwoArgsCheck("char-ci=?", argc); 102 | CharacterArgCheck("char-ci=?", argv[0]); 103 | 104 | for (long_t adx = 1; adx < argc; adx++) 105 | { 106 | CharacterArgCheck("char-ci=?", argv[adx]); 107 | 108 | if (CharFoldcase(AsCharacter(argv[adx - 1])) != CharFoldcase(AsCharacter(argv[adx]))) 109 | return(FalseObject); 110 | } 111 | 112 | return(TrueObject); 113 | } 114 | 115 | Define("char-ci= CharFoldcase(AsCharacter(argv[adx]))) 125 | return(FalseObject); 126 | } 127 | 128 | return(TrueObject); 129 | } 130 | 131 | Define("char-ci>?", CharCiGreaterThanPPrimitive)(long_t argc, FObject argv[]) 132 | { 133 | AtLeastTwoArgsCheck("char-ci>?", argc); 134 | CharacterArgCheck("char-ci>?", argv[0]); 135 | 136 | for (long_t adx = 1; adx < argc; adx++) 137 | { 138 | CharacterArgCheck("char-ci>?", argv[adx]); 139 | 140 | if (CharFoldcase(AsCharacter(argv[adx - 1])) <= CharFoldcase(AsCharacter(argv[adx]))) 141 | return(FalseObject); 142 | } 143 | 144 | return(TrueObject); 145 | } 146 | 147 | Define("char-ci<=?", CharCiLessThanEqualPPrimitive)(long_t argc, FObject argv[]) 148 | { 149 | AtLeastTwoArgsCheck("char-ci<=?", argc); 150 | CharacterArgCheck("char-ci<=?", argv[0]); 151 | 152 | for (long_t adx = 1; adx < argc; adx++) 153 | { 154 | CharacterArgCheck("char-ci<=?", argv[adx]); 155 | 156 | if (CharFoldcase(AsCharacter(argv[adx - 1])) > CharFoldcase(AsCharacter(argv[adx]))) 157 | return(FalseObject); 158 | } 159 | 160 | return(TrueObject); 161 | } 162 | 163 | Define("char-ci>=?", CharCiGreaterThanEqualPPrimitive)(long_t argc, FObject argv[]) 164 | { 165 | AtLeastTwoArgsCheck("char-ci>=?", argc); 166 | CharacterArgCheck("char-ci>=?", argv[0]); 167 | 168 | for (long_t adx = 1; adx < argc; adx++) 169 | { 170 | CharacterArgCheck("char-ci>=?", argv[adx]); 171 | 172 | if (CharFoldcase(AsCharacter(argv[adx - 1])) < CharFoldcase(AsCharacter(argv[adx]))) 173 | return(FalseObject); 174 | } 175 | 176 | return(TrueObject); 177 | } 178 | 179 | Define("char-alphabetic?", CharAlphabeticPPrimitive)(long_t argc, FObject argv[]) 180 | { 181 | OneArgCheck("char-alphabetic?", argc); 182 | CharacterArgCheck("char-alphabetic?", argv[0]); 183 | 184 | return(AlphabeticP(AsCharacter(argv[0])) ? TrueObject : FalseObject); 185 | } 186 | 187 | Define("char-numeric?", CharNumericPPrimitive)(long_t argc, FObject argv[]) 188 | { 189 | OneArgCheck("char-numeric?", argc); 190 | CharacterArgCheck("char-numeric?", argv[0]); 191 | 192 | return(DigitP(AsCharacter(argv[0])) ? TrueObject : FalseObject); 193 | } 194 | 195 | Define("char-whitespace?", CharWhitespacePPrimitive)(long_t argc, FObject argv[]) 196 | { 197 | OneArgCheck("char-whitespace?", argc); 198 | CharacterArgCheck("char-whitespace?", argv[0]); 199 | 200 | return(WhitespaceP(AsCharacter(argv[0])) ? TrueObject : FalseObject); 201 | } 202 | 203 | Define("char-upper-case?", CharUpperCasePPrimitive)(long_t argc, FObject argv[]) 204 | { 205 | OneArgCheck("char-upper-case?", argc); 206 | CharacterArgCheck("char-upper-case?", argv[0]); 207 | 208 | return(UppercaseP(AsCharacter(argv[0])) ? TrueObject : FalseObject); 209 | } 210 | 211 | Define("char-lower-case?", CharLowerCasePPrimitive)(long_t argc, FObject argv[]) 212 | { 213 | OneArgCheck("char-lower-case?", argc); 214 | CharacterArgCheck("char-lower-case?", argv[0]); 215 | 216 | return(LowercaseP(AsCharacter(argv[0])) ? TrueObject : FalseObject); 217 | } 218 | 219 | Define("digit-value", DigitValuePrimitive)(long_t argc, FObject argv[]) 220 | { 221 | OneArgCheck("digit-value", argc); 222 | CharacterArgCheck("digit-value", argv[0]); 223 | 224 | long_t dv = DigitValue(AsCharacter(argv[0])); 225 | if (dv < 0 || dv > 9) 226 | return(FalseObject); 227 | return(MakeFixnum(dv)); 228 | } 229 | 230 | Define("char->integer", CharToIntegerPrimitive)(long_t argc, FObject argv[]) 231 | { 232 | OneArgCheck("char->integer", argc); 233 | CharacterArgCheck("char->integer", argv[0]); 234 | 235 | return(MakeFixnum(AsCharacter(argv[0]))); 236 | } 237 | 238 | Define("integer->char", IntegerToCharPrimitive)(long_t argc, FObject argv[]) 239 | { 240 | OneArgCheck("integer->char", argc); 241 | FixnumArgCheck("integer->char", argv[0]); 242 | 243 | return(MakeCharacter(AsFixnum(argv[0]))); 244 | } 245 | 246 | Define("char-upcase", CharUpcasePrimitive)(long_t argc, FObject argv[]) 247 | { 248 | OneArgCheck("char-upcase", argc); 249 | CharacterArgCheck("char-upcase", argv[0]); 250 | 251 | return(MakeCharacter(CharUpcase(AsCharacter(argv[0])))); 252 | } 253 | 254 | Define("char-downcase", CharDowncasePrimitive)(long_t argc, FObject argv[]) 255 | { 256 | OneArgCheck("char-downcase", argc); 257 | CharacterArgCheck("char-downcase", argv[0]); 258 | 259 | return(MakeCharacter(CharDowncase(AsCharacter(argv[0])))); 260 | } 261 | 262 | Define("char-foldcase", CharFoldcasePrimitive)(long_t argc, FObject argv[]) 263 | { 264 | OneArgCheck("char-foldcase", argc); 265 | CharacterArgCheck("char-foldcase", argv[0]); 266 | 267 | return(MakeCharacter(CharFoldcase(AsCharacter(argv[0])))); 268 | } 269 | 270 | static FObject Primitives[] = 271 | { 272 | CharPPrimitive, 273 | CharEqualPPrimitive, 274 | CharLessThanPPrimitive, 275 | CharGreaterThanPPrimitive, 276 | CharLessThanEqualPPrimitive, 277 | CharGreaterThanEqualPPrimitive, 278 | CharCiEqualPPrimitive, 279 | CharCiLessThanPPrimitive, 280 | CharCiGreaterThanPPrimitive, 281 | CharCiLessThanEqualPPrimitive, 282 | CharCiGreaterThanEqualPPrimitive, 283 | CharAlphabeticPPrimitive, 284 | CharNumericPPrimitive, 285 | CharWhitespacePPrimitive, 286 | CharUpperCasePPrimitive, 287 | CharLowerCasePPrimitive, 288 | DigitValuePrimitive, 289 | CharToIntegerPrimitive, 290 | IntegerToCharPrimitive, 291 | CharUpcasePrimitive, 292 | CharDowncasePrimitive, 293 | CharFoldcasePrimitive 294 | }; 295 | 296 | void SetupCharacters() 297 | { 298 | for (ulong_t idx = 0; idx < sizeof(Primitives) / sizeof(FPrimitive *); idx++) 299 | DefinePrimitive(Bedrock, BedrockLibrary, Primitives[idx]); 300 | } 301 | -------------------------------------------------------------------------------- /src/compare.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #ifdef FOMENT_WINDOWS 8 | #include 9 | #endif // FOMENT_WINDOWS 10 | 11 | #ifdef FOMENT_UNIX 12 | #include 13 | #endif // FOMENT_UNIX 14 | 15 | #include "foment.hpp" 16 | #include "syncthrd.hpp" 17 | #include "unicode.hpp" 18 | 19 | // ---- Comparator ---- 20 | 21 | Define("no-ordering-predicate", NoOrderingPredicatePrimitive)(long_t argc, FObject argv[]) 22 | { 23 | TwoArgsCheck("no-ordering-predicate", argc); 24 | 25 | RaiseExceptionC(Assertion, "no-ordering-predicate", "no ordering predicate available", 26 | EmptyListObject); 27 | return(NoValueObject); 28 | } 29 | 30 | Define("no-hash-function", NoHashFunctionPrimitive)(long_t argc, FObject argv[]) 31 | { 32 | OneArgCheck("no-hash-function", argc); 33 | 34 | RaiseExceptionC(Assertion, "no-hash-function", "no hash function available", EmptyListObject); 35 | return(NoValueObject); 36 | } 37 | 38 | // ---- Comparator ---- 39 | 40 | static FObject MakeComparator(FObject ttp, FObject eqp, FObject orderp, FObject hashfn) 41 | { 42 | FComparator * comp = (FComparator *) MakeObject(ComparatorTag, sizeof(FComparator), 5, 43 | "make-comparator"); 44 | comp->TypeTestP = ttp; 45 | comp->EqualityP = eqp; 46 | comp->OrderingP = (orderp == FalseObject ? NoOrderingPredicatePrimitive : orderp); 47 | comp->HashFn = (hashfn == FalseObject ? NoHashFunctionPrimitive : hashfn); 48 | comp->Context = NoValueObject; 49 | 50 | return(comp); 51 | } 52 | 53 | Define("make-comparator", MakeComparatorPrimitive)(long_t argc, FObject argv[]) 54 | { 55 | FourArgsCheck("make-comparator", argc); 56 | 57 | ProcedureArgCheck("make-comparator", argv[0]); 58 | ProcedureArgCheck("make-comparator", argv[1]); 59 | if (argv[2] != FalseObject) 60 | ProcedureArgCheck("make-comparator", argv[2]); 61 | if (argv[3] != FalseObject) 62 | ProcedureArgCheck("make-comparator", argv[3]); 63 | 64 | return(MakeComparator(argv[0], argv[1], argv[2], argv[3])); 65 | } 66 | 67 | Define("comparator?", ComparatorPPrimitive)(long_t argc, FObject argv[]) 68 | { 69 | OneArgCheck("comparator?", argc); 70 | 71 | return(ComparatorP(argv[0]) ? TrueObject : FalseObject); 72 | } 73 | 74 | Define("comparator-type-test-predicate", ComparatorTypeTestPredicatePrimitive)(long_t argc, 75 | FObject argv[]) 76 | { 77 | OneArgCheck("comparator-type-test-predicate", argc); 78 | ComparatorArgCheck("comparator-type-test-predicate", argv[0]); 79 | 80 | return(AsComparator(argv[0])->TypeTestP); 81 | } 82 | 83 | Define("comparator-equality-predicate", ComparatorEqualityPredicatePrimitive)(long_t argc, 84 | FObject argv[]) 85 | { 86 | OneArgCheck("comparator-equality-predicate", argc); 87 | ComparatorArgCheck("comparator-equality-predicate", argv[0]); 88 | 89 | return(AsComparator(argv[0])->EqualityP); 90 | } 91 | 92 | Define("comparator-ordering-predicate", ComparatorOrderingPredicatePrimitive)(long_t argc, 93 | FObject argv[]) 94 | { 95 | OneArgCheck("comparator-ordering-predicate", argc); 96 | ComparatorArgCheck("comparator-ordering-predicate", argv[0]); 97 | 98 | return(AsComparator(argv[0])->OrderingP); 99 | } 100 | 101 | Define("comparator-hash-function", ComparatorHashFunctionPrimitive)(long_t argc, FObject argv[]) 102 | { 103 | OneArgCheck("comparator-hash-function", argc); 104 | ComparatorArgCheck("comparator-hash-function", argv[0]); 105 | 106 | return(AsComparator(argv[0])->HashFn); 107 | } 108 | 109 | Define("comparator-ordered?", ComparatorOrderedPPrimitive)(long_t argc, 110 | FObject argv[]) 111 | { 112 | OneArgCheck("comparator-ordered?", argc); 113 | ComparatorArgCheck("comparator-ordered?", argv[0]); 114 | 115 | return(AsComparator(argv[0])->OrderingP == NoOrderingPredicatePrimitive ? FalseObject : 116 | TrueObject); 117 | } 118 | 119 | Define("comparator-hashable?", ComparatorHashablePPrimitive)(long_t argc, FObject argv[]) 120 | { 121 | OneArgCheck("comparator-hashable?", argc); 122 | ComparatorArgCheck("comparator-hashable?", argv[0]); 123 | 124 | return(AsComparator(argv[0])->HashFn == NoHashFunctionPrimitive ? FalseObject : TrueObject); 125 | } 126 | 127 | Define("comparator-context", ComparatorContextPrimitive)(long_t argc, FObject argv[]) 128 | { 129 | OneArgCheck("comparator-context", argc); 130 | ComparatorArgCheck("comparator-context", argv[0]); 131 | 132 | return(AsComparator(argv[0])->Context); 133 | } 134 | 135 | Define("comparator-context-set!", ComparatorContextSetPrimitive)(long_t argc, FObject argv[]) 136 | { 137 | TwoArgsCheck("comparator-context-set!", argc); 138 | ComparatorArgCheck("comparator-context-set!", argv[0]); 139 | 140 | AsComparator(argv[0])->Context = argv[1]; 141 | return(NoValueObject); 142 | } 143 | 144 | // ---- Equivalence predicates ---- 145 | 146 | long_t EqvP(FObject obj1, FObject obj2) 147 | { 148 | if (obj1 == obj2) 149 | return(1); 150 | 151 | return(GenericEqvP(obj1, obj2)); 152 | } 153 | 154 | long_t EqP(FObject obj1, FObject obj2) 155 | { 156 | if (obj1 == obj2) 157 | return(1); 158 | 159 | return(0); 160 | } 161 | 162 | // ---- Equal ---- 163 | // 164 | // Disjoint-set trees 165 | // http://en.wikipedia.org/wiki/Disjoint-set_data_structure 166 | // http://www.cs.indiana.edu/~dyb/pubs/equal.pdf 167 | 168 | static FObject EqualPFind(FObject obj) 169 | { 170 | FAssert(BoxP(obj)); 171 | 172 | if (BoxP(Unbox(obj))) 173 | { 174 | FObject ret = EqualPFind(Unbox(obj)); 175 | 176 | FAssert(BoxP(ret)); 177 | FAssert(FixnumP(Unbox(ret))); 178 | 179 | SetBox(obj, ret); 180 | return(ret); 181 | } 182 | 183 | FAssert(FixnumP(Unbox(obj))); 184 | 185 | return(obj); 186 | } 187 | 188 | static long_t EqualPUnionFind(FObject htbl, FObject objx, FObject objy) 189 | { 190 | FObject bx = HashTableRef(htbl, objx, FalseObject); 191 | FObject by = HashTableRef(htbl, objy, FalseObject); 192 | 193 | if (bx == FalseObject) 194 | { 195 | if (by == FalseObject) 196 | { 197 | FObject nb = MakeBox(MakeFixnum(1)); 198 | HashTableSet(htbl, objx, nb); 199 | HashTableSet(htbl, objy, nb); 200 | } 201 | else 202 | { 203 | FAssert(BoxP(by)); 204 | 205 | HashTableSet(htbl, objx, EqualPFind(by)); 206 | } 207 | } 208 | else 209 | { 210 | FAssert(BoxP(bx)); 211 | 212 | if (by == FalseObject) 213 | HashTableSet(htbl, objy, EqualPFind(bx)); 214 | else 215 | { 216 | FAssert(BoxP(by)); 217 | 218 | FObject rx = EqualPFind(bx); 219 | FObject ry = EqualPFind(by); 220 | 221 | FAssert(BoxP(rx)); 222 | FAssert(BoxP(ry)); 223 | FAssert(FixnumP(Unbox(rx))); 224 | FAssert(FixnumP(Unbox(ry))); 225 | 226 | if (EqP(rx, ry)) 227 | return(1); 228 | 229 | long_t nx = AsFixnum(Unbox(rx)); 230 | long_t ny = AsFixnum(Unbox(ry)); 231 | 232 | if (nx > ny) 233 | { 234 | SetBox(ry, rx); 235 | SetBox(rx, MakeFixnum(nx + ny)); 236 | } 237 | else 238 | { 239 | SetBox(rx, ry); 240 | SetBox(ry, MakeFixnum(nx + ny)); 241 | } 242 | } 243 | } 244 | 245 | return(0); 246 | } 247 | 248 | static long_t EqualP(FObject htbl, FObject obj1, FObject obj2) 249 | { 250 | if (EqvP(obj1, obj2)) 251 | return(1); 252 | 253 | if (PairP(obj1)) 254 | { 255 | if (PairP(obj2) == 0) 256 | return(0); 257 | 258 | if (EqualPUnionFind(htbl, obj1, obj2)) 259 | return(1); 260 | 261 | if (EqualP(htbl, First(obj1), First(obj2)) && EqualP(htbl, Rest(obj1), Rest(obj2))) 262 | return(1); 263 | 264 | return(0); 265 | } 266 | 267 | if (BoxP(obj1)) 268 | { 269 | if (BoxP(obj2) == 0) 270 | return(0); 271 | 272 | if (EqualPUnionFind(htbl, obj1, obj2)) 273 | return(1); 274 | 275 | return(EqualP(htbl, Unbox(obj1), Unbox(obj2))); 276 | } 277 | 278 | if (VectorP(obj1)) 279 | { 280 | if (VectorP(obj2) == 0) 281 | return(0); 282 | 283 | if (VectorLength(obj1) != VectorLength(obj2)) 284 | return(0); 285 | 286 | if (EqualPUnionFind(htbl, obj1, obj2)) 287 | return(1); 288 | 289 | for (ulong_t idx = 0; idx < VectorLength(obj1); idx++) 290 | if (EqualP(htbl, AsVector(obj1)->Vector[idx], AsVector(obj2)->Vector[idx]) == 0) 291 | return(0); 292 | 293 | return(1); 294 | } 295 | 296 | if (StringP(obj1)) 297 | { 298 | if (StringP(obj2) == 0) 299 | return(0); 300 | 301 | return(StringCompare(obj1, obj2) == 0); 302 | } 303 | 304 | if (BytevectorP(obj1)) 305 | { 306 | if (BytevectorP(obj2) == 0) 307 | return(0); 308 | 309 | if (BytevectorLength(obj1) != BytevectorLength(obj2)) 310 | return(0); 311 | 312 | for (ulong_t idx = 0; idx < BytevectorLength(obj1); idx++) 313 | if (AsBytevector(obj1)->Vector[idx] != AsBytevector(obj2)->Vector[idx]) 314 | return(0); 315 | return(1); 316 | } 317 | 318 | return(0); 319 | } 320 | 321 | long_t EqualP(FObject obj1, FObject obj2) 322 | { 323 | return(EqualP(MakeEqHashTable(128, 0), obj1, obj2)); 324 | } 325 | 326 | Define("eqv?", EqvPPrimitive)(long_t argc, FObject argv[]) 327 | { 328 | TwoArgsCheck("eqv?", argc); 329 | 330 | return(EqvP(argv[0], argv[1]) ? TrueObject : FalseObject); 331 | } 332 | 333 | Define("eq?", EqPPrimitive)(long_t argc, FObject argv[]) 334 | { 335 | TwoArgsCheck("eq?", argc); 336 | 337 | return(EqP(argv[0], argv[1]) ? TrueObject : FalseObject); 338 | } 339 | 340 | Define("equal?", EqualPPrimitive)(long_t argc, FObject argv[]) 341 | { 342 | TwoArgsCheck("equal?", argc); 343 | 344 | return(EqualP(argv[0], argv[1]) ? TrueObject : FalseObject); 345 | } 346 | 347 | // ---- Hashing ---- 348 | 349 | inline ulong_t HashBound() 350 | { 351 | FAssert(FixnumP(Parameter(PARAMETER_HASH_BOUND))); 352 | 353 | return(AsFixnum(Parameter(PARAMETER_HASH_BOUND))); 354 | } 355 | 356 | inline ulong_t HashSalt() 357 | { 358 | FAssert(FixnumP(Parameter(PARAMETER_HASH_SALT))); 359 | 360 | return(AsFixnum(Parameter(PARAMETER_HASH_SALT))); 361 | } 362 | 363 | Define("%check-hash-bound", CheckHashBoundPrimitive)(long_t argc, FObject argv[]) 364 | { 365 | FMustBe(argc == 1); 366 | NonNegativeArgCheck("%check-hash-bound", argv[0], 1); 367 | 368 | if (BignumP(argv[0])) 369 | return(MakeFixnum(MAXIMUM_FIXNUM)); 370 | 371 | FAssert(FixnumP(argv[0])); 372 | 373 | return(argv[0]); 374 | } 375 | 376 | Define("%check-hash-salt", CheckHashSaltPrimitive)(long_t argc, FObject argv[]) 377 | { 378 | FMustBe(argc == 1); 379 | NonNegativeArgCheck("%check-hash-salt", argv[0], 1); 380 | 381 | if (BignumP(argv[0])) 382 | return(MakeFixnum(MAXIMUM_FIXNUM)); 383 | 384 | FAssert(FixnumP(argv[0])); 385 | 386 | return(argv[0]); 387 | } 388 | 389 | Define("boolean-hash", BooleanHashPrimitive)(long_t argc, FObject argv[]) 390 | { 391 | OneArgCheck("boolean-hash", argc); 392 | BooleanArgCheck("boolean-hash", argv[0]); 393 | 394 | return(MakeFixnum(argv[0] == FalseObject ? 0 : HashSalt() % HashBound())); 395 | } 396 | 397 | Define("char-hash", CharHashPrimitive)(long_t argc, FObject argv[]) 398 | { 399 | OneArgCheck("char-hash", argc); 400 | CharacterArgCheck("char-hash", argv[0]); 401 | 402 | return(MakeFixnum((AsCharacter(argv[0]) * HashSalt()) % HashBound())); 403 | } 404 | 405 | Define("char-ci-hash", CharCiHashPrimitive)(long_t argc, FObject argv[]) 406 | { 407 | OneArgCheck("char-ci-hash", argc); 408 | CharacterArgCheck("char-ci-hash", argv[0]); 409 | 410 | return(MakeFixnum((CharFoldcase(AsCharacter(argv[0])) * HashSalt()) % HashBound())); 411 | } 412 | 413 | Define("string-hash", StringHashPrimitive)(long_t argc, FObject argv[]) 414 | { 415 | OneArgCheck("string-hash", argc); 416 | StringArgCheck("string-hash", argv[0]); 417 | 418 | return(MakeFixnum((StringHash(argv[0]) * HashSalt()) % HashBound())); 419 | } 420 | 421 | Define("string-ci-hash", StringCiHashPrimitive)(long_t argc, FObject argv[]) 422 | { 423 | OneArgCheck("string-ci-hash", argc); 424 | StringArgCheck("string-ci-hash", argv[0]); 425 | 426 | return(MakeFixnum((StringCiHash(argv[0]) * HashSalt()) % HashBound())); 427 | } 428 | 429 | Define("symbol-hash", SymbolHashPrimitive)(long_t argc, FObject argv[]) 430 | { 431 | OneArgCheck("symbol-hash", argc); 432 | SymbolArgCheck("symbol-hash", argv[0]); 433 | 434 | return(MakeFixnum((SymbolHash(argv[0]) * HashSalt()) % HashBound())); 435 | } 436 | 437 | Define("number-hash", NumberHashPrimitive)(long_t argc, FObject argv[]) 438 | { 439 | OneArgCheck("number-hash", argc); 440 | NumberArgCheck("number-hash", argv[0]); 441 | 442 | return(MakeFixnum((NumberHash(argv[0]) * HashSalt()) % HashBound())); 443 | } 444 | 445 | uint32_t EqHash(FObject obj) 446 | { 447 | return(NormalizeHash(((ulong_t) obj) >> 3)); 448 | } 449 | 450 | Define("eq-hash", EqHashPrimitive)(long_t argc, FObject argv[]) 451 | { 452 | OneArgCheck("eq-hash", argc); 453 | 454 | // Do not add HashSalt and HashBound because EqHash is used internally by EqHashTable*. 455 | 456 | return(MakeFixnum(EqHash(argv[0]))); 457 | } 458 | 459 | // ---- Primitives ---- 460 | 461 | static FObject Primitives[] = 462 | { 463 | MakeComparatorPrimitive, 464 | ComparatorPPrimitive, 465 | ComparatorTypeTestPredicatePrimitive, 466 | ComparatorEqualityPredicatePrimitive, 467 | ComparatorOrderingPredicatePrimitive, 468 | ComparatorHashFunctionPrimitive, 469 | ComparatorOrderedPPrimitive, 470 | ComparatorHashablePPrimitive, 471 | ComparatorContextPrimitive, 472 | ComparatorContextSetPrimitive, 473 | EqvPPrimitive, 474 | EqPPrimitive, 475 | EqualPPrimitive, 476 | CheckHashBoundPrimitive, 477 | CheckHashSaltPrimitive, 478 | BooleanHashPrimitive, 479 | CharHashPrimitive, 480 | CharCiHashPrimitive, 481 | StringHashPrimitive, 482 | StringCiHashPrimitive, 483 | SymbolHashPrimitive, 484 | NumberHashPrimitive, 485 | EqHashPrimitive 486 | }; 487 | 488 | void SetupCompare() 489 | { 490 | for (ulong_t idx = 0; idx < sizeof(Primitives) / sizeof(FPrimitive *); idx++) 491 | DefinePrimitive(Bedrock, BedrockLibrary, Primitives[idx]); 492 | } 493 | -------------------------------------------------------------------------------- /src/compile.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #include "foment.hpp" 8 | #include "compile.hpp" 9 | 10 | EternalSymbol(TagSymbol, "tag"); 11 | EternalSymbol(UsePassSymbol, "use-pass"); 12 | EternalSymbol(ConstantPassSymbol, "constant-pass"); 13 | EternalSymbol(AnalysisPassSymbol, "analysis-pass"); 14 | 15 | // ---- Roots ---- 16 | 17 | FObject ElseReference = NoValueObject; 18 | FObject ArrowReference = NoValueObject; 19 | FObject LibraryReference = NoValueObject; 20 | FObject AndReference = NoValueObject; 21 | FObject OrReference = NoValueObject; 22 | FObject NotReference = NoValueObject; 23 | FObject QuasiquoteReference = NoValueObject; 24 | FObject UnquoteReference = NoValueObject; 25 | FObject UnquoteSplicingReference = NoValueObject; 26 | FObject ConsReference = NoValueObject; 27 | FObject AppendReference = NoValueObject; 28 | FObject ListToVectorReference = NoValueObject; 29 | FObject EllipsisReference = NoValueObject; 30 | FObject UnderscoreReference = NoValueObject; 31 | 32 | static FObject InteractionEnv = NoValueObject; 33 | 34 | // ---- SyntacticEnv ---- 35 | 36 | FObject MakeSyntacticEnv(FObject obj) 37 | { 38 | FAssert(EnvironmentP(obj) || SyntacticEnvP(obj)); 39 | 40 | FSyntacticEnv * se = (FSyntacticEnv *) MakeObject(SyntacticEnvTag, sizeof(FSyntacticEnv), 2, 41 | "make-syntactic-environment"); 42 | if (EnvironmentP(obj)) 43 | { 44 | se->GlobalBindings = obj; 45 | se->LocalBindings = EmptyListObject; 46 | } 47 | else 48 | { 49 | se->GlobalBindings = AsSyntacticEnv(obj)->GlobalBindings; 50 | se->LocalBindings = AsSyntacticEnv(obj)->LocalBindings; 51 | } 52 | 53 | return(se); 54 | } 55 | 56 | // ---- Binding ---- 57 | 58 | FObject MakeBinding(FObject se, FObject id, FObject ra) 59 | { 60 | FAssert(SyntacticEnvP(se)); 61 | FAssert(IdentifierP(id)); 62 | FAssert(ra == TrueObject || ra == FalseObject); 63 | 64 | FBinding * b = (FBinding *) MakeObject(BindingTag, sizeof(FBinding), 10, "make-binding"); 65 | b->Identifier = id; 66 | b->Syntax = NoValueObject; 67 | b->SyntacticEnv = se; 68 | b->RestArg = ra; 69 | 70 | b->UseCount = MakeFixnum(0); 71 | b->SetCount = MakeFixnum(0); 72 | b->Escapes = FalseObject; 73 | b->Level = MakeFixnum(0); 74 | b->Slot = MakeFixnum(-1); 75 | b->Constant = NoValueObject; 76 | 77 | return(b); 78 | } 79 | 80 | // ---- Identifier ---- 81 | 82 | void WriteIdentifier(FWriteContext * wctx, FObject obj) 83 | { 84 | obj = AsIdentifier(obj)->Symbol; 85 | 86 | FAssert(SymbolP(obj)); 87 | 88 | if (StringP(AsSymbol(obj)->String)) 89 | wctx->WriteString(AsString(AsSymbol(obj)->String)->String, 90 | StringLength(AsSymbol(obj)->String)); 91 | else 92 | { 93 | FAssert(CStringP(AsSymbol(obj)->String)); 94 | 95 | wctx->WriteStringC(AsCString(AsSymbol(obj)->String)->String); 96 | } 97 | } 98 | 99 | static long_t IdentifierMagic = 0; 100 | 101 | FObject MakeIdentifier(FObject sym, FObject fn, long_t ln) 102 | { 103 | FAssert(SymbolP(sym)); 104 | 105 | FIdentifier * nid = (FIdentifier *) MakeObject(IdentifierTag, sizeof(FIdentifier), 4, 106 | "%make-identifier"); 107 | nid->Symbol = sym; 108 | nid->Filename = fn; 109 | nid->SyntacticEnv = NoValueObject; 110 | nid->Wrapped = NoValueObject; 111 | 112 | nid->LineNumber = ln; 113 | IdentifierMagic += 1; 114 | nid->Magic = IdentifierMagic; 115 | 116 | return(nid); 117 | } 118 | 119 | FObject MakeIdentifier(FObject sym) 120 | { 121 | return(MakeIdentifier(sym, NoValueObject, 0)); 122 | } 123 | 124 | FObject WrapIdentifier(FObject id, FObject se) 125 | { 126 | FAssert(IdentifierP(id)); 127 | FAssert(SyntacticEnvP(se)); 128 | 129 | FIdentifier * nid = (FIdentifier *) MakeObject(IdentifierTag, sizeof(FIdentifier), 4, 130 | "%wrap-identifier"); 131 | nid->Symbol = AsIdentifier(id)->Symbol; 132 | nid->Filename = AsIdentifier(id)->Filename; 133 | nid->SyntacticEnv = se; 134 | nid->Wrapped = id; 135 | nid->LineNumber = AsIdentifier(id)->LineNumber; 136 | nid->Magic = AsIdentifier(id)->Magic; 137 | 138 | return(nid); 139 | } 140 | 141 | // ---- Lambda ---- 142 | 143 | void WriteLambda(FWriteContext * wctx, FObject obj) 144 | { 145 | FCh s[16]; 146 | long_t sl = FixnumAsString((long_t) obj, s, 16); 147 | 148 | wctx->WriteStringC("#WriteString(s, sl); 150 | 151 | wctx->WriteCh(' '); 152 | wctx->Write(AsLambda(obj)->Name); 153 | wctx->WriteCh(' '); 154 | wctx->Write(AsLambda(obj)->Bindings); 155 | if (StringP(AsLambda(obj)->Filename) && FixnumP(AsLambda(obj)->LineNumber)) 156 | { 157 | wctx->WriteCh(' '); 158 | wctx->Display(AsLambda(obj)->Filename); 159 | wctx->WriteCh('['); 160 | wctx->Display(AsLambda(obj)->LineNumber); 161 | wctx->WriteCh(']'); 162 | } 163 | wctx->WriteStringC(">"); 164 | } 165 | 166 | FObject MakeLambda(FObject enc, FObject nam, FObject bs, FObject body) 167 | { 168 | FAssert(LambdaP(enc) || enc == NoValueObject); 169 | 170 | FLambda * l = (FLambda *) MakeObject(LambdaTag, sizeof(FLambda), 14, "make-lambda"); 171 | l->Name = nam; 172 | l->Bindings = bs; 173 | l->Body = body; 174 | 175 | l->RestArg = FalseObject; 176 | l->ArgCount = MakeFixnum(0); 177 | 178 | l->Escapes = FalseObject; 179 | l->UseStack = TrueObject; 180 | l->Level = LambdaP(enc) ? MakeFixnum(AsFixnum(AsLambda(enc)->Level) + 1) : MakeFixnum(1); 181 | l->SlotCount = MakeFixnum(-1); 182 | l->CompilerPass = NoValueObject; 183 | 184 | l->Procedure = NoValueObject; 185 | l->BodyIndex = NoValueObject; 186 | 187 | if (IdentifierP(nam)) 188 | { 189 | l->Filename = AsIdentifier(nam)->Filename; 190 | l->LineNumber = MakeFixnum(AsIdentifier(nam)->LineNumber); 191 | } 192 | else 193 | { 194 | l->Filename = NoValueObject; 195 | l->LineNumber = NoValueObject; 196 | } 197 | 198 | return(l); 199 | } 200 | 201 | // ---- CaseLambda ---- 202 | 203 | FObject MakeCaseLambda(FObject cases) 204 | { 205 | FCaseLambda * cl = (FCaseLambda *) MakeObject(CaseLambdaTag, sizeof(FCaseLambda), 3, 206 | "make-case-lambda"); 207 | cl->Cases = cases; 208 | cl->Name = NoValueObject; 209 | cl->Escapes = FalseObject; 210 | 211 | return(cl); 212 | } 213 | 214 | // ---- Reference ---- 215 | 216 | FObject MakeReference(FObject be, FObject id) 217 | { 218 | FAssert(BindingP(be) || EnvironmentP(be)); 219 | FAssert(IdentifierP(id)); 220 | 221 | FReference * r = (FReference *) MakeObject(ReferenceTag, sizeof(FReference), 2, 222 | "make-reference"); 223 | r->Binding = be; 224 | r->Identifier = id; 225 | 226 | return(r); 227 | } 228 | 229 | // ---------------- 230 | 231 | FObject CompileLambda(FObject env, FObject name, FObject formals, FObject body) 232 | { 233 | FObject obj = SPassLambda(NoValueObject, MakeSyntacticEnv(env), name, formals, body); 234 | FAssert(LambdaP(obj)); 235 | 236 | UPassLambda(AsLambda(obj), 1); 237 | CPassLambda(AsLambda(obj)); 238 | APassLambda(0, AsLambda(obj)); 239 | return(GPassLambda(AsLambda(obj))); 240 | } 241 | 242 | FObject GetInteractionEnv() 243 | { 244 | if (EnvironmentP(InteractionEnv) == 0) 245 | { 246 | InteractionEnv = MakeEnvironment(StringCToSymbol("interaction"), TrueObject); 247 | EnvironmentImportLibrary(InteractionEnv, 248 | List(StringCToSymbol("foment"), StringCToSymbol("base"))); 249 | } 250 | 251 | return(InteractionEnv); 252 | } 253 | 254 | // ---------------- 255 | 256 | Define("%compile-eval", CompileEvalPrimitive)(long_t argc, FObject argv[]) 257 | { 258 | FMustBe(argc == 2); 259 | EnvironmentArgCheck("eval", argv[1]); 260 | 261 | return(CompileEval(argv[0], argv[1])); 262 | } 263 | 264 | Define("interaction-environment", InteractionEnvironmentPrimitive)(long_t argc, FObject argv[]) 265 | { 266 | if (argc == 0) 267 | { 268 | ZeroArgsCheck("interaction-environment", argc); 269 | 270 | return(GetInteractionEnv()); 271 | } 272 | 273 | FObject env = MakeEnvironment(StringCToSymbol("interaction"), TrueObject); 274 | 275 | for (long_t adx = 0; adx < argc; adx++) 276 | { 277 | ListArgCheck("environment", argv[adx]); 278 | 279 | EnvironmentImportSet(env, argv[adx], argv[adx]); 280 | } 281 | 282 | return(env); 283 | } 284 | 285 | Define("environment", EnvironmentPrimitive)(long_t argc, FObject argv[]) 286 | { 287 | FObject env = MakeEnvironment(EmptyListObject, FalseObject); 288 | 289 | for (long_t adx = 0; adx < argc; adx++) 290 | { 291 | ListArgCheck("environment", argv[adx]); 292 | 293 | EnvironmentImportSet(env, argv[adx], argv[adx]); 294 | } 295 | 296 | EnvironmentImmutable(env); 297 | return(env); 298 | } 299 | 300 | Define("syntax", SyntaxPrimitive)(long_t argc, FObject argv[]) 301 | { 302 | OneArgCheck("syntax", argc); 303 | 304 | return(ExpandExpression(NoValueObject, MakeSyntacticEnv(GetInteractionEnv()), argv[0])); 305 | } 306 | 307 | Define("unsyntax", UnsyntaxPrimitive)(long_t argc, FObject argv[]) 308 | { 309 | OneArgCheck("unsyntax", argc); 310 | 311 | return(SyntaxToDatum(argv[0])); 312 | } 313 | 314 | static FObject Primitives[] = 315 | { 316 | CompileEvalPrimitive, 317 | InteractionEnvironmentPrimitive, 318 | EnvironmentPrimitive, 319 | SyntaxPrimitive, 320 | UnsyntaxPrimitive 321 | }; 322 | 323 | void SetupCompile() 324 | { 325 | RegisterRoot(&ElseReference, "else-reference"); 326 | RegisterRoot(&ArrowReference, "arrow-reference"); 327 | RegisterRoot(&LibraryReference, "library-reference"); 328 | RegisterRoot(&AndReference, "and-reference"); 329 | RegisterRoot(&OrReference, "or-reference"); 330 | RegisterRoot(&NotReference, "not-reference"); 331 | RegisterRoot(&QuasiquoteReference, "quasiquote-reference"); 332 | RegisterRoot(&UnquoteReference, "unquote-reference"); 333 | RegisterRoot(&UnquoteSplicingReference, "unquote-splicing-reference"); 334 | RegisterRoot(&ConsReference, "cons-reference"); 335 | RegisterRoot(&AppendReference, "append-reference"); 336 | RegisterRoot(&ListToVectorReference, "list-to-vector-reference"); 337 | RegisterRoot(&EllipsisReference, "ellipsis-reference"); 338 | RegisterRoot(&UnderscoreReference, "underscore-reference"); 339 | RegisterRoot(&InteractionEnv, "interaction-env"); 340 | 341 | ElseReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("else"))); 342 | ArrowReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("=>"))); 343 | LibraryReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("library"))); 344 | AndReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("and"))); 345 | OrReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("or"))); 346 | NotReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("not"))); 347 | QuasiquoteReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("quasiquote"))); 348 | UnquoteReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("unquote"))); 349 | UnquoteSplicingReference = MakeReference(Bedrock, 350 | MakeIdentifier(StringCToSymbol("unquote-splicing"))); 351 | ConsReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("cons"))); 352 | AppendReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("append"))); 353 | ListToVectorReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("list->vector"))); 354 | EllipsisReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("..."))); 355 | UnderscoreReference = MakeReference(Bedrock, MakeIdentifier(StringCToSymbol("_"))); 356 | 357 | TagSymbol = InternSymbol(TagSymbol); 358 | UsePassSymbol = InternSymbol(UsePassSymbol); 359 | ConstantPassSymbol = InternSymbol(ConstantPassSymbol); 360 | AnalysisPassSymbol = InternSymbol(AnalysisPassSymbol); 361 | 362 | FAssert(TagSymbol == StringCToSymbol("tag")); 363 | FAssert(UsePassSymbol == StringCToSymbol("use-pass")); 364 | FAssert(ConstantPassSymbol == StringCToSymbol("constant-pass")); 365 | FAssert(AnalysisPassSymbol == StringCToSymbol("analysis-pass")); 366 | FAssert(InteractionEnv == NoValueObject); 367 | 368 | for (ulong_t idx = 0; idx < sizeof(Primitives) / sizeof(FPrimitive *); idx++) 369 | DefinePrimitive(Bedrock, BedrockLibrary, Primitives[idx]); 370 | } 371 | -------------------------------------------------------------------------------- /src/compile.hpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #ifndef __COMPILE_HPP__ 8 | #define __COMPILE_HPP__ 9 | 10 | // ---- SyntacticEnv ---- 11 | 12 | #define AsSyntacticEnv(obj) ((FSyntacticEnv *) (obj)) 13 | #define SyntacticEnvP(obj) (ObjectTag(obj) == SyntacticEnvTag) 14 | 15 | typedef struct 16 | { 17 | FObject GlobalBindings; 18 | FObject LocalBindings; 19 | } FSyntacticEnv; 20 | 21 | FObject MakeSyntacticEnv(FObject obj); 22 | 23 | // ---- Binding ---- 24 | 25 | #define AsBinding(obj) ((FBinding *) (obj)) 26 | #define BindingP(obj) (ObjectTag(obj) == BindingTag) 27 | 28 | typedef struct 29 | { 30 | FObject Identifier; 31 | FObject Syntax; 32 | FObject SyntacticEnv; 33 | FObject RestArg; 34 | 35 | FObject UseCount; 36 | FObject SetCount; 37 | FObject Escapes; 38 | FObject Level; 39 | FObject Slot; 40 | FObject Constant; 41 | } FBinding; 42 | 43 | FObject MakeBinding(FObject se, FObject id, FObject ra); 44 | 45 | // ---- Reference ---- 46 | 47 | #define AsReference(obj) ((FReference *) (obj)) 48 | #define ReferenceP(obj) (ObjectTag(obj) == ReferenceTag) 49 | 50 | typedef struct 51 | { 52 | FObject Binding; 53 | FObject Identifier; 54 | } FReference; 55 | 56 | FObject MakeReference(FObject be, FObject id); 57 | 58 | // ---- Lambda ---- 59 | 60 | #define AsLambda(obj) ((FLambda *) (obj)) 61 | #define LambdaP(obj) (ObjectTag(obj) == LambdaTag) 62 | 63 | typedef struct 64 | { 65 | FObject Name; 66 | FObject Bindings; 67 | FObject Body; 68 | 69 | FObject RestArg; 70 | FObject ArgCount; 71 | 72 | FObject Escapes; 73 | FObject UseStack; // Use a stack frame; otherwise, use a heap frame. 74 | FObject Level; 75 | FObject SlotCount; 76 | FObject CompilerPass; 77 | 78 | FObject Procedure; 79 | FObject BodyIndex; 80 | 81 | FObject Filename; 82 | FObject LineNumber; 83 | } FLambda; 84 | 85 | FObject MakeLambda(FObject enc, FObject nam, FObject bs, FObject body); 86 | 87 | // ---- CaseLambda ---- 88 | 89 | #define AsCaseLambda(obj) ((FCaseLambda *) (obj)) 90 | #define CaseLambdaP(obj) (ObjectTag(obj) == CaseLambdaTag) 91 | 92 | typedef struct 93 | { 94 | FObject Cases; 95 | FObject Name; 96 | FObject Escapes; 97 | } FCaseLambda; 98 | 99 | FObject MakeCaseLambda(FObject cases); 100 | 101 | // ---------------- 102 | 103 | FObject ResolveIdentifier(FObject se, FObject id); 104 | 105 | FObject CompileLambda(FObject env, FObject name, FObject formals, FObject body); 106 | 107 | FObject CompileSyntaxRules(FObject se, FObject obj); 108 | FObject ExpandSyntaxRules(FObject se, FObject sr, FObject expr); 109 | 110 | long_t MatchReference(FObject ref, FObject se, FObject expr); 111 | FObject ExpandExpression(FObject enc, FObject se, FObject expr); 112 | FObject CondExpand(FObject se, FObject expr, FObject clst); 113 | FObject ReadInclude(FObject op, FObject lst, long_t cif); 114 | FObject SPassLambda(FObject enc, FObject se, FObject name, FObject formals, FObject body); 115 | void UPassLambda(FLambda * lam, int ef); 116 | void CPassLambda(FLambda * lam); 117 | void APassLambda(FLambda * enc, FLambda * lam); 118 | FObject GPassLambda(FLambda * lam); 119 | 120 | // ---- Roots ---- 121 | 122 | extern FObject ElseReference; 123 | extern FObject ArrowReference; 124 | extern FObject LibraryReference; 125 | extern FObject AndReference; 126 | extern FObject OrReference; 127 | extern FObject NotReference; 128 | extern FObject QuasiquoteReference; 129 | extern FObject UnquoteReference; 130 | extern FObject UnquoteSplicingReference; 131 | extern FObject ConsReference; 132 | extern FObject AppendReference; 133 | extern FObject ListToVectorReference; 134 | extern FObject EllipsisReference; 135 | extern FObject UnderscoreReference; 136 | 137 | // ---- Eternal Objects ---- 138 | 139 | extern FObject TagSymbol; 140 | extern FObject UsePassSymbol; 141 | extern FObject ConstantPassSymbol; 142 | extern FObject AnalysisPassSymbol; 143 | 144 | // ---------------- 145 | 146 | FObject FindOrLoadLibrary(FObject nam); 147 | FObject LibraryName(FObject lst); 148 | void CompileLibrary(FObject expr); 149 | FObject CompileEval(FObject obj, FObject env); 150 | 151 | #endif // __COMPILE_HPP__ 152 | -------------------------------------------------------------------------------- /src/execute.hpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #ifndef __EXECUTE_HPP__ 8 | #define __EXECUTE_HPP__ 9 | 10 | // ---- Instruction ---- 11 | 12 | #define MakeInstruction(op, arg)\ 13 | MakeImmediate(((((long_t) (arg)) << 8) | (op & 0xFF)), InstructionTag) 14 | #define InstructionOpcode(obj) ((FOpcode) (AsValue(obj) & 0xFF)) 15 | #define InstructionArg(obj) ((long_t) (AsValue(obj) >> 8)) 16 | 17 | /* 18 | Each instruction consists of . The is a Fixnum. 19 | 20 | The virtual machine state consists of an AStack (and an AStackPtr); a CStack and (a CStackPtr); 21 | a Frame, an ArgCount, an IP, and a Proc. The Frame is optionally a vector on the heap. 22 | The IP (instruction pointer) is an index into the Proc's (procedure) code vector. 23 | */ 24 | 25 | typedef enum 26 | { 27 | // Opcodes generated by the compiler. 28 | 29 | CheckCountOpcode = 0, 30 | RestArgOpcode, 31 | MakeListOpcode, 32 | PushCStackOpcode, 33 | PushNoValueOpcode, 34 | PushWantValuesOpcode, 35 | PopCStackOpcode, 36 | SaveFrameOpcode, 37 | RestoreFrameOpcode, 38 | MakeFrameOpcode, 39 | PushFrameOpcode, 40 | GetCStackOpcode, 41 | SetCStackOpcode, 42 | GetFrameOpcode, 43 | SetFrameOpcode, 44 | GetVectorOpcode, 45 | SetVectorOpcode, 46 | GetGlobalOpcode, 47 | SetGlobalOpcode, 48 | MakeBoxOpcode, 49 | GetBoxOpcode, 50 | SetBoxOpcode, 51 | DiscardResultOpcode, // Multiple values interacts with this opcode; use PopAStackOpcode instead 52 | PopAStackOpcode, 53 | DuplicateOpcode, 54 | ReturnOpcode, 55 | CallOpcode, 56 | CallProcOpcode, 57 | CallPrimOpcode, 58 | TailCallOpcode, 59 | TailCallProcOpcode, 60 | TailCallPrimOpcode, 61 | SetArgCountOpcode, 62 | MakeClosureOpcode, 63 | IfFalseOpcode, 64 | IfEqvPOpcode, 65 | GotoRelativeOpcode, 66 | GotoAbsoluteOpcode, 67 | CheckValuesOpcode, 68 | RestValuesOpcode, 69 | 70 | // Special opcodes not generated by the compiler. 71 | 72 | ValuesOpcode, 73 | ApplyOpcode, 74 | CaseLambdaOpcode, 75 | CaptureContinuationOpcode, 76 | CallContinuationOpcode, 77 | AbortOpcode, 78 | ReturnFromOpcode, 79 | MarkContinuationOpcode, 80 | PopDynamicStackOpcode 81 | } FOpcode; 82 | 83 | #endif // __EXECUTE_HPP__ 84 | -------------------------------------------------------------------------------- /src/foment.hpp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leftmike/foment/6089c3c9e762875f619ef382d27943819bbe002b/src/foment.hpp -------------------------------------------------------------------------------- /src/genprops.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Generate buildprops.cpp based on buildprops.out 4 | 5 | */ 6 | 7 | #include 8 | #include 9 | 10 | const char * props[] = 11 | { 12 | #ifdef FOMENT_WINDOWS 13 | "build.branch", 14 | "build.commit", 15 | "build.platform", 16 | 0, 17 | "c.version" 18 | #else // FOMENT_WINDOWS 19 | "build.branch", 20 | "build.commit", 21 | "build.platform", 22 | "c.version" 23 | #endif // FOMENT_WINDOWS 24 | }; 25 | 26 | int main(int argc, char * argv[]) 27 | { 28 | char buf[256]; 29 | 30 | printf("// Do not modify; generated file\n\n"); 31 | // Size must match BuildProperties in src/main.cpp 32 | printf("const char * BuildProperties[4] =\n{\n"); 33 | for (unsigned int idx = 0; idx < sizeof(props) / sizeof(char *); idx += 1) 34 | { 35 | fgets(buf, sizeof(buf), stdin); 36 | if (props[idx] == 0) 37 | continue; 38 | 39 | if (strlen(buf) == 0) 40 | return(1); 41 | 42 | buf[strlen(buf)-1] = 0; 43 | if (idx > 0) 44 | printf(",\n"); 45 | printf(" \"(%s \\\"%s\\\")\"", props[idx], buf); 46 | } 47 | printf("\n};\n"); 48 | 49 | return(0); 50 | } 51 | 52 | -------------------------------------------------------------------------------- /src/io.hpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #ifndef __IO_HPP__ 8 | #define __IO_HPP__ 9 | 10 | // ---- Binary Ports ---- 11 | 12 | typedef ulong_t (*FReadBytesFn)(FObject port, void * b, ulong_t bl); 13 | typedef long_t (*FByteReadyPFn)(FObject port); 14 | typedef void (*FWriteBytesFn)(FObject port, void * b, ulong_t bl); 15 | 16 | typedef struct 17 | { 18 | FGenericPort Generic; 19 | FReadBytesFn ReadBytesFn; 20 | FByteReadyPFn ByteReadyPFn; 21 | FWriteBytesFn WriteBytesFn; 22 | ulong_t PeekedByte; 23 | ulong_t Offset; 24 | } FBinaryPort; 25 | 26 | #define AsBinaryPort(obj) ((FBinaryPort *) obj) 27 | 28 | FObject MakeBinaryPort(FObject nam, FObject obj, void * ctx, FCloseInputFn cifn, 29 | FCloseOutputFn cofn, FFlushOutputFn fofn, FReadBytesFn rbfn, FByteReadyPFn brpfn, 30 | FWriteBytesFn wbfn, FGetPositionFn gpfn, FSetPositionFn spfn, 31 | FGetFileHandleFn gfhfn, ulong_t flgs); 32 | 33 | // ---- Textual Ports ---- 34 | 35 | typedef ulong_t (*FReadChFn)(FObject port, FCh * ch); 36 | typedef long_t (*FCharReadyPFn)(FObject port); 37 | typedef void (*FWriteStringFn)(FObject port, FCh * s, ulong_t sl); 38 | 39 | typedef struct 40 | { 41 | FGenericPort Generic; 42 | FReadChFn ReadChFn; 43 | FCharReadyPFn CharReadyPFn; 44 | FWriteStringFn WriteStringFn; 45 | ulong_t PeekedChar; 46 | ulong_t Line; 47 | ulong_t Column; 48 | } FTextualPort; 49 | 50 | #define AsTextualPort(obj) ((FTextualPort *) obj) 51 | 52 | FObject MakeTextualPort(FObject nam, FObject obj, void * ctx, FCloseInputFn cifn, 53 | FCloseOutputFn cofn, FFlushOutputFn fofn, FReadChFn rcfn, FCharReadyPFn crpfn, 54 | FWriteStringFn wsfn, FGetPositionFn gpfn, FSetPositionFn spfn, FGetFileHandleFn gfhfn, 55 | ulong_t flgs); 56 | 57 | inline FObject CurrentInputPort() 58 | { 59 | FObject port = Parameter(PARAMETER_CURRENT_INPUT_PORT); 60 | 61 | FAssert(InputPortP(port) && InputPortOpenP(port)); 62 | 63 | return(port); 64 | } 65 | 66 | inline FObject CurrentOutputPort() 67 | { 68 | FObject port = Parameter(PARAMETER_CURRENT_OUTPUT_PORT); 69 | 70 | FAssert(OutputPortP(port) && OutputPortOpenP(port)); 71 | 72 | return(port); 73 | } 74 | 75 | FObject OpenInputPipe(FFileHandle fh); 76 | FObject OpenOutputPipe(FFileHandle fh); 77 | 78 | // ---------------- 79 | 80 | void SetupWrite(); 81 | void SetupRead(); 82 | long_t IdentifierSubsequentP(FCh ch); 83 | 84 | #ifdef FOMENT_UNIX 85 | void SetupConsoleAgain(); 86 | void RestoreConsole(); 87 | #endif // FOMENT_UNIX 88 | 89 | #endif // __IO_HPP__ 90 | -------------------------------------------------------------------------------- /src/license.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, 2014 Michael Montague 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /src/random.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #include 8 | #include "foment.hpp" 9 | 10 | #define AsRandomSource(obj) ((FRandomSource *) (obj)) 11 | #define RandomSourceP(obj) (ObjectTag(obj) == RandomSourceTag) 12 | 13 | typedef struct 14 | { 15 | std::mt19937_64 Engine; 16 | } FRandomSource; 17 | 18 | static FObject MakeRandomSource() 19 | { 20 | std::mt19937_64 seed(RandomSeed); 21 | FRandomSource * rs = (FRandomSource *) MakeObject(RandomSourceTag, sizeof(FRandomSource), 0, 22 | "make-random-source"); 23 | rs->Engine = seed; 24 | return(rs); 25 | } 26 | 27 | void WriteRandomSource(FWriteContext * wctx, FObject obj) 28 | { 29 | FAssert(RandomSourceP(obj)); 30 | 31 | wctx->WriteStringC("#Engine, s, 16); 35 | wctx->WriteString(s, sl); 36 | wctx->WriteCh('>'); 37 | } 38 | 39 | inline void RandomSourceArgCheck(const char * who, FObject arg) 40 | { 41 | if (RandomSourceP(arg) == 0) 42 | RaiseExceptionC(Assertion, who, "expected a random source", List(arg)); 43 | } 44 | 45 | Define("random-source?", RandomSourcePPrimitive)(long_t argc, FObject argv[]) 46 | { 47 | OneArgCheck("random-source?", argc); 48 | 49 | return(RandomSourceP(argv[0]) ? TrueObject : FalseObject); 50 | } 51 | 52 | Define("make-random-source", MakeRandomSourcePrimitive)(long_t argc, FObject argv[]) 53 | { 54 | ZeroArgsCheck("make-random-source", argc); 55 | 56 | return(MakeRandomSource()); 57 | } 58 | 59 | // (%random-integer rs n) 60 | Define("%random-integer", RandomIntegerPrimitive)(long_t argc, FObject argv[]) 61 | { 62 | TwoArgsCheck("%random-integer", argc); 63 | RandomSourceArgCheck("%random-integer", argv[0]); 64 | if (FixnumP(argv[1]) == 0 || AsFixnum(argv[1]) <= 0) 65 | RaiseExceptionC(Assertion, "%random-integer", "expected a positive fixnum", List(argv[1])); 66 | 67 | std::uniform_int_distribution dist(0, AsFixnum(argv[1]) - 1); 68 | return(MakeFixnum(dist(AsRandomSource(argv[0])->Engine))); 69 | } 70 | 71 | // (%random-real rs) 72 | Define("%random-real", RandomRealPrimitive)(long_t argc, FObject argv[]) 73 | { 74 | OneArgCheck("%random-real", argc); 75 | RandomSourceArgCheck("%random-real", argv[0]); 76 | 77 | std::uniform_real_distribution dist(0.0, 1.0); 78 | return(MakeFlonum(dist(AsRandomSource(argv[0])->Engine))); 79 | } 80 | 81 | // (random-source-state-ref rs) -> state 82 | Define("random-source-state-ref", RandomSourceStateRefPrimitive)(long_t argc, FObject argv[]) 83 | { 84 | OneArgCheck("random-source-state-ref", argc); 85 | RandomSourceArgCheck("random-source-state-ref", argv[0]); 86 | 87 | FObject rs = MakeRandomSource(); 88 | AsRandomSource(rs)->Engine = AsRandomSource(argv[0])->Engine; 89 | return(rs); 90 | } 91 | 92 | // (random-source-state-set! rs state) 93 | Define("random-source-state-set!", RandomSourceStateSetPrimitive)(long_t argc, FObject argv[]) 94 | { 95 | TwoArgsCheck("random-source-state-set!", argc); 96 | RandomSourceArgCheck("random-source-state-set!", argv[0]); 97 | RandomSourceArgCheck("random-source-state-set!", argv[1]); 98 | 99 | AsRandomSource(argv[0])->Engine = AsRandomSource(argv[1])->Engine; 100 | return(NoValueObject); 101 | } 102 | 103 | // (random-source-randomize! rs) 104 | Define("random-source-randomize!", RandomSourceRandomizePrimitive)(long_t argc, FObject argv[]) 105 | { 106 | OneArgCheck("random-source-randomize!", argc); 107 | RandomSourceArgCheck("random-source-randomize!", argv[0]); 108 | 109 | std::random_device rd; 110 | std::mt19937_64 seed(rd()); 111 | AsRandomSource(argv[0])->Engine = seed; 112 | return(NoValueObject); 113 | } 114 | 115 | // (random-source-pseudo-randomize! rs i j) 116 | Define("random-source-pseudo-randomize!", 117 | RandomSourcePseudoRandomizePrimitive)(long_t argc, FObject argv[]) 118 | { 119 | ThreeArgsCheck("random-source-pseudo-randomize!", argc); 120 | RandomSourceArgCheck("random-source-pseudo-randomize!", argv[0]); 121 | NonNegativeArgCheck("random-source-pseudo-randomize!", argv[1], 0); 122 | NonNegativeArgCheck("random-source-pseudo-randomize!", argv[2], 0); 123 | 124 | uint64_t i = AsFixnum(argv[1]); 125 | uint64_t j = AsFixnum(argv[2]); 126 | std::mt19937_64 seed((i << 32) | (j & 0xFFFFFFFF)); 127 | AsRandomSource(argv[0])->Engine = seed; 128 | return(NoValueObject); 129 | } 130 | 131 | static FObject Primitives[] = 132 | { 133 | RandomSourcePPrimitive, 134 | MakeRandomSourcePrimitive, 135 | RandomIntegerPrimitive, 136 | RandomRealPrimitive, 137 | RandomSourceStateRefPrimitive, 138 | RandomSourceStateSetPrimitive, 139 | RandomSourceRandomizePrimitive, 140 | RandomSourcePseudoRandomizePrimitive, 141 | }; 142 | 143 | void SetupRandom() 144 | { 145 | for (ulong_t idx = 0; idx < sizeof(Primitives) / sizeof(FPrimitive *); idx++) 146 | DefinePrimitive(Bedrock, BedrockLibrary, Primitives[idx]); 147 | } 148 | -------------------------------------------------------------------------------- /src/srfi-106.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 106) 2 | (import (foment base)) 3 | (export 4 | make-client-socket 5 | make-server-socket 6 | socket? 7 | (rename accept-socket socket-accept) 8 | socket-send 9 | socket-recv 10 | (rename shutdown-socket socket-shutdown) 11 | socket-input-port 12 | socket-output-port 13 | call-with-socket 14 | address-family 15 | address-info 16 | socket-domain 17 | ip-protocol 18 | message-type 19 | shutdown-method 20 | socket-merge-flags 21 | socket-purge-flags 22 | *af-unspec* 23 | *af-inet* 24 | *af-inet6* 25 | *sock-stream* 26 | *sock-dgram* 27 | *ai-canonname* 28 | *ai-numerichost* 29 | *ai-v4mapped* 30 | *ai-all* 31 | *ai-addrconfig* 32 | *ipproto-ip* 33 | *ipproto-tcp* 34 | *ipproto-udp* 35 | *msg-peek* 36 | *msg-oob* 37 | *msg-waitall* 38 | *shut-rd* 39 | *shut-wr* 40 | *shut-rdwr*) 41 | (begin 42 | (define make-client-socket 43 | (case-lambda 44 | ((node svc) 45 | (make-client-socket node svc *af-inet* *sock-stream* 46 | (socket-merge-flags *ai-v4mapped* *ai-addrconfig*) *ipproto-ip*)) 47 | ((node svc fam) 48 | (make-client-socket node svc fam *sock-stream* 49 | (socket-merge-flags *ai-v4mapped* *ai-addrconfig*) *ipproto-ip*)) 50 | ((node svc fam type) 51 | (make-client-socket node svc fam type 52 | (socket-merge-flags *ai-v4mapped* *ai-addrconfig*) *ipproto-ip*)) 53 | ((node svc fam type flags) 54 | (make-client-socket node svc fam type flags *ipproto-ip*)) 55 | ((node svc fam type flags prot) 56 | (let ((s (make-socket fam type prot))) 57 | (connect-socket s node svc fam type flags prot) 58 | s)))) 59 | 60 | (define make-server-socket 61 | (case-lambda 62 | ((svc) (make-server-socket svc *af-inet* *sock-stream* *ipproto-ip*)) 63 | ((svc fam) (make-server-socket svc fam *sock-stream* *ipproto-ip*)) 64 | ((svc fam type) (make-server-socket svc fam type *ipproto-ip*)) 65 | ((svc fam type prot) 66 | (let ((s (make-socket fam type prot))) 67 | (bind-socket s "" svc fam type prot) 68 | (listen-socket s) 69 | s)))) 70 | 71 | (define socket-send 72 | (case-lambda 73 | ((socket bv) (send-socket socket bv 0)) 74 | ((socket bv flags) (send-socket socket bv flags)))) 75 | 76 | (define socket-recv 77 | (case-lambda 78 | ((socket size) (recv-socket socket size 0)) 79 | ((socket size flags) (recv-socket socket size flags)))) 80 | 81 | (define (socket-close socket) (close-port socket)) 82 | 83 | (define (socket-input-port socket) socket) 84 | 85 | (define (socket-output-port socket) socket) 86 | 87 | (define (call-with-socket socket proc) 88 | (let-values ((results (proc socket))) 89 | (close-port socket) 90 | (apply values results))) 91 | )) 92 | -------------------------------------------------------------------------------- /src/srfi-133.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme vector) 2 | (aka (srfi 133)) 3 | (import (foment base)) 4 | (export 5 | make-vector 6 | vector 7 | vector-unfold 8 | vector-unfold-right 9 | vector-copy 10 | vector-reverse-copy 11 | vector-append 12 | vector-concatenate 13 | vector-append-subvectors 14 | vector? 15 | vector-empty? 16 | vector= 17 | vector-ref 18 | vector-length 19 | vector-fold 20 | vector-fold-right 21 | vector-map 22 | vector-map! 23 | vector-for-each 24 | vector-count 25 | vector-cumulate 26 | vector-index 27 | vector-index-right 28 | vector-skip 29 | vector-skip-right 30 | vector-binary-search 31 | vector-any 32 | vector-every 33 | vector-partition 34 | vector-set! 35 | vector-swap! 36 | vector-fill! 37 | vector-reverse! 38 | vector-copy! 39 | vector-reverse-copy! 40 | vector-unfold! 41 | vector-unfold-right! 42 | vector->list 43 | reverse-vector->list 44 | list->vector 45 | reverse-list->vector 46 | vector->string 47 | string->vector 48 | ) 49 | (begin 50 | (define (vector-concatenate vector-list) 51 | (apply vector-append vector-list)) 52 | (define (vector-empty? vec) 53 | (= (vector-length vec) 0)) 54 | (define (vector= elt=? . vectors) 55 | (define (length= len vectors) 56 | (or (null? vectors) 57 | (and (= len (vector-length (car vectors))) 58 | (length= len (cdr vectors))))) 59 | (define (vector-2= idx vec1 vec2) 60 | (or (= idx (vector-length vec1)) 61 | (and (elt=? (vector-ref vec1 idx) (vector-ref vec2 idx)) 62 | (vector-2= (+ idx 1) vec1 vec2)))) 63 | (define (vector-list= vec vectors) 64 | (or (null? vectors) 65 | (and (vector-2= 0 vec (car vectors)) 66 | (vector-list= (car vectors) (cdr vectors))))) 67 | (or (null? vectors) (null? (cdr vectors)) 68 | (and (length= (vector-length (car vectors)) (cdr vectors)) 69 | (vector-list= (car vectors) (cdr vectors))))) 70 | (define (fold step state idx next done vectors) 71 | (if (done idx) 72 | state 73 | (let ((state (apply step state (map (lambda (vec) (vector-ref vec idx)) vectors)))) 74 | (fold step state (next idx 1) next done vectors)))) 75 | (define (fold-left step start vectors) 76 | (let ((len (apply min (map vector-length vectors)))) 77 | (fold step start 0 + (lambda (idx) (= idx len)) vectors))) 78 | (define (vector-fold step start . vectors) 79 | (if (null? vectors) 80 | start 81 | (fold-left step start vectors))) 82 | (define (vector-fold-right step start . vectors) 83 | (if (null? vectors) 84 | start 85 | (let ((len (apply min (map vector-length vectors)))) 86 | (fold step start (- len 1) - (lambda (idx) (< idx 0)) vectors)))) 87 | (define (vector-map! proc vec . vectors) 88 | (let* ((vectors (cons vec vectors)) 89 | (len (apply min (map vector-length vectors)))) 90 | (define (map-vectors idx) 91 | (if (< idx len) 92 | (let ((val (apply proc (map (lambda (v) (vector-ref v idx)) vectors)))) 93 | (vector-set! vec idx val) 94 | (map-vectors (+ idx 1))))) 95 | (map-vectors 0))) 96 | (define (vector-count pred? vec . vectors) 97 | (fold-left (lambda (count . elts) (if (apply pred? elts) (+ count 1) count)) 0 98 | (cons vec vectors))) 99 | (define (vector-cumulate f start vec) 100 | (let* ((len (vector-length vec)) 101 | (ret (make-vector len))) 102 | (define (cumulate idx prev) 103 | (if (= idx len) 104 | ret 105 | (let ((val (f prev (vector-ref vec idx)))) 106 | (vector-set! ret idx val) 107 | (cumulate (+ idx 1) val)))) 108 | (cumulate 0 start))) 109 | (define (index pred? idx next done vectors) 110 | (if (done idx) 111 | #f 112 | (if (apply pred? (map (lambda (vec) (vector-ref vec idx)) vectors)) 113 | idx 114 | (index pred? (next idx 1) next done vectors)))) 115 | (define (vector-index pred? vec . vectors) 116 | (let* ((vectors (cons vec vectors)) 117 | (len (apply min (map vector-length vectors)))) 118 | (index pred? 0 + (lambda (idx) (= idx len)) vectors))) 119 | (define (vector-index-right pred? vec . vectors) 120 | (let* ((vectors (cons vec vectors)) 121 | (len (apply min (map vector-length vectors)))) 122 | (index pred? (- len 1) - (lambda (idx) (< idx 0)) vectors))) 123 | (define (vector-skip pred? vec . vectors) 124 | (let* ((vectors (cons vec vectors)) 125 | (len (apply min (map vector-length vectors)))) 126 | (index (lambda elts (not (apply pred? elts))) 0 + (lambda (idx) (= idx len)) 127 | vectors))) 128 | (define (vector-skip-right pred? vec . vectors) 129 | (let* ((vectors (cons vec vectors)) 130 | (len (apply min (map vector-length vectors)))) 131 | (index (lambda elts (not (apply pred? elts))) (- len 1) - 132 | (lambda (idx) (< idx 0)) vectors))) 133 | (define (vector-binary-search vec val cmp) 134 | (define (binary-search start end) 135 | (if (> 2 (- end start)) 136 | #f 137 | (let* ((idx (+ start (truncate-quotient (- end start) 2))) 138 | (ret (cmp (vector-ref vec idx) val))) 139 | (cond 140 | ((< ret 0) (binary-search idx end)) 141 | ((= ret 0) idx) 142 | ((> ret 0) (binary-search start idx)))))) 143 | (binary-search -1 (vector-length vec))) 144 | (define (vector-any pred? vec . vectors) 145 | (let* ((vectors (cons vec vectors)) 146 | (len (apply min (map vector-length vectors)))) 147 | (define (any idx) 148 | (if (= idx len) 149 | #f 150 | (let ((ret (apply pred? (map (lambda (vec) (vector-ref vec idx)) vectors)))) 151 | (if ret 152 | ret 153 | (any (+ idx 1)))))) 154 | (any 0))) 155 | (define (vector-every pred? vec . vectors) 156 | (let* ((vectors (cons vec vectors)) 157 | (len (apply min (map vector-length vectors)))) 158 | (define (every idx ret) 159 | (if (= idx len) 160 | ret 161 | (let ((ret (apply pred? (map (lambda (vec) (vector-ref vec idx)) vectors)))) 162 | (if ret 163 | (every (+ idx 1) ret) 164 | #f)))) 165 | (every 0 #f))) 166 | (define (vector-partition pred? vec) 167 | (let* ((len (vector-length vec)) 168 | (cnt (vector-count pred? vec)) 169 | (ret (make-vector len))) 170 | (define (partition idx yes no) 171 | (if (= idx len) 172 | (values ret cnt) 173 | (let ((elt (vector-ref vec idx))) 174 | (cond 175 | ((pred? elt) 176 | (vector-set! ret yes elt) 177 | (partition (+ idx 1) (+ yes 1) no)) 178 | (else 179 | (vector-set! ret no elt) 180 | (partition (+ idx 1) yes (+ no 1))))))) 181 | (partition 0 0 cnt))) 182 | (define (vector-unfold f len . seeds) 183 | (let ((vec (make-vector len))) 184 | (apply vector-unfold! f vec 0 len seeds) 185 | vec)) 186 | (define (vector-unfold! f vec start end . seeds) 187 | (define (unfold idx seeds) 188 | (if (< idx end) 189 | (let-values (((val . seeds) (apply f idx seeds))) 190 | (vector-set! vec idx val) 191 | (unfold (+ idx 1) seeds)))) 192 | (unfold start seeds)) 193 | (define (vector-unfold-right f len . seeds) 194 | (let ((vec (make-vector len))) 195 | (apply vector-unfold-right! f vec 0 len seeds) 196 | vec)) 197 | (define (vector-unfold-right! f vec start end . seeds) 198 | (define (unfold idx seeds) 199 | (if (>= idx start) 200 | (let-values (((val . seeds) (apply f idx seeds))) 201 | (vector-set! vec idx val) 202 | (unfold (- idx 1) seeds)))) 203 | (unfold (- end 1) seeds)) 204 | (define (reverse-vector->list vec . args) 205 | (reverse (apply vector->list vec args))) 206 | (define (reverse-list->vector lst) 207 | (let ((vec (list->vector lst))) 208 | (vector-reverse! vec) 209 | vec)) 210 | )) 211 | -------------------------------------------------------------------------------- /src/srfi-14.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme charset) 2 | (aka (srfi 14)) 3 | (import (foment base)) 4 | (export 5 | char-set? 6 | char-set= 7 | char-set<= 8 | char-set-hash 9 | char-set-cursor 10 | char-set-ref 11 | char-set-cursor-next 12 | end-of-char-set? 13 | char-set-fold 14 | char-set-unfold 15 | char-set-unfold! 16 | char-set-for-each 17 | char-set-map 18 | char-set-copy 19 | char-set 20 | list->char-set 21 | string->char-set 22 | list->char-set! 23 | string->char-set! 24 | char-set-filter 25 | char-set-filter! 26 | ucs-range->char-set 27 | ucs-range->char-set! 28 | ->char-set 29 | char-set-size 30 | char-set-count 31 | char-set->list 32 | char-set->string 33 | char-set-contains? 34 | char-set-every 35 | char-set-any 36 | char-set-adjoin 37 | char-set-delete 38 | (rename char-set-adjoin char-set-adjoin!) 39 | (rename char-set-delete char-set-delete!) 40 | char-set-complement 41 | (rename char-set-complement char-set-complement!) 42 | char-set-union 43 | char-set-union! 44 | char-set-intersection 45 | char-set-intersection! 46 | char-set-difference 47 | (rename char-set-difference char-set-difference!) 48 | char-set-xor 49 | char-set-xor! 50 | char-set-diff+intersection 51 | char-set-diff+intersection! 52 | char-set:lower-case 53 | char-set:upper-case 54 | char-set:title-case 55 | char-set:letter 56 | char-set:digit 57 | char-set:letter+digit 58 | char-set:graphic 59 | char-set:printing 60 | char-set:whitespace 61 | char-set:iso-control 62 | char-set:punctuation 63 | char-set:symbol 64 | char-set:hex-digit 65 | char-set:blank 66 | char-set:ascii 67 | char-set:empty 68 | char-set:full 69 | ) 70 | (begin 71 | (define (char-set-ref cset cursor) 72 | cursor) 73 | (define (end-of-char-set? cursor) 74 | (not (char? cursor))) 75 | (define (char-set-fold proc seed cset) 76 | (define (fold cursor seed) 77 | (if (end-of-char-set? cursor) 78 | seed 79 | (let ((ch (char-set-ref cset cursor))) 80 | (fold (char-set-cursor-next cset cursor) (proc ch seed))))) 81 | (fold (char-set-cursor cset) seed)) 82 | (define char-set-unfold 83 | (case-lambda 84 | ((to-char pred gen seed) (char-set-unfold! to-char pred gen seed (char-set))) 85 | ((to-char pred gen seed base) (char-set-unfold! to-char pred gen seed base)))) 86 | (define (char-set-unfold! to-char pred gen seed base) 87 | (define (unfold seed lst) 88 | (if (pred seed) 89 | lst 90 | (unfold (gen seed) (cons (to-char seed) lst)))) 91 | (list->char-set (unfold seed '()) base)) 92 | (define (char-set-for-each proc cset) 93 | (for-each proc (char-set-fold cons '() cset))) 94 | (define (char-set-map proc cset) 95 | (list->char-set (map proc (char-set-fold cons '() cset)))) 96 | (define (char-set-copy cset) 97 | cset) 98 | (define (char-set . char-list) 99 | (list->char-set char-list)) 100 | (define (list->char-set! char-list cset) 101 | (list->char-set char-list cset)) 102 | (define (string->char-set! char-list cset) 103 | (string->char-set char-list cset)) 104 | (define char-set-filter 105 | (case-lambda 106 | ((pred cset) (char-set-filter! pred cset (char-set))) 107 | ((pred cset base) (char-set-filter! pred cset base)))) 108 | (define (char-set-filter! pred cset base) 109 | (list->char-set 110 | (char-set-fold (lambda (ch lst) (if (pred ch) (cons ch lst) lst)) '() cset) 111 | base)) 112 | (define (->char-set obj) 113 | (cond 114 | ((string? obj) (string->char-set obj)) 115 | ((char? obj) (char-set obj)) 116 | ((char-set? obj) obj) 117 | (else (full-error 'assertion-violation '->char-set #f 118 | "->char-set: expected a character, string, or char-set" obj)))) 119 | (define (ucs-range->char-set! lower upper error? base) 120 | (ucs-range->char-set lower upper error? base)) 121 | (define (char-set-size cset) 122 | (char-set-fold (lambda (ch cnt) (+ cnt 1)) 0 cset)) 123 | (define (char-set-count pred cset) 124 | (char-set-fold (lambda (ch cnt) (if (pred ch) (+ cnt 1) cnt)) 0 cset)) 125 | (define (char-set->list cset) 126 | (char-set-fold (lambda (ch lst) (cons ch lst)) '() cset)) 127 | (define (char-set->string cset) 128 | (list->string (char-set->list cset))) 129 | (define (char-set-every pred cset) 130 | (define (every cursor) 131 | (if (end-of-char-set? cursor) 132 | #t 133 | (if (pred (char-set-ref cset cursor)) 134 | (every (char-set-cursor-next cset cursor)) 135 | #f))) 136 | (every (char-set-cursor cset))) 137 | (define (char-set-any pred cset) 138 | (define (any cursor) 139 | (if (end-of-char-set? cursor) 140 | #f 141 | (or 142 | (pred (char-set-ref cset cursor)) 143 | (any (char-set-cursor-next cset cursor))))) 144 | (any (char-set-cursor cset))) 145 | (define (char-set-adjoin cset . chars) 146 | (list->char-set chars cset)) 147 | (define (char-set-delete cset . chars) 148 | (let ((delete (list->char-set chars))) 149 | (char-set-filter (lambda (ch) (not (char-set-contains? delete ch))) cset))) 150 | (define (char-set-union! cset . csets) 151 | (apply char-set-union cset csets)) 152 | (define char-set-intersection 153 | (case-lambda 154 | (() char-set:full) 155 | ((cset) cset) 156 | ((cset1 cset2) (%char-set-intersection cset1 cset2)) 157 | ((cset . csets) (%char-set-intersection cset (apply char-set-union csets))))) 158 | (define char-set-intersection! 159 | (case-lambda 160 | ((cset) cset) 161 | ((cset1 cset2) (%char-set-intersection cset1 cset2)) 162 | ((cset . csets) (%char-set-intersection cset (apply char-set-union csets))))) 163 | (define char-set-difference 164 | (case-lambda 165 | ((cset) cset) 166 | ((cset1 cset2) (%char-set-intersection cset1 (char-set-complement cset2))) 167 | ((cset . csets) 168 | (%char-set-intersection cset 169 | (char-set-complement (apply char-set-union csets)))))) 170 | (define (%char-set-xor cset csets) 171 | (if (null? csets) 172 | cset 173 | (%char-set-xor 174 | (char-set-union 175 | (%char-set-intersection cset (char-set-complement (car csets))) 176 | (%char-set-intersection (car csets) (char-set-complement cset))) 177 | (cdr csets)))) 178 | (define char-set-xor 179 | (case-lambda 180 | (() char-set:empty) 181 | ((cset . csets) (%char-set-xor cset csets)))) 182 | (define (char-set-xor! cset . csets) 183 | (%char-set-xor cset csets)) 184 | (define (char-set-diff+intersection cset . csets) 185 | (values (%char-set-intersection cset (char-set-complement (apply char-set-union csets))) 186 | (%char-set-intersection cset (apply char-set-union csets)))) 187 | (define (char-set-diff+intersection! cset1 cset2 . csets) 188 | (values 189 | (%char-set-intersection cset1 190 | (char-set-complement (apply char-set-union cset2 csets))) 191 | (%char-set-intersection cset1 (apply char-set-union cset2 csets)))) 192 | (define char-set:letter+digit 193 | (char-set-union char-set:letter char-set:digit)) 194 | (define char-set:graphic 195 | (char-set-union char-set:letter char-set:digit char-set:punctuation char-set:symbol)) 196 | (define char-set:printing 197 | (char-set-union char-set:graphic char-set:whitespace)) 198 | )) 199 | -------------------------------------------------------------------------------- /src/srfi-151.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 151) 2 | (import (scheme base)) 3 | (import (scheme case-lambda)) 4 | (import (srfi 60)) 5 | (export 6 | bitwise-not 7 | bitwise-and 8 | bitwise-ior 9 | bitwise-xor 10 | bitwise-eqv 11 | bitwise-nand 12 | bitwise-nor 13 | bitwise-andc1 14 | bitwise-andc2 15 | bitwise-orc1 16 | bitwise-orc2 17 | arithmetic-shift 18 | bit-count 19 | integer-length 20 | bitwise-if 21 | bit-set? 22 | copy-bit 23 | bit-swap 24 | any-bit-set? 25 | every-bit-set? 26 | first-set-bit 27 | bit-field 28 | bit-field-any? 29 | bit-field-every? 30 | bit-field-clear 31 | bit-field-set 32 | bit-field-replace 33 | bit-field-replace-same 34 | bit-field-rotate 35 | bit-field-reverse 36 | bits->list 37 | list->bits 38 | bits->vector 39 | vector->bits 40 | bits 41 | bitwise-fold 42 | bitwise-for-each 43 | bitwise-unfold 44 | make-bitwise-generator 45 | ) 46 | (begin 47 | (define (bitwise-nand i j) 48 | (bitwise-not (bitwise-and i j))) 49 | (define (bitwise-nor i j) 50 | (bitwise-not (bitwise-ior i j))) 51 | (define (bitwise-andc1 i j) 52 | (bitwise-and (bitwise-not i) j)) 53 | (define (bitwise-andc2 i j) 54 | (bitwise-and i (bitwise-not j))) 55 | (define (bitwise-orc1 i j) 56 | (bitwise-ior (bitwise-not i) j)) 57 | (define (bitwise-orc2 i j) 58 | (bitwise-ior i (bitwise-not j))) 59 | (define (bitwise-eqv . args) 60 | (define (b-eqv args ret) 61 | (if (pair? args) 62 | (b-eqv (cdr args) (bitwise-not (bitwise-xor ret (car args)))) 63 | ret)) 64 | (b-eqv args -1)) 65 | (define (bit-swap i1 i2 n) 66 | (copy-bit i2 67 | (copy-bit i1 n (bit-set? i2 n)) 68 | (bit-set? i1 n))) 69 | (define (any-bit-set? test-bits i) 70 | (not (zero? (bitwise-and test-bits i)))) 71 | (define (every-bit-set? test-bits i) 72 | (= test-bits (bitwise-and test-bits i))) 73 | (define (bit-field-any? i start end) 74 | (not (zero? (bitwise-and (arithmetic-shift i (- start)) (mask start end))))) 75 | (define (bit-field-every? i start end) 76 | (let ((m (mask start end))) 77 | (eqv? m (bitwise-and (arithmetic-shift i (- start)) m)))) 78 | (define (bit-field-clear i start end) 79 | (bit-field-replace i 0 start end)) 80 | (define (bit-field-set i start end) 81 | (bit-field-replace i -1 start end)) 82 | (define (mask start end) 83 | (bitwise-not (arithmetic-shift -1 (- end start)))) 84 | (define (bit-field-replace dest src start end) 85 | (let ((m (mask start end))) 86 | (bitwise-ior (bitwise-and dest (bitwise-not (arithmetic-shift m start))) 87 | (arithmetic-shift (bitwise-and src m) start)))) 88 | (define (bit-field-replace-same dest src start end) 89 | (bitwise-if (arithmetic-shift (mask start end) start) src dest)) 90 | (define bits->vector 91 | (case-lambda 92 | ((i) (list->vector (bits->list i))) 93 | ((i len) (list->vector (bits->list i len))))) 94 | (define (vector->bits vec) 95 | (list->bits (vector->list vec))) 96 | 97 | ;;; Copyright John Cowan 2017 98 | 99 | (define (bitwise-fold proc seed i) 100 | (let ((len (integer-length i))) 101 | (let loop ((n 0) (r seed)) 102 | (if (= n len) 103 | r 104 | (loop (+ n 1) (proc (bit-set? n i) r)))))) 105 | 106 | (define (bitwise-for-each proc i) 107 | (let ((len (integer-length i))) 108 | (let loop ((n 0)) 109 | (when (< n len) 110 | (proc (bit-set? n i)) 111 | (loop (+ n 1)))))) 112 | 113 | (define (bitwise-unfold stop? mapper successor seed) 114 | (let loop ((n 0) (result 0) (state seed)) 115 | (if (stop? state) 116 | result 117 | (loop (+ n 1) 118 | (copy-bit n result (mapper state)) 119 | (successor state))))) 120 | 121 | (define (make-bitwise-generator i) 122 | (lambda () 123 | (let ((bit (bit-set? 0 i))) 124 | (set! i (arithmetic-shift i -1)) 125 | bit))) 126 | 127 | ;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer 128 | ; 129 | ;Permission to copy this software, to modify it, to redistribute it, 130 | ;to distribute modified versions, and to use it for any purpose is 131 | ;granted, subject to the following restrictions and understandings. 132 | ; 133 | ;1. Any copy made of this software must include this copyright notice 134 | ;in full. 135 | ; 136 | ;2. I have made no warranty or representation that the operation of 137 | ;this software will be error-free, and I am under no obligation to 138 | ;provide any services, by way of maintenance, update, or otherwise. 139 | ; 140 | ;3. In conjunction with products arising from the use of this 141 | ;material, there shall be no use of my name in any advertising, 142 | ;promotional, or sales literature without prior written consent in 143 | ;each case. 144 | 145 | (define (bit-field-rotate n count start end) 146 | (define width (- end start)) 147 | (set! count (modulo count width)) 148 | (let ((mask (bitwise-not (arithmetic-shift -1 width)))) 149 | (define zn (bitwise-and mask (arithmetic-shift n (- start)))) 150 | (bitwise-ior (arithmetic-shift 151 | (bitwise-ior (bitwise-and mask (arithmetic-shift zn count)) 152 | (arithmetic-shift zn (- count width))) 153 | start) 154 | (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)))) 155 | 156 | (define (bit-reverse k n) 157 | (do ((m (if (negative? n) (bitwise-not n) n) (arithmetic-shift m -1)) 158 | (k (+ -1 k) (+ -1 k)) 159 | (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m)))) 160 | ((negative? k) (if (negative? n) (bitwise-not rvs) rvs)))) 161 | 162 | 163 | (define (bit-field-reverse n start end) 164 | (define width (- end start)) 165 | (let ((mask (bitwise-not (arithmetic-shift -1 width)))) 166 | (define zn (bitwise-and mask (arithmetic-shift n (- start)))) 167 | (bitwise-ior (arithmetic-shift (bit-reverse width zn) start) 168 | (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)))) 169 | 170 | #| 171 | (define (copy-bit index to bool) 172 | (if bool 173 | (bitwise-ior to (arithmetic-shift 1 index)) 174 | (bitwise-and to (bitwise-not (arithmetic-shift 1 index))))) 175 | |# 176 | (define (bits->list k . len) 177 | (if (null? len) 178 | (do ((k k (arithmetic-shift k -1)) 179 | (lst '() (cons (odd? k) lst))) 180 | ((<= k 0) (reverse lst))) 181 | (do ((idx (+ -1 (car len)) (+ -1 idx)) 182 | (k k (arithmetic-shift k -1)) 183 | (lst '() (cons (odd? k) lst))) 184 | ((negative? idx) (reverse lst))))) 185 | 186 | (define (list->bits bools) 187 | (do ((bs (reverse bools) (cdr bs)) 188 | (acc 0 (+ acc acc (if (car bs) 1 0)))) 189 | ((null? bs) acc))) 190 | 191 | (define (bits . bools) 192 | (list->bits bools)) 193 | 194 | #| 195 | (define (bitwise-if mask n0 n1) 196 | (bitwise-ior (bitwise-and mask n0) 197 | (bitwise-and (bitwise-not mask) n1))) 198 | |# 199 | ) 200 | ) 201 | -------------------------------------------------------------------------------- /src/srfi-193.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 193) 2 | (import (foment base)) 3 | (export 4 | command-line 5 | command-name 6 | command-args 7 | script-file 8 | script-directory) 9 | (begin 10 | (define base-directory (current-directory)) 11 | (define path-char (cond-expand (windows #\\) (else #\/))) 12 | (define (string-last-char s ch) 13 | (define (last-char idx) 14 | (if (or (< idx 0) (eq? (string-ref s idx) ch)) 15 | idx 16 | (last-char (- idx 1)))) 17 | (last-char (- (string-length s) 1))) 18 | (define (strip-extension name) 19 | (let ((edx (string-last-char name #\.)) 20 | (pdx (string-last-char name path-char))) 21 | (if (> edx pdx) 22 | (string-copy name 0 edx) 23 | name))) 24 | (define (strip-directory name) 25 | (let ((pdx (string-last-char name path-char))) 26 | (if (>= pdx 0) 27 | (string-copy name (+ pdx 1)) 28 | name))) 29 | (define (strip-filename name) 30 | (let ((pdx (string-last-char name path-char))) 31 | (if (>= pdx 0) 32 | (string-copy name 0 (+ pdx 1)) 33 | ""))) 34 | (define (command-name) 35 | (let ((name (car (command-line)))) 36 | (if (equal? name "") 37 | #f 38 | (strip-directory (strip-extension name))))) 39 | (define (command-args) (cdr (command-line))) 40 | (define (script-file) 41 | (let ((name (car (command-line)))) 42 | (if (equal? name "") 43 | #f 44 | (if (eq? (string-ref name 0) path-char) 45 | name 46 | (string-append base-directory (make-string 1 path-char) name))))) 47 | (define (script-directory) 48 | (let ((name (script-file))) 49 | (if name 50 | (strip-filename name) 51 | #f))) 52 | )) 53 | -------------------------------------------------------------------------------- /src/srfi-207.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 207) 2 | (import (foment base)) 3 | (export 4 | bytestring 5 | make-bytestring 6 | make-bytestring! 7 | bytevector->hex-string 8 | hex-string->bytevector 9 | bytevector->base64 10 | base64->bytevector 11 | bytestring->list 12 | make-bytestring-generator 13 | bytestring-pad 14 | bytestring-pad-right 15 | bytestring-trim 16 | bytestring-trim-right 17 | bytestring-trim-both 18 | bytestring-replace 19 | bytevector=? 20 | bytevector? 22 | bytevector<=? 23 | bytevector>=? 24 | (rename bytevector=? bytestring=?) 25 | (rename bytevector? bytestring>?) 27 | (rename bytevector<=? bytestring<=?) 28 | (rename bytevector>=? bytestring>=?) 29 | bytestring-index 30 | bytestring-index-right 31 | bytestring-break 32 | bytestring-span 33 | bytestring-join 34 | bytestring-split 35 | read-textual-bytestring 36 | write-textual-bytestring 37 | write-binary-bytestring 38 | bytestring-error?) 39 | (begin 40 | (define (bytestring . args) 41 | (make-bytestring args)) 42 | (define (make-bytestring! bv at lst) 43 | (bytevector-copy! bv at (make-bytestring lst))) 44 | (define (make-bytestring-generator . args) 45 | (let ((bdx 0) (bv (make-bytestring args))) 46 | (lambda () 47 | (if (= bdx (bytevector-length bv)) 48 | (eof-object) 49 | (let ((val (bytevector-u8-ref bv bdx))) 50 | (set! bdx (+ bdx 1)) 51 | val))))) 52 | (define (bytestring-pad bv len pad) 53 | (let ((padding (- len (bytevector-length bv)))) 54 | (if (< padding 0) 55 | (bytevector-copy bv) 56 | (let ((result (make-bytevector len (if (char? pad) (char->integer pad) pad)))) 57 | (bytevector-copy! result padding bv) 58 | result)))) 59 | (define (bytestring-pad-right bv len pad) 60 | (if (< (- len (bytevector-length bv)) 0) 61 | (bytevector-copy bv) 62 | (let ((result (make-bytevector len (if (char? pad) (char->integer pad) pad)))) 63 | (bytevector-copy! result 0 bv) 64 | result))) 65 | (define (bytestring-trim bv pred) 66 | (let ((start (bytestring-index bv (lambda (n) (not (pred n)))))) 67 | (if start 68 | (bytevector-copy bv start) 69 | #u8()))) 70 | (define (bytestring-trim-right bv pred) 71 | (let ((end (bytestring-index-right bv (lambda (n) (not (pred n)))))) 72 | (if end 73 | (bytevector-copy bv 0 (+ end 1)) 74 | #u8()))) 75 | (define (bytestring-trim-both bv pred) 76 | (let ((start (bytestring-index bv (lambda (n) (not (pred n)))))) 77 | (if start 78 | (bytevector-copy bv start 79 | (+ (bytestring-index-right bv (lambda (n) (not (pred n)))) 1)) 80 | #u8()))) 81 | (define bytestring-replace 82 | (case-lambda 83 | ((bv1 bv2 start1 end1) 84 | (%bytestring-replace bv1 bv2 start1 end1 0 (bytevector-length bv2))) 85 | ((bv1 bv2 start1 end1 start2 end2) 86 | (%bytestring-replace bv1 bv2 start1 end1 start2 end2)))) 87 | (define (%bytestring-replace bv1 bv2 start1 end1 start2 end2) 88 | (let* ((len (+ (- (bytevector-length bv1) (- end1 start1)) (- end2 start2))) 89 | (bv (make-bytevector len))) 90 | (bytevector-copy! bv 0 bv1 0 start1) 91 | (bytevector-copy! bv start1 bv2 start2 end2) 92 | (bytevector-copy! bv (+ start1 (- end2 start2)) bv1 end1 (bytevector-length bv1)) 93 | bv)) 94 | (define (%bytestring-index bv pred start end) 95 | (if (>= start end) 96 | #f 97 | (if (pred (bytevector-u8-ref bv start)) 98 | start 99 | (%bytestring-index bv pred (+ start 1) end)))) 100 | (define bytestring-index 101 | (case-lambda 102 | ((bv pred) (%bytestring-index bv pred 0 (bytevector-length bv))) 103 | ((bv pred start) (%bytestring-index bv pred start (bytevector-length bv))) 104 | ((bv pred start end) (%bytestring-index bv pred start end)))) 105 | (define (%bytestring-index-right bv pred start end) 106 | (let ((end (- end 1))) 107 | (if (>= start end) 108 | #f 109 | (if (pred (bytevector-u8-ref bv end)) 110 | end 111 | (%bytestring-index-right bv pred start end))))) 112 | (define bytestring-index-right 113 | (case-lambda 114 | ((bv pred) (%bytestring-index-right bv pred 0 (bytevector-length bv))) 115 | ((bv pred start) (%bytestring-index-right bv pred start (bytevector-length bv))) 116 | ((bv pred start end) (%bytestring-index-right bv pred start end)))) 117 | (define (bytestring-break bv pred) 118 | (let ((idx (bytestring-index bv pred))) 119 | (if (not idx) 120 | (values (bytevector-copy bv) (bytevector)) 121 | (values (bytevector-copy bv 0 idx) (bytevector-copy bv idx))))) 122 | (define (bytestring-span bv pred) 123 | (bytestring-break bv (lambda (b) (not (pred b))))) 124 | (define bytestring-join 125 | (case-lambda 126 | ((lst delim) (%bytestring-join lst (bytestring delim) 'infix)) 127 | ((lst delim grammar) (%bytestring-join lst (bytestring delim) grammar)))) 128 | (define (%bytestring-join lst delim grammar) 129 | (if (null? lst) 130 | (if (eq? grammar 'strict-infix) 131 | (full-error 'assertion-violation 'bytestring-join 'bytestring-error 132 | "bytestring-join: list must not be empty with strict-inflix") 133 | (bytevector)) 134 | (let ((port (open-output-bytevector))) 135 | (if (eq? grammar 'prefix) 136 | (write-bytevector delim port)) 137 | (write-bytevector (car lst) port) 138 | (for-each 139 | (lambda (bv) 140 | (write-bytevector delim port) 141 | (write-bytevector bv port)) 142 | (cdr lst)) 143 | (if (eq? grammar 'suffix) 144 | (write-bytevector delim port)) 145 | (get-output-bytevector port)))) 146 | (define bytestring-split 147 | (case-lambda 148 | ((bv delim) 149 | (%bytestring-split bv (if (char? delim) (char->integer delim) delim) 'infix)) 150 | ((bv delim grammar) 151 | (%bytestring-split bv (if (char? delim) (char->integer delim) delim) 152 | grammar)))) 153 | (define (%bytestring-split bv delim grammar) 154 | (let* ((len (bytevector-length bv)) 155 | (len (if (and (eq? grammar 'suffix) 156 | (= (bytevector-u8-ref bv (- len 1)) delim)) 157 | (- len 1) 158 | len))) 159 | (define (split sdx idx) 160 | (if (= idx len) 161 | (list (bytevector-copy bv sdx idx)) 162 | (if (= (bytevector-u8-ref bv idx) delim) 163 | (cons (bytevector-copy bv sdx idx) (split (+ idx 1) (+ idx 1))) 164 | (split sdx (+ idx 1))))) 165 | (if (= len 0) 166 | '() 167 | (if (and (eq? grammar 'prefix) (= (bytevector-u8-ref bv 0) delim)) 168 | (split 1 1) 169 | (split 0 0))))) 170 | (define (write-binary-bytestring port . args) 171 | (write-bytevector (apply bytestring args) port)) 172 | (define (bytestring-error? obj) 173 | (and (error-object? obj) (eq? (error-object-kind obj) 'bytestring-error))) 174 | ) 175 | ) 176 | -------------------------------------------------------------------------------- /src/srfi-60.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 60) 2 | (import (foment base)) 3 | (export 4 | bitwise-and 5 | (rename bitwise-and logand) 6 | bitwise-ior 7 | (rename bitwise-ior logior) 8 | bitwise-xor 9 | (rename bitwise-xor logxor) 10 | bitwise-not 11 | (rename bitwise-not lognot) 12 | bitwise-merge 13 | (rename bitwise-merge bitwise-if) 14 | any-bits-set? 15 | (rename any-bits-set? logtest) 16 | bit-count 17 | (rename bit-count logcount) 18 | integer-length 19 | first-set-bit 20 | (rename first-set-bit log2-binary-factors) 21 | bit-set? 22 | (rename bit-set? logbit?) 23 | copy-bit 24 | bit-field 25 | copy-bit-field 26 | arithmetic-shift 27 | (rename arithmetic-shift ash) 28 | rotate-bit-field 29 | reverse-bit-field 30 | integer->list 31 | list->integer 32 | booleans->integer 33 | ) 34 | (begin 35 | (define (first-set-bit n) 36 | (- (integer-length (bitwise-and n (- n))) 1)) 37 | (define (bitwise-merge mask n0 n1) 38 | (bitwise-ior (bitwise-and mask n0) (bitwise-and (bitwise-not mask) n1))) 39 | 40 | (define (any-bits-set? n1 n2) 41 | (not (zero? (bitwise-and n1 n2)))) 42 | 43 | (define (bit-set? index n) 44 | (any-bits-set? (expt 2 index) n)) 45 | 46 | (define (copy-bit idx to bit) 47 | (if bit 48 | (bitwise-ior to (arithmetic-shift 1 idx)) 49 | (bitwise-and to (bitwise-not (arithmetic-shift 1 idx))))) 50 | 51 | (define (bit-field n start end) 52 | (bitwise-and (bitwise-not (arithmetic-shift -1 (- end start))) 53 | (arithmetic-shift n (- start)))) 54 | 55 | (define (copy-bit-field to from start end) 56 | (bitwise-merge 57 | (arithmetic-shift (bitwise-not (arithmetic-shift -1 (- end start))) start) 58 | (arithmetic-shift from start) to)) 59 | 60 | (define (rotate-bit-field n count start end) 61 | (define width (- end start)) 62 | (set! count (modulo count width)) 63 | (let ((mask (bitwise-not (arithmetic-shift -1 width)))) 64 | (define zn (bitwise-and mask (arithmetic-shift n (- start)))) 65 | (bitwise-ior 66 | (arithmetic-shift 67 | (bitwise-ior 68 | (bitwise-and mask (arithmetic-shift zn count)) 69 | (arithmetic-shift zn (- count width))) 70 | start) 71 | (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)))) 72 | 73 | (define (bit-reverse k n) 74 | (do ((m (if (negative? n) (bitwise-not n) n) (arithmetic-shift m -1)) 75 | (k (+ -1 k) (+ -1 k)) 76 | (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m)))) 77 | ((negative? k) (if (negative? n) (bitwise-not rvs) rvs)))) 78 | 79 | (define (reverse-bit-field n start end) 80 | (define width (- end start)) 81 | (let ((mask (bitwise-not (arithmetic-shift -1 width)))) 82 | (define zn (bitwise-and mask (arithmetic-shift n (- start)))) 83 | (bitwise-ior 84 | (arithmetic-shift (bit-reverse width zn) start) 85 | (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)))) 86 | 87 | (define (integer->list k . len) 88 | (if (null? len) 89 | (do ((k k (arithmetic-shift k -1)) 90 | (lst '() (cons (odd? k) lst))) 91 | ((<= k 0) lst)) 92 | (do ((idx (+ -1 (car len)) (+ -1 idx)) 93 | (k k (arithmetic-shift k -1)) 94 | (lst '() (cons (odd? k) lst))) 95 | ((negative? idx) lst)))) 96 | 97 | (define (list->integer bools) 98 | (do ((bs bools (cdr bs)) 99 | (acc 0 (+ acc acc (if (car bs) 1 0)))) 100 | ((null? bs) acc))) 101 | 102 | (define (booleans->integer . bools) 103 | (list->integer bools)) 104 | )) 105 | -------------------------------------------------------------------------------- /src/syncthrd.hpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #ifndef __SYNCTHRD_HPP__ 8 | #define __SYNCTHRD_HPP__ 9 | 10 | #ifdef FOMENT_WINDOWS 11 | 12 | // ---- Operating System Thread ---- 13 | 14 | typedef HANDLE OSThreadHandle; 15 | 16 | // ---- Operating System Exclusive ---- 17 | 18 | typedef CRITICAL_SECTION OSExclusive; 19 | 20 | inline void InitializeExclusive(OSExclusive * ose) 21 | { 22 | InitializeCriticalSection(ose); 23 | } 24 | 25 | inline void EnterExclusive(OSExclusive * ose) 26 | { 27 | EnterCriticalSection(ose); 28 | } 29 | 30 | inline void LeaveExclusive(OSExclusive * ose) 31 | { 32 | LeaveCriticalSection(ose); 33 | } 34 | 35 | inline int TryExclusive(OSExclusive * ose) 36 | { 37 | return(TryEnterCriticalSection(ose)); 38 | } 39 | 40 | inline void DeleteExclusive(OSExclusive * ose) 41 | { 42 | DeleteCriticalSection(ose); 43 | } 44 | 45 | // ---- Operating System Condition ---- 46 | 47 | typedef CONDITION_VARIABLE OSCondition; 48 | 49 | inline void InitializeCondition(OSCondition * osc) 50 | { 51 | InitializeConditionVariable(osc); 52 | } 53 | 54 | inline void ConditionWait(OSCondition * osc, OSExclusive * ose) 55 | { 56 | SleepConditionVariableCS(osc, ose, INFINITE); 57 | } 58 | 59 | inline void WakeCondition(OSCondition * osc) 60 | { 61 | WakeConditionVariable(osc); 62 | } 63 | 64 | inline void WakeAllCondition(OSCondition * osc) 65 | { 66 | WakeAllConditionVariable(osc); 67 | } 68 | 69 | inline void DeleteCondition(OSCondition * osc) 70 | { 71 | // Nothing. 72 | } 73 | 74 | #endif // FOMENT_WINDOWS 75 | 76 | #ifdef FOMENT_UNIX 77 | 78 | // ---- Operating System Thread ---- 79 | 80 | typedef pthread_t OSThreadHandle; 81 | 82 | // ---- Operating System Exclusive ---- 83 | 84 | typedef pthread_mutex_t OSExclusive; 85 | 86 | void InitializeExclusive(OSExclusive * ose); 87 | 88 | inline void EnterExclusive(OSExclusive * ose) 89 | { 90 | pthread_mutex_lock(ose); 91 | } 92 | 93 | inline void LeaveExclusive(OSExclusive * ose) 94 | { 95 | pthread_mutex_unlock(ose); 96 | } 97 | 98 | inline int TryExclusive(OSExclusive * ose) 99 | { 100 | return(pthread_mutex_trylock(ose) == 0); 101 | } 102 | 103 | inline void DeleteExclusive(OSExclusive * ose) 104 | { 105 | pthread_mutex_destroy(ose); 106 | } 107 | 108 | // ---- Operating System Condition ---- 109 | 110 | typedef pthread_cond_t OSCondition; 111 | 112 | inline void InitializeCondition(OSCondition * osc) 113 | { 114 | pthread_cond_init(osc, 0); 115 | } 116 | 117 | inline void ConditionWait(OSCondition * osc, OSExclusive * ose) 118 | { 119 | pthread_cond_wait(osc, ose); 120 | } 121 | 122 | inline void WakeCondition(OSCondition * osc) 123 | { 124 | pthread_cond_signal(osc); 125 | } 126 | 127 | inline void WakeAllCondition(OSCondition * osc) 128 | { 129 | pthread_cond_broadcast(osc); 130 | } 131 | 132 | inline void DeleteCondition(OSCondition * osc) 133 | { 134 | pthread_cond_destroy(osc); 135 | } 136 | 137 | #endif // FOMENT_UNIX 138 | 139 | ulong_t ConditionWaitTimeout(OSCondition * osc, OSExclusive * ose, FObject to); 140 | 141 | // ---- Threads ---- 142 | 143 | #define AsThread(obj) ((FThread *) (obj)) 144 | 145 | #define THREAD_STATE_NEW 0 146 | #define THREAD_STATE_READY 1 147 | #define THREAD_STATE_RUNNING 2 148 | #define THREAD_STATE_DONE 3 149 | 150 | #define THREAD_EXIT_NORMAL 0 151 | #define THREAD_EXIT_TERMINATED 1 152 | #define THREAD_EXIT_UNCAUGHT 2 153 | 154 | typedef struct 155 | { 156 | FObject Result; 157 | FObject Thunk; 158 | FObject Name; 159 | FObject Specific; 160 | OSThreadHandle Handle; 161 | OSExclusive Exclusive; 162 | OSCondition Condition; 163 | ulong_t State; 164 | ulong_t Exit; 165 | } FThread; 166 | 167 | FThread * MakeThread(OSThreadHandle h, FObject thnk); 168 | void DeleteThread(FObject thrd); 169 | void ThreadExit(FObject obj, ulong_t exit); 170 | 171 | // ---- Exclusives ---- 172 | 173 | #define AsExclusive(obj) ((FExclusive *) (obj)) 174 | 175 | typedef struct 176 | { 177 | FObject Name; 178 | FObject Specific; 179 | OSExclusive Exclusive; 180 | } FExclusive; 181 | 182 | // ---- Conditions ---- 183 | 184 | #define AsCondition(obj) ((FCondition *) (obj)) 185 | 186 | typedef struct 187 | { 188 | FObject Name; 189 | FObject Specific; 190 | OSCondition Condition; 191 | } FCondition; 192 | 193 | // ---- Time ---- 194 | 195 | #define AsTime(obj) ((FTime *) (obj)) 196 | #define TimeP(obj) (ObjectTag(obj) == TimeTag) 197 | 198 | typedef struct 199 | { 200 | #ifdef FOMENT_WINDOWS 201 | FILETIME filetime; 202 | #else // FOMENT_WINDOWS 203 | struct timespec timespec; 204 | #endif // FOMENT_WINDOWS 205 | } FTime; 206 | 207 | // ---------------- 208 | 209 | #ifdef FOMENT_WINDOWS 210 | extern unsigned int TlsIndex; 211 | 212 | inline FThreadState * GetThreadState() 213 | { 214 | FAssert(TlsGetValue(TlsIndex) != 0); 215 | 216 | return((FThreadState *) TlsGetValue(TlsIndex)); 217 | } 218 | 219 | inline void SetThreadState(FThreadState * ts) 220 | { 221 | TlsSetValue(TlsIndex, ts); 222 | } 223 | #endif // FOMENT_WINDOWS 224 | 225 | #ifdef FOMENT_UNIX 226 | extern pthread_key_t ThreadKey; 227 | 228 | inline FThreadState * GetThreadState() 229 | { 230 | FAssert(pthread_getspecific(ThreadKey) != 0); 231 | 232 | return((FThreadState *) pthread_getspecific(ThreadKey)); 233 | } 234 | 235 | inline void SetThreadState(FThreadState * ts) 236 | { 237 | pthread_setspecific(ThreadKey, ts); 238 | } 239 | #endif // FOMENT_UNIX 240 | 241 | extern FThreadState * Threads; 242 | extern OSExclusive ThreadsExclusive; 243 | 244 | long_t EnterThread(FThreadState * ts, FObject thrd, FObject prms); 245 | ulong_t LeaveThread(FThreadState * ts); 246 | 247 | inline FObject Parameter(ulong_t idx) 248 | { 249 | FThreadState * ts = GetThreadState(); 250 | 251 | FAssert(idx < ts->ParametersLength); 252 | FAssert(BoxP(ts->Parameters[idx])); 253 | 254 | return(Unbox(ts->Parameters[idx])); 255 | } 256 | 257 | typedef struct 258 | { 259 | long_t Unused; 260 | } FNotifyThrow; 261 | 262 | class FWithExclusive 263 | { 264 | public: 265 | 266 | FWithExclusive(FObject exc); 267 | FWithExclusive(OSExclusive * ose); 268 | ~FWithExclusive(); 269 | 270 | private: 271 | 272 | OSExclusive * Exclusive; 273 | }; 274 | 275 | #endif // __SYNCTHRD_HPP__ 276 | -------------------------------------------------------------------------------- /src/txt2cpp.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Convert a scheme library into a multiple line string constant. 4 | 5 | */ 6 | 7 | #ifdef FOMENT_WINDOWS 8 | #define _CRT_SECURE_NO_WARNINGS 9 | #define strdup(s) _strdup(s) 10 | #endif // FOMENT_WINDOWS 11 | 12 | #include 13 | #include 14 | 15 | void print_name(FILE * outf, char * nam) 16 | { 17 | int sf = 1; 18 | 19 | while (*nam) 20 | { 21 | if (*nam >= 'a' && *nam <= 'z') 22 | { 23 | if (sf) 24 | fputc(*nam - 'a' + 'A', outf); 25 | else 26 | fputc(*nam, outf); 27 | sf = 0; 28 | } 29 | else if (*nam == ' ' || *nam == '(' || *nam == '-') 30 | sf = 1; 31 | else if (*nam == ')') 32 | break; 33 | else 34 | { 35 | fputc(*nam, outf); 36 | sf = 0; 37 | } 38 | 39 | nam += 1; 40 | } 41 | } 42 | 43 | char * parse_name(char * s) 44 | { 45 | int idx = 0; 46 | 47 | while (s[idx] != 0 && s[idx] != '(') 48 | idx += 1; 49 | 50 | if (s[idx] != 0) 51 | { 52 | char * nam = strdup(s + idx); 53 | for (idx = 0; nam[idx] != 0; idx++) 54 | if (nam[idx] == ')') 55 | { 56 | nam[idx + 1] = 0; 57 | break; 58 | } 59 | 60 | return(nam); 61 | } 62 | 63 | return(0); 64 | } 65 | 66 | int main(int argc, char * argv[]) 67 | { 68 | char buf[256]; 69 | char * libs[256]; 70 | char * names[256]; 71 | int num_libs = 0; 72 | int idx; 73 | 74 | if (argc < 3) 75 | { 76 | printf("usage: txt2cpp ...\n"); 77 | return(1); 78 | } 79 | 80 | FILE * outf = fopen(argv[1], "w"); 81 | if (outf == 0) 82 | { 83 | printf("error: unable to open %s for writing\n", argv[1]); 84 | return(1); 85 | } 86 | 87 | for (int adx = 2; adx < argc; adx += 1) 88 | { 89 | FILE * inf = fopen(argv[adx], "r"); 90 | if (inf == 0) 91 | { 92 | printf("error: unable to open %s for reading\n", argv[adx]); 93 | return(1); 94 | } 95 | 96 | for (;;) 97 | { 98 | if (fgets(buf, sizeof(buf), inf) == 0) 99 | break; 100 | 101 | char * s = buf; 102 | int cnt = 0; 103 | while (*s) 104 | { 105 | if (*s != ' ') 106 | break; 107 | 108 | s += 1; 109 | cnt += 1; 110 | } 111 | 112 | if (strncmp(s, "(define-library", 15) == 0) 113 | { 114 | char * nam = parse_name(s + 15); 115 | if (nam != 0) 116 | { 117 | if (num_libs > 0) 118 | { 119 | fputc(';', outf); 120 | fputc('\n', outf); 121 | } 122 | 123 | fprintf(outf, "char "); 124 | print_name(outf, nam); 125 | fprintf(outf, "[] ="); 126 | libs[num_libs] = nam; 127 | names[num_libs] = nam; 128 | num_libs += 1; 129 | } 130 | } 131 | else if (strncmp(s, "(aka", 4) == 0 && num_libs > 0) 132 | { 133 | char * nam = parse_name(s + 4); 134 | if (nam != 0) 135 | { 136 | libs[num_libs] = libs[num_libs - 1]; 137 | names[num_libs] = nam; 138 | num_libs += 1; 139 | } 140 | } 141 | 142 | if (*s != 0 && *s != '\n') 143 | { 144 | fputc('\n', outf); 145 | 146 | while (cnt > 0) 147 | { 148 | fputc(' ', outf); 149 | cnt -= 1; 150 | } 151 | 152 | fputc('"', outf); 153 | 154 | while (*s) 155 | { 156 | if (*s == '\n') 157 | { 158 | fputc('\\', outf); 159 | fputc('n', outf); 160 | break; 161 | } 162 | 163 | if (*s == '"' || *s == '\\') 164 | fputc('\\', outf); 165 | fputc(*s, outf); 166 | 167 | s += 1; 168 | } 169 | 170 | fputc('"', outf); 171 | } 172 | } 173 | 174 | fputc(';', outf); 175 | fputc('\n', outf); 176 | 177 | if (fclose(inf) != 0) 178 | { 179 | printf("error: unable to close %s\n", argv[adx]); 180 | return(1); 181 | } 182 | } 183 | 184 | fprintf(outf, "char * FomentLibraries[] = {\n"); 185 | for (idx = 1; idx < num_libs; idx++) 186 | { 187 | fprintf(outf, " "); 188 | print_name(outf, libs[idx]); 189 | fprintf(outf, ",\n"); 190 | }; 191 | fprintf(outf, " 0\n};\n"); 192 | 193 | fprintf(outf, "char FomentLibraryNames[] =\n\"#(\"\n"); 194 | for (idx = 1; idx < num_libs; idx++) 195 | fprintf(outf, "\" %s\"\n", names[idx]); 196 | fprintf(outf, "\")\";\n"); 197 | 198 | if (fclose(outf) != 0) 199 | { 200 | printf("error: unable to close %s\n", argv[1]); 201 | return(1); 202 | } 203 | 204 | return(0); 205 | } 206 | -------------------------------------------------------------------------------- /src/unicode.hpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Foment 4 | 5 | */ 6 | 7 | #ifndef __UNICODE_HPP__ 8 | #define __UNICODE_HPP__ 9 | 10 | #define MaximumUnicodeCharacter 0x0010FFFF 11 | #define UnicodeReplacementCharacter 0xFFFD 12 | 13 | #define Utf16HighSurrogateStart 0xD800 14 | #define Utf16HighSurrogateEnd 0xDBFF 15 | #define Utf16LowSurrogateStart 0xDC00 16 | #define Utf16LowSurrogateEnd 0xDFFF 17 | #define Utf16HalfShift 10 18 | #define Utf16HalfBase 0x0010000 19 | #define Utf16HalfMask 0x3FF 20 | 21 | extern unsigned char Utf8TrailingBytes[256]; 22 | 23 | FCh ConvertUtf8ToCh(FByte * b, ulong_t bl); 24 | FObject ConvertUtf8ToString(FByte * b, ulong_t bl); 25 | FObject ConvertStringToUtf8(FCh * s, ulong_t sl, long_t ztf, FCh * pch); 26 | FObject ConvertUtf16ToString(FCh16 * b, ulong_t bl); 27 | FObject ConvertStringToUtf16(FCh * s, ulong_t sl, long_t ztf, ulong_t el, FCh * pch); 28 | 29 | inline FObject ConvertStringToUtf8(FObject s) 30 | { 31 | FAssert(StringP(s)); 32 | 33 | return(ConvertStringToUtf8(AsString(s)->String, StringLength(s), 1, 0)); 34 | } 35 | 36 | inline FObject ConvertStringToUtf8(FCh * s, ulong_t sl, long_t ztf) 37 | { 38 | return(ConvertStringToUtf8(s, sl, ztf, 0)); 39 | } 40 | 41 | inline FObject ConvertStringToUtf16(FObject s) 42 | { 43 | FAssert(StringP(s)); 44 | 45 | return(ConvertStringToUtf16(AsString(s)->String, StringLength(s), 1, 0, 0)); 46 | } 47 | 48 | inline FObject ConvertStringToUtf16(FCh * s, ulong_t sl, long_t ztf, ulong_t el) 49 | { 50 | return(ConvertStringToUtf16(s, sl, ztf, el, 0)); 51 | } 52 | 53 | typedef struct 54 | { 55 | FCh Start; 56 | FCh End; // Inclusive 57 | } FCharRange; 58 | 59 | int32_t DigitValue(FCh ch); 60 | unsigned int DigitP(FCh ch); 61 | 62 | int WhitespaceP(FCh ch); 63 | unsigned int AlphabeticP(FCh ch); 64 | unsigned int UppercaseP(FCh ch); 65 | unsigned int LowercaseP(FCh ch); 66 | 67 | unsigned int CharFullfoldLength(FCh ch); 68 | FCh * CharFullfold(FCh ch); 69 | 70 | unsigned int CharFullupLength(FCh ch); 71 | FCh * CharFullup(FCh ch); 72 | 73 | unsigned int CharFulldownLength(FCh ch); 74 | FCh * CharFulldown(FCh ch); 75 | 76 | // Generated code in unicode.hpp. 77 | 78 | FCh CharFoldcase(FCh ch); 79 | FCh CharUpcase(FCh ch); 80 | FCh CharDowncase(FCh ch); 81 | 82 | #endif // __UNICODE_HPP__ 83 | -------------------------------------------------------------------------------- /test/chibi-test.sld: -------------------------------------------------------------------------------- 1 | (define-library (chibi test) 2 | (import (scheme base)) 3 | (import (scheme write)) 4 | (export test-begin test-end test test-error test-values) 5 | (begin 6 | (define passed 0) 7 | (define failed 0) 8 | (define section '()) 9 | (define failed-section '()) 10 | 11 | (define (test-passed) 12 | (set! passed (+ passed 1))) 13 | 14 | (define (test-failed expr thunk) 15 | (set! failed (+ failed 1)) 16 | (if (not (eq? failed-section section)) 17 | (begin 18 | (set! failed-section section) 19 | (display (car failed-section)) 20 | (newline))) 21 | (display "failed: ") 22 | (write expr) 23 | (thunk) 24 | (newline)) 25 | 26 | (define (test-begin msg) 27 | (set! section (cons msg section))) 28 | 29 | (define (test-end) 30 | (set! section (cdr section)) 31 | (if (null? section) 32 | (begin 33 | (display "pass: ") (write passed) 34 | (display " fail: ") (write failed) 35 | (newline)))) 36 | 37 | (define (check-equal? a b) 38 | (if (equal? a b) 39 | #t 40 | (if (and (number? a) (inexact? a) (number? b) (inexact? b)) 41 | (equal? (number->string a) (number->string b)) 42 | #f))) 43 | 44 | (define-syntax test 45 | (syntax-rules () 46 | ((test expect expr) 47 | (guard (exc 48 | (else 49 | (test-failed 'expr 50 | (lambda () 51 | (display " exception: ") 52 | (write exc))))) 53 | (let ((ret expr)) 54 | (if (check-equal? ret expect) 55 | (test-passed) 56 | (test-failed 'expr 57 | (lambda () 58 | (display " got: ") 59 | (write ret) 60 | (display " expected: ") 61 | (write expect))))))))) 62 | 63 | (define-syntax test-error 64 | (syntax-rules () 65 | ((test-error expr) 66 | (guard (exc 67 | (else (test-passed))) 68 | expr 69 | (test-failed 'expr 70 | (lambda () 71 | (display " : no exception raised"))))))) 72 | 73 | (define-syntax test-values 74 | (syntax-rules () 75 | ((test-values vals expr) 76 | (test 77 | (call-with-values (lambda () vals) list) 78 | (call-with-values (lambda () expr) list))))) 79 | )) 80 | 81 | -------------------------------------------------------------------------------- /test/eccentric.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Tests from eccentric.txt by JRM. 3 | ;;; 4 | 5 | (define-syntax nth-value 6 | (syntax-rules () 7 | ((nth-value n values-producing-form) 8 | (call-with-values 9 | (lambda () values-producing-form) 10 | (lambda all-values 11 | (list-ref all-values n)))))) 12 | 13 | (check-equal 5 (nth-value 4 (values 1 2 3 4 5 6 7 8))) 14 | 15 | (define-syntax please 16 | (syntax-rules () 17 | ((please . forms) forms))) 18 | 19 | (check-equal 20 (please + 9 11)) 20 | 21 | (define-syntax please 22 | (syntax-rules () 23 | ((please function . arguments) (function . arguments)))) 24 | 25 | (check-equal 20 (please + 9 11)) 26 | 27 | (define-syntax prohibit-one-arg 28 | (syntax-rules () 29 | ((prohibit-one-arg function argument) 30 | (syntax-error 31 | "Prohibit-one-arg cannot be used with one argument." 32 | function argument)) 33 | ((prohibit-one-arg function . arguments) 34 | (function . arguments)))) 35 | 36 | (check-syntax (syntax-violation syntax-error) (prohibit-one-arg display 3)) 37 | (check-equal 5 (prohibit-one-arg + 2 3)) 38 | 39 | (define-syntax bind-variables 40 | (syntax-rules () 41 | ((bind-variables () form . forms) 42 | (begin form . forms)) 43 | 44 | ((bind-variables ((variable value0 value1 . more) . more-bindings) form . forms) 45 | (syntax-error "bind-variables illegal binding" (variable value0 value1 . more))) 46 | 47 | ((bind-variables ((variable value) . more-bindings) form . forms) 48 | (let ((variable value)) (bind-variables more-bindings form . forms))) 49 | 50 | ((bind-variables ((variable) . more-bindings) form . forms) 51 | (let ((variable #f)) (bind-variables more-bindings form . forms))) 52 | 53 | ((bind-variables (variable . more-bindings) form . forms) 54 | (let ((variable #f)) (bind-variables more-bindings form . forms))) 55 | 56 | ((bind-variables bindings form . forms) 57 | (syntax-error "Bindings must be a list." bindings)))) 58 | 59 | (check-equal (1 #f #f 4) 60 | (bind-variables ((a 1) ;; a will be 1 61 | (b) ;; b will be #F 62 | c ;; so will c 63 | (d (+ a 3))) ;; a is visible in this scope. 64 | (list a b c d))) 65 | 66 | (define-syntax bind-variables1 67 | (syntax-rules () 68 | ((bind-variables1 () form . forms) 69 | (begin form . forms)) 70 | 71 | ((bind-variables1 ((variable value0 value1 . more) . more-bindings) form . forms) 72 | (syntax-error "bind-variables illegal binding" (variable value0 value1 . more))) 73 | 74 | ((bind-variables1 ((variable value) . more-bindings) form . forms) 75 | (bind-variables1 more-bindings (let ((variable value)) form . forms))) 76 | 77 | ((bind-variables1 ((variable) . more-bindings) form . forms) 78 | (bind-variables1 more-bindings (let ((variable #f)) form . forms))) 79 | 80 | ((bind-variables1 (variable . more-bindings) form . forms) 81 | (bind-variables1 more-bindings (let ((variable #f)) form . forms))) 82 | 83 | ((bind-variables1 bindings form . forms) 84 | (syntax-error "Bindings must be a list." bindings)))) 85 | 86 | (check-equal (1 #f #f 4) 87 | (bind-variables1 ((d (+ a 3)) ;; a is visible in this scope. 88 | c ;; c will be bound to #f 89 | (b) ;; so will b 90 | (a 1)) ;; a will be 1 91 | (list a b c d))) 92 | 93 | (define-syntax multiple-value-set! 94 | (syntax-rules () 95 | ((multiple-value-set! variables values-form) 96 | 97 | (gen-temps 98 | variables ;; provided for GEN-TEMPS 99 | () ;; initial value of temps 100 | variables ;; provided for GEN-SETS 101 | values-form)))) 102 | 103 | (define-syntax emit-cwv-form 104 | (syntax-rules () 105 | 106 | ((emit-cwv-form temps assignments values-form) 107 | (call-with-values (lambda () values-form) 108 | (lambda temps . assignments))))) 109 | 110 | (define-syntax gen-temps 111 | (syntax-rules () 112 | 113 | ((gen-temps () temps vars-for-gen-set values-form) 114 | (gen-sets temps 115 | temps ;; another copy for gen-sets 116 | vars-for-gen-set 117 | () ;; initial set of assignments 118 | values-form)) 119 | 120 | ((gen-temps (variable . more) temps vars-for-gen-set values-form) 121 | (gen-temps 122 | more 123 | (temp . temps) 124 | vars-for-gen-set 125 | values-form)))) 126 | 127 | (define-syntax gen-sets 128 | (syntax-rules () 129 | 130 | ((gen-sets temps () () assignments values-form) 131 | (emit-cwv-form temps assignments values-form)) 132 | 133 | ((gen-sets temps (temp . more-temps) (variable . more-vars) assignments values-form) 134 | (gen-sets 135 | temps 136 | more-temps 137 | more-vars 138 | ((set! variable temp) . assignments) 139 | values-form)))) 140 | 141 | (check-equal (1 2 3) 142 | (let ((a 0) (b 0) (c 0)) (multiple-value-set! (a b c) (values 1 2 3)) (list a b c))) 143 | 144 | (define-syntax multiple-value-set! 145 | (syntax-rules () 146 | ((multiple-value-set! variables values-form) 147 | 148 | (gen-temps-and-sets 149 | variables 150 | () ;; initial value of temps 151 | () ;; initial value of assignments 152 | values-form)))) 153 | 154 | (define-syntax gen-temps-and-sets 155 | (syntax-rules () 156 | 157 | ((gen-temps-and-sets () temps assignments values-form) 158 | (emit-cwv-form temps assignments values-form)) 159 | 160 | ((gen-temps-and-sets (variable . more) (temps ...) (assignments ...) values-form) 161 | (gen-temps-and-sets 162 | more 163 | (temps ... temp) 164 | (assignments ... (set! variable temp)) 165 | values-form)))) 166 | 167 | (define-syntax emit-cwv-form 168 | (syntax-rules () 169 | 170 | ((emit-cwv-form temps assignments values-form) 171 | (call-with-values (lambda () values-form) 172 | (lambda temps . assignments))))) 173 | 174 | (check-equal (1 2 3) 175 | (let ((a 0) (b 0) (c 0)) (multiple-value-set! (a b c) (values 1 2 3)) (list a b c))) 176 | 177 | (define-syntax multiple-value-set! 178 | (syntax-rules () 179 | ((multiple-value-set! variables values-form) 180 | (mvs-aux "entry" variables values-form)))) 181 | 182 | (define-syntax mvs-aux 183 | (syntax-rules () 184 | ((mvs-aux "entry" variables values-form) 185 | (mvs-aux "gen-code" variables () () values-form)) 186 | 187 | ((mvs-aux "gen-code" () temps sets values-form) 188 | (mvs-aux "emit" temps sets values-form)) 189 | 190 | ((mvs-aux "gen-code" (var . vars) (temps ...) (sets ...) values-form) 191 | (mvs-aux "gen-code" vars 192 | (temps ... temp) 193 | (sets ... (set! var temp)) 194 | values-form)) 195 | 196 | ((mvs-aux "emit" temps sets values-form) 197 | (call-with-values (lambda () values-form) 198 | (lambda temps . sets))))) 199 | 200 | (check-equal (1 2 3) 201 | (let ((a 0) (b 0) (c 0)) (multiple-value-set! (a b c) (values 1 2 3)) (list a b c))) 202 | 203 | (define d 0) 204 | (define e 0) 205 | (define f 0) 206 | (check-equal (1 2 3) (begin (multiple-value-set! (d e f) (values 1 2 3)) (list d e f))) 207 | 208 | (define-syntax sreverse 209 | (syntax-rules (halt) 210 | ((sreverse thing) (sreverse "top" thing ("done"))) 211 | 212 | ((sreverse "top" () (tag . more)) 213 | (sreverse tag () . more)) 214 | 215 | ((sreverse "top" ((headcar . headcdr) . tail) kont) 216 | (sreverse "top" tail ("after-tail" (headcar . headcdr) kont))) 217 | 218 | ((sreverse "after-tail" new-tail head kont) 219 | (sreverse "top" head ("after-head" new-tail kont))) 220 | 221 | ((sreverse "after-head" () new-tail (tag . more)) 222 | (sreverse tag new-tail . more)) 223 | 224 | ((sreverse "after-head" new-head (new-tail ...) (tag . more)) 225 | (sreverse tag (new-tail ... new-head) . more)) 226 | 227 | ((sreverse "top" (halt . tail) kont) 228 | '(sreverse "top" (halt . tail) kont)) 229 | 230 | ((sreverse "top" (head . tail) kont) 231 | (sreverse "top" tail ("after-tail2" head kont))) 232 | 233 | ((sreverse "after-tail2" () head (tag . more)) 234 | (sreverse tag (head) . more)) 235 | 236 | ((sreverse "after-tail2" (new-tail ...) head (tag . more)) 237 | (sreverse tag (new-tail ... head) . more)) 238 | 239 | ((sreverse "done" value) 240 | 'value))) 241 | 242 | (check-equal 243 | (sreverse "top" (halt) 244 | ("after-head" () 245 | ("after-tail2" 4 246 | ("after-head" (7 6) 247 | ("after-tail" (2 3) 248 | ("after-tail2" 1 249 | ("done"))))))) 250 | (sreverse (1 (2 3) (4 (halt)) 6 7))) 251 | -------------------------------------------------------------------------------- /test/exitcode.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Exit with the code specified as an argument. 4 | 5 | */ 6 | 7 | #include 8 | 9 | int main(int argc, char * argv[]) 10 | { 11 | if (argc != 2) 12 | return(1); 13 | return(atoi(argv[1])); 14 | } 15 | -------------------------------------------------------------------------------- /test/hang.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Hang. 4 | 5 | */ 6 | 7 | int main(int argc, char * argv[]) 8 | { 9 | int cnt = 0; 10 | 11 | for (;;) 12 | cnt += 1; 13 | 14 | return(0); 15 | } 16 | -------------------------------------------------------------------------------- /test/include.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; R7RS 3 | ;;; 4 | 5 | (define INCLUDE-A 10) 6 | (define include-b 20) 7 | -------------------------------------------------------------------------------- /test/include2.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; R7RS 3 | ;;; 4 | 5 | (set! a 10) 6 | (set! B 20) 7 | -------------------------------------------------------------------------------- /test/include3.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; R7RS 3 | ;;; 4 | 5 | (define INCLUDE-C 10) 6 | (define include-d 20) 7 | -------------------------------------------------------------------------------- /test/include4.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; R7RS 3 | ;;; 4 | 5 | (define INCLUDE-E 10) 6 | (define include-f 20) 7 | -------------------------------------------------------------------------------- /test/include5.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; R7RS 3 | ;;; 4 | 5 | (define INCLUDE-G 10) 6 | (define include-h 20) 7 | -------------------------------------------------------------------------------- /test/input.txt: -------------------------------------------------------------------------------- 1 | abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ -------------------------------------------------------------------------------- /test/lib-a-b-c.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib a b c) 2 | (import (scheme base)) 3 | (export lib-a-b-c) 4 | (begin 5 | (define lib-a-b-c 100))) 6 | -------------------------------------------------------------------------------- /test/lib/ce1.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib ce1) 2 | (import (scheme base))) 3 | -------------------------------------------------------------------------------- /test/lib/ce2.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib ce2) 2 | (import (scheme base))) 3 | -------------------------------------------------------------------------------- /test/lib/t1.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t1) 2 | (import (scheme base)) 3 | (begin 4 | (define lib-t1-a 10) 5 | (define lib-t1-b 20) 6 | (define lib-t1-c 30)) 7 | (export lib-t1-a (rename lib-t1-b b-lib-t1))) 8 | -------------------------------------------------------------------------------- /test/lib/t10.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t10) 2 | (import (scheme base)) 3 | (begin 4 | (define lib-t10-a 1) 5 | (define lib-t10-b 2) 6 | (define lib-t10-c 3) 7 | (define lib-t10-d 4)) 8 | (export lib-t10-a lib-t10-b lib-t10-c lib-t10-d)) 9 | -------------------------------------------------------------------------------- /test/lib/t11.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t11) 2 | (import (scheme base)) 3 | (begin 4 | (define lib-t11-a 1) 5 | (define lib-t11-b 2) 6 | (define lib-t11-c 3) 7 | (define lib-t11-d 4)) 8 | (export lib-t11-a lib-t11-b lib-t11-c lib-t11-d)) 9 | -------------------------------------------------------------------------------- /test/lib/t12.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t12) 2 | (import (scheme base)) 3 | (begin 4 | (define (foo) (set! + 12)))) 5 | 6 | -------------------------------------------------------------------------------- /test/lib/t13.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t13) 2 | (import (scheme base)) 3 | (begin 4 | (define + 12))) 5 | 6 | -------------------------------------------------------------------------------- /test/lib/t14.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t14) 2 | (import (scheme base)) 3 | (export lib-t14-a lib-t14-b) 4 | (begin 5 | (define (r- a b) (- b a)) 6 | (define (lib-t14-a x y) (r- x y)) 7 | (define (lib-t14-b x y) 8 | (define (rev- a b) (- b a)) 9 | (rev- x y)))) 10 | -------------------------------------------------------------------------------- /test/lib/t15.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t15) 2 | (import (scheme base) (lib t14)) 3 | (export lib-t15-a lib-t15-b) 4 | (begin 5 | (define (lib-t15-a p q) (lib-t14-a p q)) 6 | (define (lib-t15-b p q) (lib-t14-b p q)))) 7 | -------------------------------------------------------------------------------- /test/lib/t2.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t2) 2 | (import (scheme base) (lib t1)) 3 | (begin 4 | (define (lib-t2-a) lib-t1-a) 5 | (define (lib-t2-b) b-lib-t1)) 6 | (export lib-t2-a lib-t2-b)) 7 | -------------------------------------------------------------------------------- /test/lib/t3.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t2) 2 | (import (scheme base) (lib t1)) 3 | (begin 4 | (define (lib-t2-a) lib-t1-a) 5 | (define (lib-t2-b) lib-t1-b))) 6 | (export lib-t2-a lib-t2-b)) 7 | -------------------------------------------------------------------------------- /test/lib/t4.scm: -------------------------------------------------------------------------------- 1 | (define-library (lib t2) 2 | (import (scheme base) (lib t1)) 3 | (begin 4 | (define (lib-t2-a) lib-t1-a) 5 | (define (lib-t2-c) lib-t1-c))) 6 | (export lib-t2-a lib-t2-c)) 7 | -------------------------------------------------------------------------------- /test/lib/t5.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t5) 2 | (import (scheme base)) 3 | (begin 4 | (define a 1000) 5 | (define (b) a)) 6 | (export (rename a lib-t5-a) (rename b lib-t5-b))) 7 | -------------------------------------------------------------------------------- /test/lib/t6.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t6) 2 | (import (scheme base) (lib t5)) 3 | (begin 4 | (define (a) lib-t5-a) 5 | (define (b) (lib-t5-b))) 6 | (export (rename a lib-t6-a) (rename b lib-t6-b))) 7 | -------------------------------------------------------------------------------- /test/lib/t7-ild.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base)) 2 | (begin 3 | (define a 1000) 4 | (define (b) a)) 5 | (export (rename a lib-t7-a) (rename b lib-t7-b)) 6 | -------------------------------------------------------------------------------- /test/lib/t7.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t7) 2 | (include-library-declarations "t7-ild.scm")) 3 | 4 | -------------------------------------------------------------------------------- /test/lib/t8.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t8) 2 | (import (scheme base)) 3 | (begin 4 | (define lib-t8-a 1) 5 | (define lib-t8-b 2) 6 | (define lib-t8-c 3) 7 | (define lib-t8-d 4)) 8 | (export lib-t8-a lib-t8-b lib-t8-c lib-t8-d)) 9 | 10 | -------------------------------------------------------------------------------- /test/lib/t9.sld: -------------------------------------------------------------------------------- 1 | (define-library (lib t9) 2 | (import (scheme base)) 3 | (begin 4 | (define lib-t9-a 1) 5 | (define lib-t9-b 2) 6 | (define lib-t9-c 3) 7 | (define lib-t9-d 4)) 8 | (export lib-t9-a lib-t9-b lib-t9-c lib-t9-d)) 9 | -------------------------------------------------------------------------------- /test/loadtest.scm: -------------------------------------------------------------------------------- 1 | (define load-test #t) 2 | -------------------------------------------------------------------------------- /test/process.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Processes 3 | ;;; 4 | 5 | (import (foment base)) 6 | 7 | (check-equal #t #t) 8 | 9 | (define (read-lines port) 10 | (let ((s (read-line port))) 11 | (if (eof-object? s) 12 | '() 13 | (cons s (read-lines port))))) 14 | 15 | (define stdread 16 | (cond-expand 17 | (windows "..\\windows\\debug\\stdread.exe") 18 | (else "../unix/debug/stdread"))) 19 | 20 | (define stdwrite 21 | (cond-expand 22 | (windows "..\\windows\\debug\\stdwrite.exe") 23 | (else "../unix/debug/stdwrite"))) 24 | 25 | (define exitcode 26 | (cond-expand 27 | (windows "..\\windows\\debug\\exitcode.exe") 28 | (else "../unix/debug/exitcode"))) 29 | 30 | (define hang 31 | (cond-expand 32 | (windows "..\\windows\\debug\\hang.exe") 33 | (else "../unix/debug/hang"))) 34 | 35 | ;; subprocess 36 | 37 | (check-equal 0 38 | (call-with-values 39 | (lambda () 40 | (subprocess (current-output-port) #f (current-error-port) 41 | stdread "ABC" "DEF GHI" "JKLMNOPQR")) 42 | (lambda (sub in out err) 43 | (for-each 44 | (lambda (line) 45 | (display line out) 46 | (newline out)) 47 | '("ABC" "DEF GHI" "JKLMNOPQR")) 48 | (close-port out) 49 | (subprocess-wait sub) 50 | (subprocess-status sub)))) 51 | 52 | (check-equal ("abc" "def\\ghi" "jklmn\"opqr") 53 | (call-with-values 54 | (lambda () 55 | (subprocess #f (current-input-port) (current-error-port) 56 | stdwrite "--stdout" "abc" "def\\ghi" "jklmn\"opqr")) 57 | (lambda (sub in out err) 58 | (let ((lines (read-lines in))) 59 | (close-port in) 60 | (subprocess-wait sub) 61 | (if (zero? (subprocess-status sub)) 62 | lines 63 | #f))))) 64 | 65 | (check-equal ("abc" "defghi" "jklmnopqr") 66 | (call-with-values 67 | (lambda () 68 | (subprocess #f (current-input-port) 'stdout 69 | stdwrite "--stderr" "abc" "defghi" "jklmnopqr")) 70 | (lambda (sub in out err) 71 | (let ((lines (read-lines in))) 72 | (close-port in) 73 | (subprocess-wait sub) 74 | (if (zero? (subprocess-status sub)) 75 | lines 76 | #f))))) 77 | 78 | (check-equal ("abc" "defghi" "jklmnopqr") 79 | (call-with-values 80 | (lambda () 81 | (subprocess (current-output-port) (current-input-port) #f 82 | stdwrite "--stderr" "abc" "defghi" "jklmnopqr")) 83 | (lambda (sub in out err) 84 | (let ((lines (read-lines err))) 85 | (close-port err) 86 | (subprocess-wait sub) 87 | (if (zero? (subprocess-status sub)) 88 | lines 89 | #f))))) 90 | 91 | (check-equal 234 92 | (call-with-values 93 | (lambda () 94 | (subprocess (current-output-port) (current-input-port) (current-error-port) 95 | exitcode "234")) 96 | (lambda (sub in out err) 97 | (subprocess-wait sub) 98 | (subprocess-status sub)))) 99 | 100 | ;; subprocess-wait 101 | ;; subprocess-status 102 | ;; subprocess-kill 103 | ;; subprocess-pid 104 | ;; subprocess? 105 | 106 | (define-values (sub1 in1 out1 err1) (subprocess #f #f 'stdout hang)) 107 | (check-equal #t (subprocess? sub1)) 108 | (check-equal #f (subprocess? in1)) 109 | (check-equal #f err1) 110 | (check-equal #t (input-port-open? in1)) 111 | (check-equal #t (output-port-open? out1)) 112 | 113 | (check-equal running (subprocess-status sub1)) 114 | (check-equal #t (and (integer? (subprocess-pid sub1)) (> (subprocess-pid sub1) 0))) 115 | 116 | (subprocess-kill sub1 #t) 117 | (subprocess-wait sub1) 118 | (check-equal #t (integer? (subprocess-status sub1))) 119 | 120 | (close-port in1) 121 | (close-port out1) 122 | 123 | ;; process/ports 124 | ;; process*/ports 125 | 126 | (check-equal 0 127 | (let* ((lst (process*/ports (current-output-port) #f (current-error-port) 128 | stdread "ABC" "DEFGHI" "JKLMNOPQR")) 129 | (out (cadr lst)) 130 | (ctrl (cadddr (cdr lst)))) 131 | (for-each 132 | (lambda (line) 133 | (display line out) 134 | (newline out)) 135 | '("ABC" "DEFGHI" "JKLMNOPQR")) 136 | (close-port out) 137 | (ctrl 'wait) 138 | (ctrl 'exit-code))) 139 | 140 | (check-equal ("abc" "defghi" "jklmnopqr") 141 | (let* ((lst (process*/ports #f (current-input-port) (current-error-port) 142 | stdwrite "--stdout" "abc" "defghi" "jklmnopqr")) 143 | (in (car lst)) 144 | (ctrl (cadddr (cdr lst)))) 145 | (let ((lines (read-lines in))) 146 | (close-port in) 147 | (ctrl 'wait) 148 | (if (zero? (ctrl 'exit-code)) 149 | lines 150 | #f)))) 151 | 152 | (check-equal ("abc" "defghi" "jklmnopqr") 153 | (let* ((lst (process/ports #f (current-input-port) 'stdout 154 | "stdwrite --stderr abc defghi jklmnopqr")) 155 | (in (car lst)) 156 | (ctrl (cadddr (cdr lst)))) 157 | (let ((lines (read-lines in))) 158 | (close-port in) 159 | (ctrl 'wait) 160 | (if (zero? (ctrl 'exit-code)) 161 | lines 162 | #f)))) 163 | 164 | (check-equal ("abc" "defghi" "jklmnopqr") 165 | (let* ((lst (process*/ports (current-output-port) (current-input-port) #f 166 | stdwrite "--stderr" "abc" "defghi" "jklmnopqr")) 167 | (err (cadddr lst)) 168 | (ctrl (cadddr (cdr lst)))) 169 | (let ((lines (read-lines err))) 170 | (close-port err) 171 | (ctrl 'wait) 172 | (if (zero? (ctrl 'exit-code)) 173 | lines 174 | #f)))) 175 | 176 | (check-equal 123 177 | (let* ((lst (process*/ports (current-output-port) (current-input-port) (current-error-port) 178 | exitcode "123")) 179 | (ctrl (cadddr (cdr lst)))) 180 | (ctrl 'wait) 181 | (ctrl 'exit-code))) 182 | 183 | ;; ( 'status) 184 | ;; ( 'exit-code) 185 | ;; ( 'wait) 186 | ;; ( 'kill) 187 | 188 | (define p2 (process*/ports #f #f 'stdout hang)) 189 | (define in2 (car p2)) 190 | (define out2 (cadr p2)) 191 | (check-equal #t 192 | (let ((pid (caddr p2))) 193 | (and (integer? pid) (> pid 0)))) 194 | (define err2 (cadddr p2)) 195 | (define ctrl2 (cadddr (cdr p2))) 196 | 197 | (check-equal #f err2) 198 | (check-equal #t (input-port-open? in2)) 199 | (check-equal #t (output-port-open? out2)) 200 | 201 | (check-equal running (ctrl2 'status)) 202 | (check-equal #f (ctrl2 'exit-code)) 203 | 204 | (ctrl2 'kill) 205 | (ctrl2 'wait) 206 | (check-equal #t 207 | (eq? (cond-expand (windows 'done-ok) (else 'done-error)) 208 | (ctrl2 'status))) 209 | 210 | (check-equal #t (integer? (ctrl2 'exit-code))) 211 | 212 | ;; system 213 | ;; system* 214 | 215 | (define (with-output-to-string proc) 216 | (let ((port (open-output-string))) 217 | (parameterize ((current-output-port port)) (proc)) 218 | (get-output-string port))) 219 | 220 | (check-equal #t 221 | (string=? (substring "abcdefghijklmnopqr" 0 18) 222 | (substring 223 | (with-output-to-string 224 | (lambda () 225 | (system "stdwrite --stdout abcdefghijklmnopqr"))) 226 | 0 18))) 227 | 228 | (define (with-input-from-string s proc) 229 | (let ((port (open-input-string s))) 230 | (parameterize ((current-input-port port)) (proc)))) 231 | 232 | (check-equal #t 233 | (with-input-from-string "abcdef\n" 234 | (lambda () 235 | (system* stdread "abcdef")))) 236 | 237 | (check-equal #f 238 | (with-input-from-string "abcdef" 239 | (lambda () 240 | (system* stdread "abc" "def")))) 241 | 242 | ;; system/exit-code 243 | ;; system*/exit-code 244 | 245 | (check-equal 88 246 | (system/exit-code "exitcode 88")) 247 | 248 | (check-equal 88 249 | (system*/exit-code exitcode "88")) 250 | 251 | ;; chicken process module 252 | 253 | (define (call-with-input-pipe cmdline proc) 254 | (let* ((lst (process/ports #f (current-input-port) (current-error-port) cmdline)) 255 | (in (car lst)) 256 | (ctrl (cadddr (cdr lst)))) 257 | (let-values ((results (proc in))) 258 | (close-port in) 259 | (ctrl 'wait) 260 | (if (= (ctrl 'exit-code) 0) 261 | (apply values results) 262 | #f)))) 263 | 264 | (check-equal ("aaa" "bbb" "ccc" "ddd") 265 | (call-with-input-pipe "stdwrite --stdout aaa bbb ccc ddd" 266 | (lambda (in) (read-lines in)))) 267 | 268 | (define (call-with-output-pipe cmdline proc) 269 | (let* ((lst (process/ports (current-output-port) #f (current-error-port) cmdline)) 270 | (out (cadr lst)) 271 | (ctrl (cadddr (cdr lst)))) 272 | (let-values ((results (proc out))) 273 | (close-port out) 274 | (ctrl 'wait) 275 | (if (= (ctrl 'exit-code) 0) 276 | (apply values results) 277 | #f)))) 278 | 279 | (check-equal #t 280 | (call-with-output-pipe "stdread 1 22 333 4444 55555" 281 | (lambda (out) 282 | (for-each 283 | (lambda (line) 284 | (display line out) 285 | (newline out)) 286 | '("1" "22" "333" "4444" "55555")) 287 | #t))) 288 | 289 | (define (with-input-from-pipe cmdline proc) 290 | (call-with-input-pipe cmdline 291 | (lambda (port) 292 | (parameterize ((current-input-port port)) (proc))))) 293 | 294 | (check-equal ("aaa" "bbb" "ccc" "ddd") 295 | (with-input-from-pipe "stdwrite --stdout aaa bbb ccc ddd" 296 | (lambda () (read-lines (current-input-port))))) 297 | 298 | (define (with-output-to-pipe cmdline proc) 299 | (call-with-output-pipe cmdline 300 | (lambda (port) 301 | (parameterize ((current-output-port port)) (proc))))) 302 | 303 | (check-equal #t 304 | (with-output-to-pipe "stdread 1 22 333 4444 55555" 305 | (lambda () 306 | (for-each 307 | (lambda (line) 308 | (display line) 309 | (newline)) 310 | '("1" "22" "333" "4444" "55555")) 311 | #t))) 312 | -------------------------------------------------------------------------------- /test/r5rs_pitfall.scm: -------------------------------------------------------------------------------- 1 | ;; r5rs_pitfalls.scm 2 | ;; 3 | ;; This program attempts to test a Scheme implementation's conformance 4 | ;; to various subtle edge-cases and consequences of the R5RS Scheme standard. 5 | ;; Code was collected from public forums, and is hereby placed in the public domain. 6 | ;; 7 | ;; 8 | 9 | ;; Section 1: Proper letrec implementation 10 | 11 | ;;Credits to Al Petrofsky 12 | ;; In thread: 13 | ;; defines in letrec body 14 | ;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com 15 | (check-equal 0 16 | (let ((cont #f)) 17 | (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0))) 18 | (y (call-with-current-continuation (lambda (c) (set! cont c) 0)))) 19 | (if cont 20 | (let ((c cont)) 21 | (set! cont #f) 22 | (set! x 1) 23 | (set! y 1) 24 | (c 0)) 25 | (+ x y))))) 26 | 27 | ;;Credits to Al Petrofsky 28 | ;; In thread: 29 | ;; Widespread bug (arguably) in letrec when an initializer returns twice 30 | ;; http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com 31 | 32 | (check-equal #t 33 | (letrec ((x (call/cc list)) (y (call/cc list))) 34 | (cond ((procedure? x) (x (pair? y))) 35 | ((procedure? y) (y (pair? x)))) 36 | (let ((x (car x)) (y (car y))) 37 | (and (call/cc x) (call/cc y) (call/cc x))))) 38 | 39 | ;;Credits to Alan Bawden 40 | ;; In thread: 41 | ;; LETREC + CALL/CC = SET! even in a limited setting 42 | ;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU 43 | (check-equal #t 44 | (letrec ((x (call-with-current-continuation 45 | (lambda (c) 46 | (list #t c))))) 47 | (if (car x) 48 | ((cadr x) (list #f (lambda () x))) 49 | (eq? x ((cadr x)))))) 50 | 51 | ;; Section 2: Proper call/cc and procedure application 52 | 53 | ;;Credits to Al Petrofsky, (and a wink to Matthias Blume) 54 | ;; In thread: 55 | ;; Widespread bug in handling (call/cc (lambda (c) (0 (c 1)))) => 1 56 | ;; http://groups.google.com/groups?selm=87g00y4b6l.fsf%40radish.petrofsky.org 57 | (check-equal 1 58 | (call/cc (lambda (c) (0 (c 1))))) 59 | 60 | ;; Section 3: Hygienic macros 61 | 62 | ;; Eli Barzilay 63 | ;; In thread: 64 | ;; R5RS macros... 65 | ;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu 66 | (check-equal 4 67 | (let-syntax ((foo 68 | (syntax-rules () 69 | ((_ expr) (+ expr 1))))) 70 | (let ((+ *)) 71 | (foo 3)))) 72 | 73 | ;; Al Petrofsky again 74 | ;; In thread: 75 | ;; Buggy use of begin in r5rs cond and case macros. 76 | ;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org 77 | (check-equal 2 78 | (let-syntax ((foo (syntax-rules () 79 | ((_ var) (define var 1))))) 80 | (let ((x 2)) 81 | (begin (define foo +)) 82 | (cond (else (foo x))) 83 | x))) 84 | 85 | ;;Al Petrofsky 86 | ;; In thread: 87 | ;; An Advanced syntax-rules Primer for the Mildly Insane 88 | ;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org 89 | 90 | (check-equal 1 91 | (let ((x 1)) 92 | (let-syntax 93 | ((foo (syntax-rules () 94 | ((_ y) (let-syntax 95 | ((bar (syntax-rules () 96 | ((_) (let ((x 2)) y))))) 97 | (bar)))))) 98 | (foo x)))) 99 | 100 | (check-equal (1 2 3 a) 101 | (let ((a 1)) 102 | (letrec-syntax 103 | ((foo (syntax-rules () 104 | ((_ b) 105 | (bar a b)))) 106 | (bar (syntax-rules () 107 | ((_ c d) 108 | (cons c (let ((c 3)) 109 | (list d c 'c))))))) 110 | (let ((a 2)) 111 | (foo a))))) 112 | 113 | (check-equal 2 114 | (let ((x 1)) 115 | (let-syntax 116 | ((foo (syntax-rules () 117 | ((_ y) (let-syntax 118 | ((bar (syntax-rules () 119 | ((_ x) y)))) 120 | (bar 2)))))) 121 | (foo x)))) 122 | 123 | ;; Al Petrofsky 124 | ;; Contributed directly 125 | (check-equal 1 126 | (let-syntax ((x (syntax-rules ()))) 1)) 127 | 128 | ;; Setion 4: No identifiers are reserved 129 | 130 | ;;(Brian M. Moore) 131 | ;; In thread: 132 | ;; shadowing syntatic keywords, bug in MIT Scheme? 133 | ;; http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu 134 | (check-equal (x) 135 | ((lambda lambda lambda) 'x)) 136 | 137 | (check-equal (1 2 3) 138 | ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda))) 139 | 140 | (check-equal #f 141 | (let ((quote -)) (eqv? '1 1))) 142 | ;; Section 5: #f/() distinctness 143 | 144 | ;; Scott Miller 145 | (check-equal #f 146 | (eq? #f '())) 147 | (check-equal #f 148 | (eqv? #f '())) 149 | (check-equal #f 150 | (equal? #f '())) 151 | 152 | ;; Section 6: string->symbol case sensitivity 153 | 154 | ;; Jens Axel S?gaard 155 | ;; In thread: 156 | ;; Symbols in DrScheme - bug? 157 | ;; http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk 158 | (check-equal #f 159 | (eq? (string->symbol "f") (string->symbol "F"))) 160 | 161 | ;; Section 7: First class continuations 162 | 163 | ;; Scott Miller 164 | ;; No newsgroup posting associated. The gist of this test and 7.2 165 | ;; is that once captured, a continuation should be unmodified by the 166 | ;; invocation of other continuations. This test determines that this is 167 | ;; the case by capturing a continuation and setting it aside in a temporary 168 | ;; variable while it invokes that and another continuation, trying to 169 | ;; side effect the first continuation. This test case was developed when 170 | ;; testing SISC 1.7's lazy CallFrame unzipping code. 171 | (define r #f) 172 | (define a #f) 173 | (define b #f) 174 | (define c #f) 175 | (define i 0) 176 | (check-equal 28 177 | (let () 178 | (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4)))) 179 | (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7)))))) 180 | (if (not c) 181 | (set! c a)) 182 | (set! i (+ i 1)) 183 | (case i 184 | ((1) (a 5)) 185 | ((2) (b 8)) 186 | ((3) (a 6)) 187 | ((4) (c 4))) 188 | r)) 189 | 190 | ;; Same test, but in reverse order 191 | (define r #f) 192 | (define a #f) 193 | (define b #f) 194 | (define c #f) 195 | (define i 0) 196 | (check-equal 28 197 | (let () 198 | (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4)))) 199 | (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7)))))) 200 | (if (not c) 201 | (set! c a)) 202 | (set! i (+ i 1)) 203 | (case i 204 | ((1) (b 8)) 205 | ((2) (a 5)) 206 | ((3) (b 7)) 207 | ((4) (c 4))) 208 | r)) 209 | 210 | ;; Credits to Matthias Radestock 211 | ;; Another test case used to test SISC's lazy CallFrame routines. 212 | (check-equal ((-1 4 5 3) 213 | (4 -1 5 3) 214 | (-1 5 4 3) 215 | (5 -1 4 3) 216 | (4 5 -1 3) 217 | (5 4 -1 3)) 218 | (let ((k1 #f) 219 | (k2 #f) 220 | (k3 #f) 221 | (state 0)) 222 | (define (identity x) x) 223 | (define (fn) 224 | ((identity (if (= state 0) 225 | (call/cc (lambda (k) (set! k1 k) +)) 226 | +)) 227 | (identity (if (= state 0) 228 | (call/cc (lambda (k) (set! k2 k) 1)) 229 | 1)) 230 | (identity (if (= state 0) 231 | (call/cc (lambda (k) (set! k3 k) 2)) 232 | 2)))) 233 | (define (check states) 234 | (set! state 0) 235 | (let* ((res '()) 236 | (r (fn))) 237 | (set! res (cons r res)) 238 | (if (null? states) 239 | res 240 | (begin (set! state (car states)) 241 | (set! states (cdr states)) 242 | (case state 243 | ((1) (k3 4)) 244 | ((2) (k2 2)) 245 | ((3) (k1 -))))))) 246 | (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))))) 247 | 248 | ;; Modification of the yin-yang puzzle so that it terminates and produces 249 | ;; a value as a result. (Scott G. Miller) 250 | #| 251 | (check-equal (10 9 8 7 6 5 4 3 2 1 0) 252 | (let ((x '()) 253 | (y 0)) 254 | (call/cc 255 | (lambda (escape) 256 | (let* ((yin ((lambda (foo) 257 | (set! x (cons y x)) 258 | (if (= y 10) 259 | (escape x) 260 | (begin 261 | (set! y 0) 262 | foo))) 263 | (call/cc (lambda (bar) bar)))) 264 | (yang ((lambda (foo) 265 | (set! y (+ y 1)) 266 | foo) 267 | (call/cc (lambda (baz) baz))))) 268 | (yin yang)))))) 269 | |# 270 | ;; Miscellaneous 271 | 272 | ;;Al Petrofsky 273 | ;; In thread: 274 | ;; R5RS Implementors Pitfalls 275 | ;; http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com 276 | (check-equal -1 277 | (let - ((n (- 1))) n)) 278 | 279 | (check-equal (1 2 3 4 1 2 3 4 5) 280 | (let ((ls (list 1 2 3 4))) 281 | (append ls ls '(5)))) 282 | 283 | ;; This example actually illustrates a bug in R5RS. If a Scheme system 284 | ;; follows the letter of the standard, 1 should be returned, but 285 | ;; the general agreement is that 2 should instead be returned. 286 | ;; The reason is that in R5RS, let-syntax always introduces new scope, thus 287 | ;; in the following test, the let-syntax breaks the definition section 288 | ;; and begins the expression section of the let. 289 | ;; 290 | ;; The general agreement by the implementors in 1998 was that the following 291 | ;; should be possible, but isn't: 292 | ;; 293 | ;; (define ---) 294 | ;; (let-syntax (---) 295 | ;; (define ---) 296 | ;; (define ---)) 297 | ;; (define ---) 298 | ;; 299 | ;; Scheme systems based on the Portable syntax-case expander by Dybvig 300 | ;; and Waddell do allow the above, and thus often violate the letter of 301 | ;; R5RS. In such systems, the following will produce a local scope: 302 | ;; 303 | ;; (define ---) 304 | ;; (let-syntax ((a ---)) 305 | ;; (let () 306 | ;; (define ---) 307 | ;; (define ---))) 308 | ;; (define ---) 309 | ;; 310 | ;; Credits to Matthias Radestock and thanks to R. Kent Dybvig for the 311 | ;; explanation and background 312 | (check-equal 1 313 | (let ((x 1)) 314 | (let-syntax ((foo (syntax-rules () ((_) 2)))) 315 | (define x (foo)) 316 | 3) 317 | x)) 318 | 319 | -------------------------------------------------------------------------------- /test/r7rs-eval.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; R7RS 3 | ;;; 4 | ;;; These tests need eval. They will not work as a program; load or runtests.scm needs to be used. 5 | ;;; 6 | 7 | ;; define-library 8 | 9 | (check-equal 100 (begin (import (lib a b c)) lib-a-b-c)) 10 | (check-equal 10 (begin (import (lib t1)) lib-t1-a)) 11 | (check-error (assertion-violation) lib-t1-b) 12 | (check-equal 20 b-lib-t1) 13 | (check-error (assertion-violation) lib-t1-c) 14 | 15 | (check-equal 10 (begin (import (lib t2)) (lib-t2-a))) 16 | (check-equal 20 (lib-t2-b)) 17 | (check-syntax (syntax-violation) (import (lib t3))) 18 | (check-syntax (syntax-violation) (import (lib t4))) 19 | 20 | (check-equal 1000 (begin (import (lib t5)) (lib-t5-b))) 21 | (check-equal 1000 lib-t5-a) 22 | 23 | (check-equal 1000 (begin (import (lib t6)) (lib-t6-b))) 24 | (check-equal 1000 (lib-t6-a)) 25 | 26 | (check-equal 1000 (begin (import (lib t7)) (lib-t7-b))) 27 | (check-equal 1000 lib-t7-a) 28 | 29 | (check-equal 1 (begin (import (only (lib t8) lib-t8-a lib-t8-c)) lib-t8-a)) 30 | (check-error (assertion-violation) lib-t8-b) 31 | (check-equal 3 lib-t8-c) 32 | (check-error (assertion-violation) lib-t8-d) 33 | 34 | (check-equal 1 (begin (import (except (lib t9) lib-t9-b lib-t9-d)) lib-t9-a)) 35 | (check-error (assertion-violation) lib-t9-b) 36 | (check-equal 3 lib-t9-c) 37 | (check-error (assertion-violation) lib-t9-d) 38 | 39 | (check-equal 1 (begin (import (prefix (lib t10) x)) xlib-t10-a)) 40 | (check-error (assertion-violation) lib-t10-b) 41 | (check-equal 3 xlib-t10-c) 42 | (check-error (assertion-violation) lib-t10-d) 43 | 44 | (check-equal 1 (begin (import (rename (lib t11) (lib-t11-b b-lib-t11) (lib-t11-d d-lib-t11))) 45 | lib-t11-a)) 46 | (check-error (assertion-violation) lib-t11-b) 47 | (check-equal 2 b-lib-t11) 48 | (check-equal 3 lib-t11-c) 49 | (check-error (assertion-violation) lib-t11-d) 50 | (check-equal 4 d-lib-t11) 51 | 52 | (check-syntax (syntax-violation) (import bad "bad library" name)) 53 | (check-syntax (syntax-violation) 54 | (define-library (no ("good") "library") (import (scheme base)) (export +))) 55 | 56 | (check-syntax (syntax-violation) (import (lib t12))) 57 | (check-syntax (syntax-violation) (import (lib t13))) 58 | 59 | (check-equal 10 (begin (import (lib t14)) (lib-t14-a 10 20))) 60 | (check-equal 10 (lib-t14-b 10 20)) 61 | 62 | (check-equal 10 (begin (import (lib t15)) (lib-t15-a 10 20))) 63 | (check-equal 10 (lib-t15-b 10 20)) 64 | 65 | ;; include 66 | 67 | (check-error (assertion-violation) (let () (include "include3.scm") include-c)) 68 | 69 | ;; include-ci 70 | 71 | (check-error (assertion-violation) (let () (include-ci "include4.scm") INCLUDE-E)) 72 | -------------------------------------------------------------------------------- /test/runtests.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; A program to run the tests. 3 | ;; 4 | ;; foment runtests.scm ... 5 | ;; 6 | 7 | (import (foment base)) 8 | 9 | (define pass-count 0) 10 | (define fail-count 0) 11 | 12 | (define (run-tests lst) 13 | (define (fail obj ret) 14 | (set! fail-count (+ fail-count 1)) 15 | (display "failed: ") 16 | (write obj) 17 | (display ": ") 18 | (write ret) 19 | (newline)) 20 | (let ((env (interaction-environment '(scheme base)))) 21 | (define (check-equal? a b) 22 | (if (equal? a b) 23 | #t 24 | (if (and (number? a) (inexact? a) (number? b) (inexact? b)) 25 | (equal? (number->string a) (number->string b)) 26 | #f))) 27 | (define (test-check-equal obj) 28 | (let ((ret (eval (caddr obj) env))) 29 | (if (check-equal? (unsyntax (cadr obj)) ret) 30 | (set! pass-count (+ pass-count 1)) 31 | (fail obj ret)))) 32 | (define (test-check-error obj) 33 | (guard (exc 34 | ((error-object? exc) 35 | (let ((want (unsyntax (cadr obj)))) 36 | (if (or (not (equal? (car want) (error-object-type exc))) 37 | (and (pair? (cdr want)) 38 | (not (equal? (cadr want) (error-object-who exc))))) 39 | (fail obj exc) 40 | (set! pass-count (+ pass-count 1))))) 41 | (else (fail obj exc))) 42 | (eval (caddr obj) env) 43 | (fail obj "no exception raised"))) 44 | (define (test-when obj) 45 | (define (test-list lst) 46 | (when (pair? lst) 47 | (test-expr (car lst)) 48 | (test-list (cdr lst)))) 49 | (if (eval (cadr obj) env) 50 | (test-list (cddr obj)))) 51 | (define (test-expr obj) 52 | (cond 53 | ((and (pair? obj) (eq? (unsyntax (car obj)) 'check-equal)) 54 | (test-check-equal obj)) 55 | ((and (pair? obj) (eq? (unsyntax (car obj)) 'check-error)) 56 | (test-check-error obj)) 57 | ((and (pair? obj) (eq? (unsyntax (car obj)) 'check-syntax)) 58 | (test-check-error obj)) 59 | ((and (pair? obj) (eq? (unsyntax (car obj)) 'test-when)) 60 | (test-when obj)) 61 | (else (eval obj env)))) 62 | (define (test port) 63 | (let ((obj (read port))) 64 | (when (not (eof-object? obj)) 65 | (test-expr obj) 66 | (test port)))) 67 | (define (run name) 68 | (let ((port (open-input-file name))) 69 | (want-identifiers port #t) 70 | (call-with-port port test))) 71 | (if (not (null? lst)) 72 | (begin 73 | (display (car lst)) 74 | (newline) 75 | (run (car lst)) 76 | (run-tests (cdr lst)))))) 77 | 78 | (run-tests (cdr (command-line))) 79 | (when (> fail-count 0) 80 | (newline) 81 | (write (features)) 82 | (newline) 83 | (write (config)) 84 | (newline)) 85 | (display "pass: ") (display pass-count) (display " fail: ") (display fail-count) (newline) 86 | -------------------------------------------------------------------------------- /test/stdread.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Read lines from standard input; each line should match one argument. 4 | 5 | */ 6 | 7 | #include 8 | #include 9 | 10 | int main(int argc, char * argv[]) 11 | { 12 | char s[1024]; 13 | int adx = 1; 14 | 15 | for (;;) 16 | { 17 | if (fgets(s, sizeof(s), stdin) == 0) 18 | break; 19 | if (adx == argc) 20 | return(1); 21 | size_t sl = strlen(s); 22 | if (sl > 0) 23 | s[sl - 1] = 0; 24 | if (strcmp(s, argv[adx]) != 0) 25 | return(2); 26 | adx += 1; 27 | } 28 | 29 | return(0); 30 | } 31 | -------------------------------------------------------------------------------- /test/stdwrite.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Write lines to standard output or error; each line is an argument. 4 | 5 | */ 6 | 7 | #include 8 | #include 9 | 10 | int main(int argc, char * argv[]) 11 | { 12 | FILE * fp; 13 | 14 | if (argc < 2) 15 | return(1); 16 | if (strcmp(argv[1], "--stdout") == 0) 17 | fp = stdout; 18 | else if (strcmp(argv[1], "--stderr") == 0) 19 | fp = stderr; 20 | else 21 | return(2); 22 | 23 | for (int adx = 2; adx < argc; adx += 1) 24 | { 25 | fputs(argv[adx], fp); 26 | fputc('\n', fp); 27 | } 28 | 29 | return(0); 30 | } 31 | -------------------------------------------------------------------------------- /test/stress.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Stress Tests 3 | ;;; 4 | 5 | (import (foment bedrock)) 6 | 7 | (define rs (make-random-source)) 8 | (define (random-integer n) 9 | (%random-integer rs n)) 10 | 11 | (define p (make-parameter 0)) 12 | 13 | ; An implementation of a mailbox used by producer(s) and consumer(s). 14 | 15 | (define not-empty (make-condition)) 16 | (define not-full (make-condition)) 17 | (define lock (make-exclusive)) 18 | (define mailbox #f) 19 | (define mailbox-full #f) 20 | (define next-item 1) 21 | (define last-item 100) 22 | 23 | (define (producer) 24 | (sleep (random-integer 100)) 25 | (enter-exclusive lock) 26 | (let ((item next-item)) 27 | (define (put item) 28 | (if mailbox-full 29 | (begin 30 | (condition-wait not-full lock) 31 | (put item)) 32 | (begin 33 | (set! mailbox item) 34 | (set! mailbox-full #t) 35 | (leave-exclusive lock) 36 | (condition-wake not-empty)))) 37 | (set! next-item (+ next-item 1)) 38 | (if (> next-item last-item) 39 | (leave-exclusive lock) ; All done. 40 | (begin 41 | (put item) 42 | (producer))))) 43 | 44 | (define (consumer) 45 | (define (get) 46 | (if mailbox-full 47 | (begin 48 | (set! mailbox-full #f) 49 | (let ((item mailbox)) 50 | (condition-wake not-full) 51 | (leave-exclusive lock) 52 | item)) 53 | (begin 54 | (condition-wait not-empty lock) 55 | (get)))) 56 | (enter-exclusive lock) 57 | (let ((item (get))) 58 | (write item) 59 | (display " ") 60 | (consumer))) 61 | 62 | (define (run-thread thunk) 63 | (%run-thread thunk #t)) 64 | 65 | (p 1) 66 | (run-thread producer) 67 | (run-thread producer) 68 | (parameterize ((p 2)) (run-thread producer)) 69 | (parameterize ((p 3)) (run-thread consumer) 70 | (parameterize ((p 4)) (run-thread consumer))) 71 | (run-thread consumer) 72 | (run-thread consumer) 73 | (run-thread consumer) 74 | (run-thread consumer) 75 | 76 | (sleep 3000) 77 | (display " 78 | ") 79 | 80 | (define e1 (make-exclusive)) 81 | (define condition1 (make-condition)) 82 | 83 | (define run #t) 84 | 85 | (define (stress1) 86 | (enter-exclusive e1) 87 | (condition-wait condition1 e1) 88 | (leave-exclusive e1) 89 | (if run (stress1))) 90 | 91 | (define (stress2) 92 | (sleep (random-integer 1000)) 93 | (condition-wake condition1) 94 | (if run (stress2))) 95 | 96 | (run-thread stress1) 97 | (run-thread stress1) 98 | (run-thread stress1) 99 | (run-thread stress1) 100 | (run-thread stress2) 101 | (run-thread stress2) 102 | (run-thread stress2) 103 | (run-thread stress2) 104 | 105 | (define e2 (make-exclusive)) 106 | (enter-exclusive e2) 107 | (run-thread (lambda () (enter-exclusive e2))) 108 | 109 | (set! run #f) 110 | 111 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 112 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 113 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 114 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 115 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 116 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 117 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 118 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 119 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 120 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 121 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 122 | (run-thread (lambda () (define (recur n) (recur (+ n 1))) (recur 0))) 123 | -------------------------------------------------------------------------------- /test/threads.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Threads 3 | ;;; 4 | 5 | (import (foment base)) 6 | (import (srfi 18)) 7 | 8 | (define (current-seconds) (time->seconds (current-time))) 9 | (define s (current-seconds)) 10 | 11 | (thread-sleep! 0) 12 | 13 | (check-equal #t (<= s (current-seconds))) 14 | 15 | (set! s (current-seconds)) 16 | 17 | (thread-sleep! 2) 18 | 19 | (check-equal #t (< s (current-seconds))) 20 | 21 | (thread-sleep! (seconds->time (- (current-seconds) 10))) 22 | 23 | (define t (current-time)) 24 | (set! s (time->seconds t)) 25 | 26 | (thread-sleep! (seconds->time (+ s 2))) 27 | 28 | (check-equal #t (< s (current-seconds))) 29 | 30 | (check-error (assertion-violation thread-sleep!) (thread-sleep!)) 31 | (check-error (assertion-violation thread-sleep!) (thread-sleep! #f)) 32 | 33 | (check-equal #t (thread? (current-thread))) 34 | (check-equal #f (thread? 'thread)) 35 | 36 | (define result (cons #t #t)) 37 | 38 | (define thrd (make-thread (lambda () result) 'thread-name)) 39 | 40 | (check-equal thread-name (thread-name thrd)) 41 | (check-equal #t (thread? thrd)) 42 | 43 | (define specific (cons #f #f)) 44 | 45 | (thread-specific-set! thrd specific) 46 | (check-equal #t (eq? (thread-specific thrd) specific)) 47 | 48 | (thread-start! thrd) 49 | 50 | (check-equal thread-name (thread-name thrd)) 51 | (check-equal #t (thread? thrd)) 52 | (check-equal #t (eq? (thread-specific thrd) specific)) 53 | 54 | (thread-yield!) 55 | 56 | (check-equal #t (eq? (thread-join! thrd) result)) 57 | 58 | (check-equal thread-name (thread-name thrd)) 59 | (check-equal #t (thread? thrd)) 60 | (check-equal #t (eq? (thread-specific thrd) specific)) 61 | 62 | (define thrd (thread-start! (make-thread (lambda () (raise specific))))) 63 | 64 | (check-equal #t 65 | (eq? specific 66 | (guard (obj ((uncaught-exception? obj) (uncaught-exception-reason obj))) 67 | (thread-join! thrd)))) 68 | 69 | (define thrd (thread-start! (make-thread (lambda () (thread-sleep! 1) result)))) 70 | 71 | (check-equal #t (eq? result (thread-join! thrd))) 72 | 73 | (define thrd (thread-start! (make-thread (lambda () (thread-sleep! 9999))))) 74 | 75 | (thread-terminate! thrd) 76 | 77 | (check-equal #t 78 | (guard (obj ((terminated-thread-exception? obj) #t)) 79 | (thread-join! thrd))) 80 | 81 | (define thrd (thread-start! (make-thread (lambda () result)))) 82 | 83 | (thread-sleep! 1) 84 | 85 | (thread-terminate! thrd) 86 | 87 | (check-equal #t (eq? result (thread-join! thrd))) 88 | 89 | (define thrd (thread-start! (make-thread (lambda () (thread-sleep! 9999))))) 90 | 91 | (check-equal #t 92 | (guard (obj ((join-timeout-exception? obj) #t)) 93 | (thread-join! thrd 1))) 94 | 95 | (check-equal #t 96 | (guard (obj ((join-timeout-exception? obj) #t)) 97 | (thread-join! thrd (seconds->time (+ (time->seconds (current-time)) 1))))) 98 | 99 | (check-equal timed-out 100 | (thread-join! thrd 1 'timed-out)) 101 | 102 | (check-equal timed-out 103 | (thread-join! thrd (seconds->time (+ (time->seconds (current-time)) 1)) 'timed-out)) 104 | 105 | (thread-terminate! thrd) 106 | 107 | (check-equal #t 108 | (guard (obj ((terminated-thread-exception? obj) #t)) 109 | (thread-join! thrd))) 110 | 111 | (define mux (make-mutex 'mutex-name)) 112 | 113 | (check-equal #t (mutex? (make-mutex))) 114 | (check-equal #t (mutex? mux)) 115 | (check-equal #f (mutex? 'mutex)) 116 | 117 | (check-equal mutex-name (mutex-name mux)) 118 | 119 | (check-equal #f (eq? (mutex-specific mux) specific)) 120 | (mutex-specific-set! mux specific) 121 | (check-equal #t (eq? (mutex-specific mux) specific)) 122 | 123 | (check-equal #t (procedure? mutex-state)) 124 | (check-equal #t (procedure? abandoned-mutex-exception?)) 125 | 126 | (check-equal #t (try-exclusive mux)) 127 | (mutex-unlock! mux) 128 | 129 | (run-thread (lambda () (mutex-lock! mux) (sleep 1000) (mutex-unlock! mux))) 130 | (sleep 100) 131 | 132 | (check-equal #f (try-exclusive mux)) 133 | 134 | (define cv (make-condition-variable 'condition-variable-name)) 135 | 136 | (check-equal #t (condition-variable? (make-condition-variable))) 137 | (check-equal #t (condition-variable? cv)) 138 | (check-equal #f (condition-variable? 'condition-variable)) 139 | 140 | (check-equal condition-variable-name (condition-variable-name cv)) 141 | 142 | (check-equal #f (eq? (condition-variable-specific cv) specific)) 143 | (condition-variable-specific-set! cv specific) 144 | (check-equal #t (eq? (condition-variable-specific cv) specific)) 145 | 146 | (define mux (make-mutex)) 147 | (define done #f) 148 | (define result #f) 149 | 150 | (define (wait-for-done cnt) 151 | (if done 152 | (begin 153 | (set! result cnt) 154 | (mutex-unlock! mux)) 155 | (begin 156 | (mutex-unlock! mux cv) 157 | (wait-for-done (+ cnt 1))))) 158 | 159 | (run-thread 160 | (lambda () 161 | (mutex-lock! mux) 162 | (wait-for-done 0))) 163 | 164 | (sleep 100) 165 | (mutex-lock! mux) 166 | (set! done #t) 167 | (mutex-unlock! mux) 168 | (condition-variable-signal! cv) 169 | 170 | (define (wait-for-result) 171 | (mutex-lock! mux) 172 | (if (not result) 173 | (begin 174 | (mutex-unlock! mux) 175 | (sleep 100) 176 | (wait-for-result)) 177 | (begin 178 | (mutex-unlock! mux) 179 | result))) 180 | 181 | (check-equal #t (< 0 (wait-for-result))) 182 | 183 | (check-equal #t (eq? (with-exception-handler list current-exception-handler) list)) 184 | -------------------------------------------------------------------------------- /test/unicode.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Unicode 3 | ;;; 4 | 5 | (import (scheme base)) 6 | (import (scheme char)) 7 | 8 | -------------------------------------------------------------------------------- /unidata/gencase.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Generate Upcase, Downcase and Foldcase Unicode Tables 4 | 5 | gencase Upcase|Downcase|Foldcase|Fullfold|Fullup|Fulldown 6 | 7 | */ 8 | 9 | #define _CRT_SECURE_NO_WARNINGS 10 | #include 11 | #include 12 | #include 13 | 14 | #define MAX_FULL_CHARS 3 15 | 16 | int ParseFields(char * s, char ** flds) 17 | { 18 | int nflds = 0; 19 | 20 | for (;;) 21 | { 22 | char * f = strchr(s, ';'); 23 | 24 | while (*s == ' ') 25 | s += 1; 26 | 27 | if (*s == 0) 28 | flds[nflds] = 0; 29 | else 30 | flds[nflds] = s; 31 | 32 | nflds += 1; 33 | if (f == 0) 34 | break; 35 | 36 | *f = 0; 37 | s = f + 1; 38 | } 39 | 40 | return(nflds); 41 | } 42 | 43 | unsigned int ParseCodePoint(char * fld) 44 | { 45 | char * s = fld; 46 | unsigned int n = 0; 47 | 48 | while (*fld) 49 | { 50 | if (*fld >= '0' && *fld <= '9') 51 | n = n * 16 + *fld - '0'; 52 | else if (*fld >= 'a' && *fld <= 'f') 53 | n = n * 16 + *fld - 'a' + 10; 54 | else if (*fld >= 'A' && *fld <= 'F') 55 | n = n * 16 + *fld - 'A' + 10; 56 | else 57 | { 58 | fprintf(stderr, "error: gencase: unable to parse field: %s\n", s); 59 | return(0); 60 | } 61 | 62 | fld += 1; 63 | } 64 | 65 | return(n); 66 | } 67 | 68 | unsigned int ParseSeveralPoints(char * fld, unsigned int chars[MAX_FULL_CHARS]) 69 | { 70 | unsigned int cnt = 0; 71 | char * s; 72 | 73 | for (;;) 74 | { 75 | while (*fld == ' ') 76 | fld += 1; 77 | 78 | s = strchr(fld, ' '); 79 | if (s) 80 | *s = 0; 81 | 82 | chars[cnt] = ParseCodePoint(fld); 83 | cnt += 1; 84 | 85 | if (s == 0) 86 | break; 87 | 88 | fld = s + 1; 89 | } 90 | 91 | return(cnt); 92 | } 93 | 94 | void Usage() 95 | { 96 | fprintf(stderr, 97 | "usage: gencase Upcase|Downcase|Foldcase|Fullfold|Fullup|Fulldown \n"); 98 | } 99 | 100 | typedef struct 101 | { 102 | unsigned int Count; 103 | unsigned int Chars[MAX_FULL_CHARS]; 104 | } FullChar; 105 | 106 | unsigned int Map[0x110000]; 107 | FullChar FullMap[0x110000]; 108 | 109 | int main(int argc, char * argv[]) 110 | { 111 | char s[256]; 112 | 113 | for (int idx = 0; idx < 0x110000; idx++) 114 | { 115 | Map[idx] = idx; 116 | 117 | FullMap[idx].Count = 1; 118 | FullMap[idx].Chars[0] = idx; 119 | FullMap[idx].Chars[1] = 0; 120 | FullMap[idx].Chars[2] = 0; 121 | } 122 | 123 | if (argc != 5) 124 | { 125 | Usage(); 126 | return(1); 127 | } 128 | 129 | if (strcmp(argv[2], "Upcase") && strcmp(argv[2], "Downcase") && strcmp(argv[2], "Foldcase") 130 | && strcmp(argv[2], "Fullfold") && strcmp(argv[2], "Fullup") 131 | && strcmp(argv[2], "Fulldown")) 132 | { 133 | fprintf(stderr, 134 | "error: gencase: expected 'Upcase', 'Downcase', 'Foldcase', 'Fullfold', 'Fullup', or 'Fulldown'\n"); 135 | return(1); 136 | } 137 | 138 | int fcf = (strcmp(argv[2], "Foldcase") == 0 || strcmp(argv[2], "Fullfold") == 0); 139 | int ff = (strcmp(argv[2], "Fullfold") == 0 || strcmp(argv[2], "Fullup") == 0 140 | || strcmp(argv[2], "Fulldown") == 0); 141 | int fdx = atoi(argv[3]); 142 | 143 | unsigned int maxgap = ParseCodePoint(argv[4]); 144 | 145 | FILE * fp = fopen(argv[1], "rt"); 146 | if (fp == 0) 147 | { 148 | fprintf(stderr, "error: gencase: unable to open %s\n", argv[1]); 149 | return(1); 150 | } 151 | 152 | while (fgets(s, sizeof(s), fp)) 153 | { 154 | char * flds[32]; 155 | 156 | if (*s != '#' && *s != '\n') 157 | { 158 | int nflds = ParseFields(s, flds); 159 | 160 | if (fcf) 161 | { 162 | if (ff) 163 | { 164 | if (*flds[1] != 'F') 165 | continue; 166 | } 167 | else if (*flds[1] != 'C' && *flds[1] != 'S') 168 | continue; 169 | } 170 | 171 | if (nflds > 5 && (strcmp(argv[2], "Fullup") == 0 || strcmp(argv[2], "Fulldown") == 0)) 172 | continue; 173 | 174 | if (fdx >= nflds) 175 | { 176 | fprintf(stderr, "error: gencase: too large: %d\n", fdx); 177 | return(1); 178 | } 179 | 180 | if (*flds[fdx]) 181 | { 182 | unsigned int idx = ParseCodePoint(flds[0]); 183 | 184 | if (ff) 185 | { 186 | FullMap[idx].Count = ParseSeveralPoints(flds[fdx], FullMap[idx].Chars); 187 | Map[idx] = FullMap[idx].Chars[0]; 188 | 189 | if (FullMap[idx].Count == 0) 190 | { 191 | fprintf(stderr, "error: gencase: unexpected full mapping: 0x%04x\n", idx); 192 | return(1); 193 | } 194 | } 195 | else 196 | { 197 | unsigned int val = ParseCodePoint(flds[fdx]); 198 | Map[idx] = val; 199 | } 200 | } 201 | } 202 | } 203 | 204 | unsigned int Start[128]; 205 | unsigned int End[128]; 206 | unsigned int cnt = 0; 207 | 208 | unsigned int tot = 0; 209 | unsigned int idx = 0; 210 | while (idx < 0x110000) 211 | { 212 | while (Map[idx] == idx) 213 | { 214 | idx += 1; 215 | if (idx == 0x110000) 216 | break; 217 | } 218 | 219 | unsigned int strt = idx; 220 | unsigned int end; 221 | unsigned int gap = 0; 222 | for (; idx < 0x110000; idx++) 223 | { 224 | if (Map[idx] == idx) 225 | { 226 | gap += 1; 227 | if (gap > maxgap) 228 | break; 229 | } 230 | else 231 | { 232 | end = idx; 233 | gap = 0; 234 | } 235 | } 236 | 237 | if (idx < 0x110000) 238 | { 239 | Start[cnt] = strt; 240 | End[cnt] = end; 241 | cnt += 1; 242 | 243 | fprintf(stderr, "0x%04x --> 0x%04x [%d]\n", strt, end, end - strt); 244 | tot += (end - strt); 245 | } 246 | } 247 | 248 | // printf("%d\n", tot); 249 | 250 | if (ff) 251 | { 252 | printf("#ifndef __FFULLCASE__\n"); 253 | printf("#define __FFULLCASE__\n"); 254 | printf("typedef struct {unsigned int Count; FCh Chars[3];} FFullCase;\n"); 255 | printf("#endif\n\n"); 256 | 257 | unsigned int fdx = 0; 258 | 259 | printf("static const unsigned int %sSet[] =\n{\n", argv[2]); 260 | 261 | while (fdx <= 0x1FFF) 262 | { 263 | unsigned int msk = 0; 264 | 265 | for (int idx = 0; idx < 32; idx++) 266 | if (FullMap[fdx + idx].Count > 1) 267 | msk |= (1 << idx); 268 | 269 | if (msk == 0) 270 | printf(" 0x0, // 0x%04x\n", fdx); 271 | else 272 | printf(" 0x%08x, // 0x%04x\n", msk, fdx); 273 | fdx += 32; 274 | } 275 | 276 | printf(" 0x0\n};\n\n"); 277 | 278 | for (unsigned int cdx = 0; cdx < cnt; cdx++) 279 | { 280 | printf("static FFullCase %s0x%04xTo0x%04x[] =\n{\n", argv[2], Start[cdx], End[cdx]); 281 | 282 | for (idx = Start[cdx]; idx < End[cdx]; idx++) 283 | printf(" {%d, {0x%04x, 0x%04x, 0x%04x}}, // 0x%04x\n", FullMap[idx].Count, 284 | FullMap[idx].Chars[0], FullMap[idx].Chars[1], FullMap[idx].Chars[2], idx); 285 | printf(" {%d, {0x%04x, 0x%04x, 0x%04x}} // 0x%04x\n};\n\n", FullMap[idx].Count, 286 | FullMap[idx].Chars[0], FullMap[idx].Chars[1], FullMap[idx].Chars[2], idx); 287 | } 288 | } 289 | else 290 | { 291 | for (unsigned int cdx = 0; cdx < cnt; cdx++) 292 | { 293 | printf("static const FCh %s0x%04x[] =\n{\n", argv[2], Start[cdx]); 294 | 295 | for (idx = Start[cdx]; idx < End[cdx]; idx++) 296 | printf(" 0x%04x, // 0x%04x\n", Map[idx], idx); 297 | printf(" 0x%04x // 0x%04x\n};\n\n", Map[idx], idx); 298 | } 299 | 300 | printf("FCh Char%s(FCh ch)\n{\n", argv[2]); 301 | for (unsigned int cdx = 0; cdx < cnt; cdx++) 302 | { 303 | printf(" if (ch <= 0x%04x)\n {\n", End[cdx]); 304 | printf(" if (ch >= 0x%04x)\n", Start[cdx]); 305 | printf(" return(%s0x%04x[ch - 0x%04x]);\n", argv[2], Start[cdx], Start[cdx]); 306 | printf(" return(ch);\n }\n"); 307 | } 308 | printf(" return(ch);\n}\n\n"); 309 | } 310 | 311 | fclose(fp); 312 | return(0); 313 | } 314 | -------------------------------------------------------------------------------- /unidata/gencrng.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Generate character ranges for a char-set 4 | 5 | gencrng | + ... 6 | 7 | */ 8 | 9 | #define _CRT_SECURE_NO_WARNINGS 10 | #include 11 | #include 12 | #include 13 | 14 | #define MAX_FULL_CHARS 3 15 | 16 | int ParseFields(char * s, char ** flds) 17 | { 18 | int nflds = 0; 19 | 20 | for (;;) 21 | { 22 | char * f = strchr(s, ';'); 23 | 24 | while (*s == ' ') 25 | s += 1; 26 | 27 | if (*s == 0) 28 | flds[nflds] = 0; 29 | else 30 | flds[nflds] = s; 31 | 32 | nflds += 1; 33 | if (f == 0) 34 | break; 35 | 36 | *f = 0; 37 | s = f + 1; 38 | } 39 | 40 | return(nflds); 41 | } 42 | 43 | unsigned int ParseCodePoint(char * fld) 44 | { 45 | char * s = fld; 46 | unsigned int n = 0; 47 | 48 | while (*fld) 49 | { 50 | if (*fld >= '0' && *fld <= '9') 51 | n = n * 16 + *fld - '0'; 52 | else if (*fld >= 'a' && *fld <= 'f') 53 | n = n * 16 + *fld - 'a' + 10; 54 | else if (*fld >= 'A' && *fld <= 'F') 55 | n = n * 16 + *fld - 'A' + 10; 56 | else 57 | { 58 | fprintf(stderr, "error: gencrng: unable to parse field: %s\n", s); 59 | return(0); 60 | } 61 | 62 | fld += 1; 63 | } 64 | 65 | return(n); 66 | } 67 | 68 | void Usage() 69 | { 70 | fprintf(stderr, "usage: gencrng | ...\n"); 71 | } 72 | 73 | typedef struct 74 | { 75 | unsigned int Start; 76 | unsigned int End; // Inclusive 77 | } CharRange; 78 | 79 | CharRange Ranges[0x110000]; 80 | unsigned int NumRanges = 0; 81 | 82 | void AddCh(unsigned int ch) 83 | { 84 | if (NumRanges == 0 || Ranges[NumRanges - 1].End + 1 < ch) 85 | { 86 | Ranges[NumRanges].Start = ch; 87 | Ranges[NumRanges].End = ch; 88 | NumRanges += 1; 89 | } 90 | else 91 | Ranges[NumRanges-1].End += 1; 92 | } 93 | 94 | int main(int argc, char * argv[]) 95 | { 96 | char s[256]; 97 | 98 | if (argc < 4) 99 | { 100 | Usage(); 101 | return(1); 102 | } 103 | 104 | FILE * fp = fopen(argv[1], "rt"); 105 | if (fp == 0) 106 | { 107 | fprintf(stderr, "error: gencrng: unable to open %s\n", argv[1]); 108 | return(1); 109 | } 110 | 111 | while (fgets(s, sizeof(s), fp)) 112 | { 113 | char * flds[32]; 114 | 115 | if (*s != '#' && *s != '\n') 116 | { 117 | int nflds = ParseFields(s, flds); 118 | if (nflds < 3) 119 | { 120 | fprintf(stderr, "error: gencrng: not enough fields %s\n", flds[0]); 121 | return(1); 122 | } 123 | 124 | for (int adx = 3; adx < argc; adx++) 125 | if (strcmp(argv[adx], flds[2]) == 0 || 126 | (argv[adx][0] == '+' && strcmp(argv[adx] + 1, flds[0]) == 0)) 127 | { 128 | AddCh(ParseCodePoint(flds[0])); 129 | break; 130 | } 131 | } 132 | } 133 | 134 | fclose(fp); 135 | 136 | printf("\nstatic FCharRange %s[%d] =\n{\n", argv[2], NumRanges); 137 | for (unsigned int ndx = 0; ndx < NumRanges; ndx++) 138 | printf(" {0x%x, 0x%x}, // %d\n", Ranges[ndx].Start, Ranges[ndx].End, 139 | Ranges[ndx].End - Ranges[ndx].Start + 1); 140 | printf("};\n"); 141 | 142 | return(0); 143 | } 144 | -------------------------------------------------------------------------------- /unidata/genul.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Generate UpperCase, and LowerCase unicode character ranges 4 | 5 | genul 6 | 7 | */ 8 | 9 | #define _CRT_SECURE_NO_WARNINGS 10 | #include 11 | #include 12 | #include 13 | 14 | int ParseFields(char * s, char ** flds) 15 | { 16 | int nflds = 0; 17 | 18 | for (;;) 19 | { 20 | char * f = strchr(s, ';'); 21 | 22 | while (*s == ' ') 23 | s += 1; 24 | 25 | if (*s == 0) 26 | flds[nflds] = 0; 27 | else 28 | flds[nflds] = s; 29 | 30 | nflds += 1; 31 | if (f == 0) 32 | break; 33 | 34 | *f = 0; 35 | s = f + 1; 36 | } 37 | 38 | return(nflds); 39 | } 40 | 41 | typedef struct 42 | { 43 | unsigned int Start; 44 | unsigned int End; // Inclusive 45 | } CharRange; 46 | 47 | CharRange Ranges[0x110000]; 48 | unsigned int NumRanges = 0; 49 | 50 | void AddRange(char * fld) 51 | { 52 | unsigned int strt = 0; 53 | unsigned int end = 0; 54 | 55 | while (*fld) 56 | { 57 | if (*fld >= '0' && *fld <= '9') 58 | strt = strt * 16 + *fld - '0'; 59 | else if (*fld >= 'a' && *fld <= 'f') 60 | strt = strt * 16 + *fld - 'a' + 10; 61 | else if (*fld >= 'A' && *fld <= 'F') 62 | strt = strt * 16 + *fld - 'A' + 10; 63 | else 64 | break; 65 | 66 | fld += 1; 67 | } 68 | 69 | if (*fld == '.') 70 | { 71 | fld += 2; 72 | 73 | while (*fld) 74 | { 75 | if (*fld >= '0' && *fld <= '9') 76 | end = end * 16 + *fld - '0'; 77 | else if (*fld >= 'a' && *fld <= 'f') 78 | end = end * 16 + *fld - 'a' + 10; 79 | else if (*fld >= 'A' && *fld <= 'F') 80 | end = end * 16 + *fld - 'A' + 10; 81 | else 82 | break; 83 | 84 | fld += 1; 85 | } 86 | } 87 | 88 | if (end == 0) 89 | end = strt; 90 | 91 | Ranges[NumRanges].Start = strt; 92 | Ranges[NumRanges].End = end; 93 | NumRanges += 1; 94 | } 95 | 96 | int MatchField(char * fld, char * s) 97 | { 98 | char * r = strstr(fld, s); 99 | if (r == 0) 100 | return(0); 101 | 102 | if (r > fld && *(r - 1) != ' ') 103 | return(0); 104 | 105 | r += strlen(s); 106 | if (*r == ' ' || *r == 0) 107 | return(1); 108 | 109 | return(0); 110 | } 111 | 112 | void Usage() 113 | { 114 | fprintf(stderr, "usage: genul \n"); 115 | } 116 | 117 | int main(int argc, char * argv[]) 118 | { 119 | char s[256]; 120 | 121 | if (argc != 4) 122 | { 123 | Usage(); 124 | return(1); 125 | } 126 | 127 | FILE * fp = fopen(argv[1], "rt"); 128 | if (fp == 0) 129 | { 130 | fprintf(stderr, "error: genul: unable to open %s\n", argv[1]); 131 | return(1); 132 | } 133 | 134 | while (fgets(s, sizeof(s), fp)) 135 | { 136 | char * flds[32]; 137 | 138 | if (*s != '#' && *s != '\n') 139 | { 140 | int nflds = ParseFields(s, flds); 141 | 142 | if (nflds == 2 && MatchField(flds[1], argv[3])) 143 | AddRange(flds[0]); 144 | } 145 | } 146 | fclose(fp); 147 | 148 | printf("\nstatic FCharRange %s[%d] =\n{\n", argv[2], NumRanges); 149 | for (unsigned int ndx = 0; ndx < NumRanges; ndx++) 150 | printf(" {0x%x, 0x%x}, // %d\n", Ranges[ndx].Start, Ranges[ndx].End, 151 | Ranges[ndx].End - Ranges[ndx].Start + 1); 152 | printf("};\n"); 153 | 154 | return(0); 155 | } 156 | -------------------------------------------------------------------------------- /unidata/makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Generate unicode data and code 3 | # 4 | 5 | BUILD_CXX ?= g++ 6 | BUILD_FLAGS := -ggdb -Wall 7 | 8 | .PHONY: all 9 | all: debug unicase unicrng 10 | 11 | .PHONY: code 12 | code: debug/gencase debug/gencrng debug/genul 13 | 14 | .PHONY: clean 15 | clean: debug 16 | -rm -R debug/* 17 | 18 | unicrng: debug/gencrng debug/genul 19 | -rm ../src/unicrng.hpp 20 | @echo "/*\n\ 21 | \n\ 22 | Foment\n\ 23 | \n\ 24 | */\n\ 25 | \n\ 26 | // Automatically generated unicode character ranges included by charsets.cpp."\ 27 | > ../src/unicrng.hpp 28 | debug/genul DerivedCoreProperties.txt LowerCaseCharRange Lowercase >> ../src/unicrng.hpp 29 | debug/genul DerivedCoreProperties.txt UpperCaseCharRange Uppercase >> ../src/unicrng.hpp 30 | debug/gencrng UnicodeData.txt TitleCaseCharRange Lt >> ../src/unicrng.hpp 31 | debug/genul DerivedCoreProperties.txt LetterCharRange Alphabetic >> ../src/unicrng.hpp 32 | debug/gencrng UnicodeData.txt DigitCharRange Nd >> ../src/unicrng.hpp 33 | debug/gencrng UnicodeData.txt WhitespaceCharRange Zs Zl Zp +0009 +000A +000B +000C +000D \ 34 | >> ../src/unicrng.hpp 35 | debug/gencrng UnicodeData.txt PunctuationCharRange Pc Pd Ps Pe Pi Pf Po >> ../src/unicrng.hpp 36 | debug/gencrng UnicodeData.txt SymbolCharRange Sm Sc Sk So >> ../src/unicrng.hpp 37 | debug/gencrng UnicodeData.txt BlankCharRange Zs +0009 >> ../src/unicrng.hpp 38 | 39 | unicase: debug/gencase 40 | -rm ../src/unicase.hpp 41 | @echo "/*\n\ 42 | \n\ 43 | Foment\n\ 44 | \n\ 45 | */\n\ 46 | \n\ 47 | // Automatically generated unicode data and code included by unicode.cpp.\n" > ../src/unicase.hpp 48 | debug/gencase UnicodeData.txt Upcase 12 50 >> ../src/unicase.hpp 49 | debug/gencase UnicodeData.txt Downcase 13 50 >> ../src/unicase.hpp 50 | debug/gencase CaseFolding.txt Foldcase 2 50 >> ../src/unicase.hpp 51 | debug/gencase CaseFolding.txt Fullfold 2 20 >> ../src/unicase.hpp 52 | debug/gencase SpecialCasing.txt Fullup 3 20 >> ../src/unicase.hpp 53 | 54 | debug: 55 | -mkdir debug 56 | 57 | debug/%: ./%.cpp 58 | $(BUILD_CXX) $(BUILD_FLAGS) -o $@ $< 59 | -------------------------------------------------------------------------------- /unix/makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Foment 3 | # 4 | 5 | CXX ?= g++ 6 | BUILD_CXX ?= g++ 7 | 8 | TEST_OPTIONS = --check-heap --zero-heap 9 | TEST_BUILD = debug 10 | 11 | # FOMENT_LITTLE_ENDIAN is defined in foment.hpp as 1, 12 | # EXCEPT if already defined. So if FOMENT_BIG_ENDIAN was 13 | # set when calling make, we define FOMENT_LITTLE_ENDIAN=0 14 | ifdef FOMENT_BIG_ENDIAN 15 | CFLAGS += -DFOMENT_LITTLE_ENDIAN=0 16 | endif 17 | 18 | CFLAGS += -c -Wall -DFOMENT_UNIX -std=c++2a 19 | 20 | CCDEBUG := -ggdb -DFOMENT_DEBUG $(CFLAGS) 21 | CCRELEASE := $(CFLAGS) 22 | CCPROFILE := -pg $(CCRELEASE) 23 | 24 | .PHONY: all 25 | all: debug release debug/genprops debug/foment release/foment 26 | 27 | .PHONY: prof 28 | prof: profile profile/foment 29 | 30 | .PHONY: install 31 | install: all 32 | sudo cp release/foment /usr/local/bin 33 | 34 | .PHONY: clean 35 | clean: debug release profile 36 | -rm debug/* 37 | -rm release/* 38 | -rm profile/* 39 | 40 | .PHONY: test 41 | test: all foment-test stress-test chibi-test process-test threads-test 42 | 43 | .PHONY: test-all 44 | test-all: all 45 | $(MAKE) test TEST_BUILD=debug TEST_OPTIONS=--no-collector 46 | $(MAKE) test TEST_BUILD=release TEST_OPTIONS=--no-collector 47 | $(MAKE) test TEST_BUILD=debug TEST_OPTIONS=--mark-sweep 48 | $(MAKE) test TEST_BUILD=release TEST_OPTIONS=--mark-sweep 49 | $(MAKE) test TEST_BUILD=debug "TEST_OPTIONS=--no-collector --check-heap --zero-heap" 50 | $(MAKE) test TEST_BUILD=release "TEST_OPTIONS=--no-collector --check-heap --zero-heap" 51 | $(MAKE) test TEST_BUILD=debug "TEST_OPTIONS=--mark-sweep --check-heap --zero-heap" 52 | $(MAKE) test TEST_BUILD=release "TEST_OPTIONS=--mark-sweep --check-heap --zero-heap" 53 | 54 | .PHONY: foment-test 55 | foment-test: all 56 | cd ../test ; ../unix/$(TEST_BUILD)/foment $(TEST_OPTIONS) runtests.scm r7rs.scm r7rs-eval.scm foment.scm eccentric.scm r5rs_pitfall.scm unicode.scm srfi.scm 57 | cd ../test ; ../unix/$(TEST_BUILD)/foment $(TEST_OPTIONS) r7rs.scm 58 | 59 | .PHONY: stress-test 60 | stress-test: all 61 | cd ../test ; ../unix/$(TEST_BUILD)/foment $(TEST_OPTIONS) runtests.scm stress.scm r7rs.scm 62 | 63 | .PHONY: chibi-test 64 | chibi-test: all 65 | cd ../test ; ../unix/$(TEST_BUILD)/foment $(TEST_OPTIONS) r7rs-tests.scm 66 | 67 | .PHONY: process-test 68 | process-test: all debug/stdread debug/stdwrite debug/exitcode debug/hang 69 | export PATH=../unix/debug:"$$PATH" ; cd ../test ; ../unix/$(TEST_BUILD)/foment $(TEST_OPTIONS) runtests.scm process.scm 70 | 71 | .PHONY: threads-test 72 | threads-test: all 73 | cd ../test ; ../unix/$(TEST_BUILD)/foment $(TEST_OPTIONS) runtests.scm threads.scm 74 | 75 | .PHONY: threads-gdb 76 | threads-gdb: all 77 | cd ../test ; gdb --args ../unix/$(TEST_BUILD)/foment $(TEST_OPTIONS) runtests.scm threads.scm 78 | 79 | .PHONY: srfi-test 80 | srfi-test: all 81 | cd ../test ; ../unix/$(TEST_BUILD)/foment $(TEST_OPTIONS) runtests.scm srfi.scm 82 | 83 | debug: 84 | -mkdir debug 85 | 86 | release: 87 | -mkdir release 88 | 89 | profile: 90 | -mkdir profile 91 | 92 | debug/base.cpp: debug/txt2cpp makefile ../src/base.scm ../src/srfi-106.scm ../src/srfi-60.scm\ 93 | ../src/srfi-1.scm ../src/srfi-128.scm ../src/srfi-125.scm ../src/srfi-133.scm\ 94 | ../src/srfi-14.scm ../src/srfi-193.scm ../src/srfi-151.scm ../src/srfi-166.scm\ 95 | ../src/srfi-207.scm 96 | debug/txt2cpp debug/base.cpp ../src/base.scm ../src/srfi-106.scm ../src/srfi-60.scm\ 97 | ../src/srfi-1.scm ../src/srfi-128.scm ../src/srfi-125.scm ../src/srfi-133.scm\ 98 | ../src/srfi-14.scm ../src/srfi-193.scm ../src/srfi-151.scm ../src/srfi-166.scm\ 99 | ../src/srfi-207.scm 100 | 101 | debug/foment: debug/foment.o debug/gc.o debug/syncthrd.o debug/compile.o debug/io.o\ 102 | debug/synrules.o debug/synpass.o debug/midpass.o debug/genpass.o\ 103 | debug/pairs.o debug/unicode.o debug/chars.o debug/strings.o debug/vectors.o\ 104 | debug/library.o debug/execute.o debug/numbers.o debug/write.o\ 105 | debug/read.o debug/filesys.o debug/compare.o debug/main.o debug/hashtbl.o\ 106 | debug/bignums.o debug/charset.o debug/process.o debug/random.o debug/base.o 107 | git rev-parse --abbrev-ref HEAD > debug/buildprops.out 108 | git rev-parse --short HEAD >> debug/buildprops.out 109 | uname -s -r -v -m >> debug/buildprops.out 110 | g++ -v 2>&1 | tail --lines=1 >> debug/buildprops.out 111 | debug/genprops < debug/buildprops.out > debug/buildprops.cpp 112 | $(CXX) $(CCDEBUG) -o debug/buildprops.o debug/buildprops.cpp 113 | $(CXX) $(LDFLAGS) -o debug/foment $^ debug/buildprops.o -lpthread 114 | 115 | release/foment: release/foment.o release/gc.o release/syncthrd.o release/compile.o release/io.o\ 116 | release/synrules.o release/synpass.o release/midpass.o release/genpass.o\ 117 | release/pairs.o release/unicode.o release/chars.o release/strings.o\ 118 | release/vectors.o release/library.o release/execute.o release/numbers.o\ 119 | release/write.o release/read.o release/filesys.o\ 120 | release/compare.o release/main.o release/hashtbl.o release/bignums.o release/charset.o\ 121 | release/process.o release/random.o release/base.o 122 | git rev-parse --abbrev-ref HEAD > release/buildprops.out 123 | git rev-parse --short HEAD >> release/buildprops.out 124 | uname -s -r -v -m >> release/buildprops.out 125 | g++ -v 2>&1 | tail --lines=1 >> release/buildprops.out 126 | debug/genprops < release/buildprops.out > release/buildprops.cpp 127 | $(CXX) $(CCRELEASE) -o release/buildprops.o release/buildprops.cpp 128 | $(CXX) $(LDFLAGS) -o release/foment $^ release/buildprops.o -lpthread 129 | 130 | profile/foment: profile/foment.o profile/gc.o profile/syncthrd.o profile/compile.o profile/io.o\ 131 | profile/synrules.o profile/synpass.o profile/midpass.o profile/genpass.o\ 132 | profile/pairs.o profile/unicode.o profile/chars.o profile/strings.o\ 133 | profile/vectors.o profile/library.o profile/execute.o profile/numbers.o\ 134 | profile/write.o profile/read.o profile/filesys.o\ 135 | profile/compare.o profile/main.o profile/hashtbl.o profile/bignums.o profile/charset.o\ 136 | profile/process.o profile/random.o profile/base.o 137 | $(CXX) $(LDFLAGS) -pg -o profile/foment $^ -lpthread 138 | 139 | debug/foment.o: ../src/foment.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/unicode.hpp 140 | debug/gc.o: ../src/gc.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp 141 | debug/syncthrd.o: ../src/syncthrd.cpp ../src/foment.hpp ../src/execute.hpp ../src/syncthrd.hpp 142 | debug/compile.o: ../src/compile.cpp ../src/foment.hpp ../src/compile.hpp 143 | debug/synrules.o: ../src/synrules.cpp ../src/foment.hpp ../src/compile.hpp 144 | debug/synpass.o: ../src/synpass.cpp ../src/foment.hpp ../src/compile.hpp 145 | debug/midpass.o: ../src/midpass.cpp ../src/foment.hpp ../src/compile.hpp 146 | debug/genpass.o: ../src/genpass.cpp ../src/foment.hpp ../src/compile.hpp ../src/execute.hpp 147 | debug/pairs.o: ../src/pairs.cpp ../src/foment.hpp 148 | debug/unicode.o: ../src/unicode.cpp ../src/foment.hpp ../src/unicode.hpp ../src/unicase.hpp 149 | debug/chars.o: ../src/chars.cpp ../src/foment.hpp ../src/unicode.hpp 150 | debug/strings.o: ../src/strings.cpp ../src/foment.hpp ../src/unicode.hpp 151 | debug/vectors.o: ../src/vectors.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 152 | ../src/unicode.hpp 153 | debug/library.o: ../src/library.cpp ../src/foment.hpp ../src/compile.hpp 154 | debug/execute.o: ../src/execute.cpp ../src/foment.hpp ../src/execute.hpp ../src/syncthrd.hpp 155 | debug/numbers.o: ../src/numbers.cpp ../src/foment.hpp ../src/unicode.hpp ../src/bignums.hpp 156 | debug/bignums.o: ../src/bignums.cpp ../src/foment.hpp ../src/unicode.hpp ../src/bignums.hpp 157 | debug/charset.o: ../src/charset.cpp ../src/foment.hpp ../src/unicode.hpp ../src/unicrng.hpp 158 | debug/process.o: ../src/process.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 159 | ../src/unicode.hpp 160 | debug/io.o: ../src/io.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 161 | ../src/unicode.hpp 162 | debug/write.o: ../src/write.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 163 | ../src/compile.hpp 164 | debug/read.o: ../src/read.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 165 | ../src/unicode.hpp 166 | debug/filesys.o: ../src/filesys.cpp ../src/foment.hpp ../src/unicode.hpp 167 | debug/hashtbl.o: ../src/hashtbl.cpp ../src/foment.hpp ../src/syncthrd.hpp 168 | debug/compare.o: ../src/compare.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/unicode.hpp 169 | debug/random.o: ../src/random.cpp ../src/foment.hpp 170 | debug/main.o: ../src/main.cpp ../src/foment.hpp 171 | debug/base.o: debug/base.cpp 172 | 173 | release/foment.o: ../src/foment.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/unicode.hpp 174 | release/gc.o: ../src/gc.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp 175 | release/syncthrd.o: ../src/syncthrd.cpp ../src/foment.hpp ../src/execute.hpp ../src/syncthrd.hpp 176 | release/compile.o: ../src/compile.cpp ../src/foment.hpp ../src/compile.hpp 177 | release/synrules.o: ../src/synrules.cpp ../src/foment.hpp ../src/compile.hpp 178 | release/synpass.o: ../src/synpass.cpp ../src/foment.hpp ../src/compile.hpp 179 | release/midpass.o: ../src/midpass.cpp ../src/foment.hpp ../src/compile.hpp 180 | release/genpass.o: ../src/genpass.cpp ../src/foment.hpp ../src/compile.hpp ../src/execute.hpp 181 | release/pairs.o: ../src/pairs.cpp ../src/foment.hpp 182 | release/unicode.o: ../src/unicode.cpp ../src/foment.hpp ../src/unicode.hpp ../src/unicase.hpp 183 | release/chars.o: ../src/chars.cpp ../src/foment.hpp ../src/unicode.hpp 184 | release/strings.o: ../src/strings.cpp ../src/foment.hpp ../src/unicode.hpp 185 | release/vectors.o: ../src/vectors.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 186 | ../src/unicode.hpp 187 | release/library.o: ../src/library.cpp ../src/foment.hpp ../src/compile.hpp 188 | release/execute.o: ../src/execute.cpp ../src/foment.hpp ../src/execute.hpp ../src/syncthrd.hpp 189 | release/numbers.o: ../src/numbers.cpp ../src/foment.hpp ../src/unicode.hpp ../src/bignums.hpp 190 | release/bignums.o: ../src/bignums.cpp ../src/foment.hpp ../src/unicode.hpp ../src/bignums.hpp 191 | release/charset.o: ../src/charset.cpp ../src/foment.hpp ../src/unicode.hpp ../src/unicrng.hpp 192 | release/process.o: ../src/process.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 193 | ../src/unicode.hpp 194 | release/io.o: ../src/io.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 195 | ../src/unicode.hpp 196 | release/write.o: ../src/write.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 197 | ../src/compile.hpp 198 | release/read.o: ../src/read.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/io.hpp\ 199 | ../src/unicode.hpp 200 | release/filesys.o: ../src/filesys.cpp ../src/foment.hpp ../src/unicode.hpp 201 | release/hashtbl.o: ../src/hashtbl.cpp ../src/foment.hpp ../src/syncthrd.hpp 202 | release/compare.o: ../src/compare.cpp ../src/foment.hpp ../src/syncthrd.hpp ../src/unicode.hpp 203 | release/random.o: ../src/random.cpp ../src/foment.hpp 204 | release/main.o: ../src/main.cpp ../src/foment.hpp 205 | release/base.o: debug/base.cpp 206 | 207 | debug/%.o: %.cpp 208 | $(CXX) $(CCDEBUG) -I ../src -o $@ $< 209 | 210 | debug/%.o: ../src/%.cpp 211 | $(CXX) $(CCDEBUG) -I ../src -o $@ $< 212 | 213 | debug/%.o: debug/%.cpp 214 | $(CXX) $(CCDEBUG) -I ../src -o $@ $< 215 | 216 | release/%.o: %.cpp 217 | $(CXX) $(CCRELEASE) -I ../src -o $@ $< 218 | 219 | release/%.o: ../src/%.cpp 220 | $(CXX) $(CCRELEASE) -I ../src -o $@ $< 221 | 222 | release/%.o: debug/%.cpp 223 | $(CXX) $(CCRELEASE) -I ../src -o $@ $< 224 | 225 | profile/%.o: %.cpp 226 | $(CXX) $(CCPROFILE) -I ../src -o $@ $< 227 | 228 | profile/%.o: ../src/%.cpp 229 | $(CXX) $(CCPROFILE) -I ../src -o $@ $< 230 | 231 | profile/%.o: debug/%.cpp 232 | $(CXX) $(CCPROFILE) -I ../src -o $@ $< 233 | 234 | debug/%: ../test/%.cpp 235 | $(BUILD_CXX) $(CCDEBUG) -o debug/$*.o $< 236 | $(BUILD_CXX) debug/$*.o -o $@ 237 | 238 | debug/txt2cpp: ../src/txt2cpp.cpp 239 | $(BUILD_CXX) $(CCDEBUG) ../src/txt2cpp.cpp -o debug/txt2cpp.o 240 | $(BUILD_CXX) debug/txt2cpp.o -o debug/txt2cpp 241 | 242 | debug/genprops: ../src/genprops.cpp 243 | $(BUILD_CXX) $(CCDEBUG) ../src/genprops.cpp -o debug/genprops.o 244 | $(BUILD_CXX) debug/genprops.o -o debug/genprops 245 | 246 | -------------------------------------------------------------------------------- /windows/.gitignore: -------------------------------------------------------------------------------- 1 | foment.history 2 | *.pdb 3 | -------------------------------------------------------------------------------- /windows/makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Foment 3 | # 4 | 5 | PATH = $(PATH);../windows/debug 6 | 7 | TEST_OPTIONS = --check-heap --zero-heap 8 | TEST_BUILD = debug 9 | 10 | CLDEBUG = /nologo /MD /W3 /EHsc /Zi /Od /c /Fodebug\ /DFOMENT_DEBUG /DFOMENT_WINDOWS /std:c++latest 11 | CLRELEASE = /nologo /MD /W3 /Ox /Zi /GA /EHsc /Forelease\ /c /DFOMENT_WINDOWS /std:c++latest 12 | 13 | LIBS = ws2_32.lib iphlpapi.lib 14 | 15 | all: debug release debug\genprops.exe debug\foment.exe release\foment.exe\ 16 | debug\stdread.exe debug\stdwrite.exe debug\exitcode.exe debug\hang.exe makefile 17 | 18 | clean: debug release 19 | del /Q debug\* 20 | del /Q release\* 21 | 22 | test: all foment-test stress-test chibi-test process-test threads-test 23 | 24 | test-all: all test-no-collector test-mark-sweep 25 | 26 | test-no-collector: all 27 | $(MAKE) test TEST_BUILD=debug TEST_OPTIONS=--no-collector 28 | $(MAKE) test TEST_BUILD=release TEST_OPTIONS=--no-collector 29 | $(MAKE) test TEST_BUILD=debug "TEST_OPTIONS=--no-collector --check-heap --zero-heap" 30 | $(MAKE) test TEST_BUILD=release "TEST_OPTIONS=--no-collector --check-heap --zero-heap" 31 | 32 | test-mark-sweep: all 33 | $(MAKE) test TEST_BUILD=debug TEST_OPTIONS=--mark-sweep 34 | $(MAKE) test TEST_BUILD=release TEST_OPTIONS=--mark-sweep 35 | $(MAKE) test TEST_BUILD=debug "TEST_OPTIONS=--mark-sweep --check-heap --zero-heap" 36 | $(MAKE) test TEST_BUILD=release "TEST_OPTIONS=--mark-sweep --check-heap --zero-heap" 37 | 38 | foment-test: all 39 | cd ..\test 40 | ..\windows\$(TEST_BUILD)\foment $(TEST_OPTIONS) runtests.scm r7rs.scm r7rs-eval.scm foment.scm\ 41 | eccentric.scm r5rs_pitfall.scm unicode.scm srfi.scm 42 | ..\windows\$(TEST_BUILD)\foment $(TEST_OPTIONS) r7rs.scm 43 | 44 | stress-test: all 45 | cd ..\test 46 | ..\windows\$(TEST_BUILD)\foment $(TEST_OPTIONS) runtests.scm stress.scm r7rs.scm 47 | 48 | chibi-test: all 49 | cd ..\test 50 | ..\windows\$(TEST_BUILD)\foment $(TEST_OPTIONS) runtests.scm stress.scm r7rs-tests.scm 51 | 52 | process-test: all 53 | cd ..\test 54 | ..\windows\$(TEST_BUILD)\foment $(TEST_OPTIONS) runtests.scm process.scm 55 | 56 | threads-test: all 57 | cd ..\test 58 | ..\windows\$(TEST_BUILD)\foment $(TEST_OPTIONS) runtests.scm threads.scm 59 | 60 | debug: 61 | -mkdir debug 62 | 63 | release: 64 | -mkdir release 65 | 66 | debug\base.cpp: debug\txt2cpp.exe makefile ..\src\base.scm ..\src\srfi-106.scm ..\src\srfi-60.scm\ 67 | ..\src\srfi-1.scm ..\src\srfi-128.scm ..\src\srfi-125.scm ..\src\srfi-133.scm\ 68 | ..\src\srfi-14.scm ..\src\srfi-193.scm ..\src\srfi-151.scm ..\src\srfi-166.scm\ 69 | ..\src\srfi-207.scm 70 | debug\txt2cpp debug\base.cpp ..\src\base.scm ..\src\srfi-106.scm ..\src\srfi-60.scm\ 71 | ..\src\srfi-1.scm ..\src\srfi-128.scm ..\src\srfi-125.scm ..\src\srfi-133.scm\ 72 | ..\src\srfi-14.scm ..\src\srfi-193.scm ..\src\srfi-151.scm ..\src\srfi-166.scm\ 73 | ..\src\srfi-207.scm 74 | 75 | debug\foment.exe: debug\foment.obj debug\gc.obj debug\syncthrd.obj debug\compile.obj debug\io.obj\ 76 | debug\synrules.obj debug\synpass.obj debug\midpass.obj debug\genpass.obj\ 77 | debug\pairs.obj debug\unicode.obj debug\chars.obj debug\strings.obj debug\vectors.obj\ 78 | debug\library.obj debug\execute.obj debug\numbers.obj debug\write.obj\ 79 | debug\read.obj debug\filesys.obj debug\compare.obj debug\main.obj debug\hashtbl.obj\ 80 | debug\bignums.obj debug\charset.obj debug\process.obj debug\random.obj debug\base.obj 81 | git rev-parse --abbrev-ref HEAD > debug\buildprops.out 82 | git rev-parse --short HEAD >> debug\buildprops.out 83 | ver >> debug\buildprops.out 84 | cl > nul 2>> debug\buildprops.out 85 | debug\genprops.exe < debug\buildprops.out > debug\buildprops.cpp 86 | cl $(CLDEBUG) debug\buildprops.cpp 87 | link /nologo /subsystem:console /out:debug\foment.exe /debug /pdb:debug\foment.pdb\ 88 | /largeaddressaware $** debug\buildprops.obj $(LIBS) 89 | 90 | release\foment.exe: release\foment.obj release\gc.obj release\syncthrd.obj release\compile.obj\ 91 | release\io.obj release\synrules.obj release\synpass.obj release\midpass.obj\ 92 | release\genpass.obj release\pairs.obj release\unicode.obj release\chars.obj\ 93 | release\strings.obj release\vectors.obj release\library.obj release\execute.obj\ 94 | release\numbers.obj release\write.obj release\read.obj\ 95 | release\filesys.obj release\compare.obj release\main.obj release\hashtbl.obj\ 96 | release\bignums.obj release\charset.obj release\process.obj release\random.obj\ 97 | release\base.obj 98 | git rev-parse --abbrev-ref HEAD > release\buildprops.out 99 | git rev-parse --short HEAD >> release\buildprops.out 100 | ver >> release\buildprops.out 101 | cl > nul 2>> release\buildprops.out 102 | debug\genprops.exe < release\buildprops.out > release\buildprops.cpp 103 | cl $(CLRELEASE) release\buildprops.cpp 104 | # link /nologo /subsystem:console /out:release\foment.exe $** 105 | link /nologo /subsystem:console /out:release\foment.exe /debug /pdb:release\foment.pdb\ 106 | /largeaddressaware $** release\buildprops.obj $(LIBS) 107 | 108 | debug\txt2cpp.exe: debug\txt2cpp.obj 109 | link /nologo /subsystem:console /out:debug\txt2cpp.exe debug\txt2cpp.obj 110 | 111 | debug\stdread.exe: debug\stdread.obj 112 | link /nologo /subsystem:console /out:debug\stdread.exe debug\stdread.obj 113 | 114 | debug\stdwrite.exe: debug\stdwrite.obj 115 | link /nologo /subsystem:console /out:debug\stdwrite.exe debug\stdwrite.obj 116 | 117 | debug\exitcode.exe: debug\exitcode.obj 118 | link /nologo /subsystem:console /out:debug\exitcode.exe debug\exitcode.obj 119 | 120 | debug\hang.exe: debug\hang.obj 121 | link /nologo /subsystem:console /out:debug\hang.exe debug\hang.obj 122 | 123 | debug\genprops.exe: debug\genprops.obj 124 | link /nologo /subsystem:console /out:debug\genprops.exe debug\genprops.obj 125 | 126 | debug\foment.obj: ..\src\foment.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\unicode.hpp 127 | debug\gc.obj: ..\src\gc.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp 128 | debug\syncthrd.obj: ..\src\syncthrd.cpp ..\src\foment.hpp ..\src\execute.hpp ..\src\syncthrd.hpp 129 | debug\compile.obj: ..\src\compile.cpp ..\src\foment.hpp ..\src\compile.hpp 130 | debug\synrules.obj: ..\src\synrules.cpp ..\src\foment.hpp ..\src\compile.hpp 131 | debug\synpass.obj: ..\src\synpass.cpp ..\src\foment.hpp ..\src\compile.hpp 132 | debug\midpass.obj: ..\src\midpass.cpp ..\src\foment.hpp ..\src\compile.hpp 133 | debug\genpass.obj: ..\src\genpass.cpp ..\src\foment.hpp ..\src\compile.hpp ..\src\execute.hpp 134 | debug\pairs.obj: ..\src\pairs.cpp ..\src\foment.hpp 135 | debug\unicode.obj: ..\src\unicode.cpp ..\src\foment.hpp ..\src\unicode.hpp ..\src\unicase.hpp 136 | debug\chars.obj: ..\src\chars.cpp ..\src\foment.hpp ..\src\unicode.hpp 137 | debug\strings.obj: ..\src\strings.cpp ..\src\foment.hpp ..\src\unicode.hpp 138 | debug\vectors.obj: ..\src\vectors.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp\ 139 | ..\src\unicode.hpp 140 | debug\library.obj: ..\src\library.cpp ..\src\foment.hpp ..\src\compile.hpp 141 | debug\execute.obj: ..\src\execute.cpp ..\src\foment.hpp ..\src\execute.hpp ..\src\syncthrd.hpp 142 | debug\numbers.obj: ..\src\numbers.cpp ..\src\foment.hpp ..\src\unicode.hpp ..\src\bignums.hpp 143 | debug\bignums.obj: ..\src\bignums.cpp ..\src\foment.hpp ..\src\unicode.hpp ..\src\bignums.hpp 144 | debug\charset.obj: ..\src\charset.cpp ..\src\foment.hpp ..\src\unicode.hpp ..\src\unicrng.hpp 145 | debug\process.obj: ..\src\process.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp\ 146 | ..\src\unicode.hpp 147 | debug\io.obj: ..\src\io.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp ..\src\unicode.hpp 148 | debug\write.obj: ..\src\write.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp\ 149 | ..\src\compile.hpp 150 | debug\read.obj: ..\src\read.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp\ 151 | ..\src\unicode.hpp 152 | debug\filesys.obj: ..\src\filesys.cpp ..\src\foment.hpp ..\src\unicode.hpp 153 | debug\hashtbl.obj: ..\src\hashtbl.cpp ..\src\foment.hpp ..\src\syncthrd.hpp 154 | debug\compare.obj: ..\src\compare.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\unicode.hpp 155 | debug\main.obj: ..\src\main.cpp ..\src\foment.hpp 156 | debug\random.obj: ..\src\random.cpp ..\src\foment.hpp 157 | debug\base.obj: debug\base.cpp 158 | 159 | release\foment.obj: ..\src\foment.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\unicode.hpp 160 | release\gc.obj: ..\src\gc.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp 161 | release\syncthrd.obj: ..\src\syncthrd.cpp ..\src\foment.hpp ..\src\execute.hpp ..\src\syncthrd.hpp 162 | release\compile.obj: ..\src\compile.cpp ..\src\foment.hpp ..\src\compile.hpp 163 | release\synrules.obj: ..\src\synrules.cpp ..\src\foment.hpp ..\src\compile.hpp 164 | release\synpass.obj: ..\src\synpass.cpp ..\src\foment.hpp ..\src\compile.hpp 165 | release\midpass.obj: ..\src\midpass.cpp ..\src\foment.hpp ..\src\compile.hpp 166 | release\genpass.obj: ..\src\genpass.cpp ..\src\foment.hpp ..\src\compile.hpp ..\src\execute.hpp 167 | release\pairs.obj: ..\src\pairs.cpp ..\src\foment.hpp 168 | release\unicode.obj: ..\src\unicode.cpp ..\src\foment.hpp ..\src\unicode.hpp ..\src\unicase.hpp 169 | release\chars.obj: ..\src\chars.cpp ..\src\foment.hpp ..\src\unicode.hpp 170 | release\strings.obj: ..\src\strings.cpp ..\src\foment.hpp ..\src\unicode.hpp 171 | release\vectors.obj: ..\src\vectors.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp\ 172 | ..\src\unicode.hpp 173 | release\library.obj: ..\src\library.cpp ..\src\foment.hpp ..\src\compile.hpp 174 | release\execute.obj: ..\src\execute.cpp ..\src\foment.hpp ..\src\execute.hpp ..\src\syncthrd.hpp 175 | release\numbers.obj: ..\src\numbers.cpp ..\src\foment.hpp ..\src\unicode.hpp ..\src\bignums.hpp 176 | release\bignums.obj: ..\src\bignums.cpp ..\src\foment.hpp ..\src\unicode.hpp ..\src\bignums.hpp 177 | release\charset.obj: ..\src\charset.cpp ..\src\foment.hpp ..\src\unicode.hpp ..\src\unicrng.hpp 178 | release\process.obj: ..\src\process.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp\ 179 | ..\src\unicode.hpp 180 | release\io.obj: ..\src\io.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp\ 181 | ..\src\unicode.hpp 182 | release\write.obj: ..\src\write.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp\ 183 | ..\src\compile.hpp 184 | release\read.obj: ..\src\read.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\io.hpp\ 185 | ..\src\unicode.hpp 186 | release\filesys.obj: ..\src\filesys.cpp ..\src\foment.hpp ..\src\unicode.hpp 187 | release\hashtbl.obj: ..\src\hashtbl.cpp ..\src\foment.hpp ..\src\syncthrd.hpp 188 | release\compare.obj: ..\src\compare.cpp ..\src\foment.hpp ..\src\syncthrd.hpp ..\src\unicode.hpp 189 | release\main.obj: ..\src\main.cpp ..\src\foment.hpp 190 | release\random.obj: ..\src\random.cpp ..\src\foment.hpp 191 | release\base.obj: debug\base.cpp 192 | 193 | debug\txt2cpp.obj: ..\src\txt2cpp.cpp 194 | debug\genprops.obj: ..\src\genprops.cpp 195 | 196 | debug\stdread.obj: ..\test\stdread.cpp 197 | debug\stdwrite.obj: ..\test\stdwrite.cpp 198 | debug\exitcode.obj: ..\test\exitcode.cpp 199 | debug\hang.obj: ..\test\hang.cpp 200 | 201 | {.}.cpp.{debug}.obj: 202 | cl $(CLDEBUG) $(*B).cpp 203 | 204 | {..\src\}.cpp.{debug}.obj: 205 | cl $(CLDEBUG) ..\src\$(*B).cpp 206 | 207 | {..\src\}.c.{debug}.obj: 208 | cl $(CLDEBUG) ..\src\$(*B).c 209 | 210 | {debug\}.cpp.{debug}.obj: 211 | cl $(CLDEBUG) debug\$(*B).cpp 212 | 213 | {.}.cpp.{release}.obj: 214 | cl $(CLRELEASE) $(*B).cpp 215 | 216 | {..\src\}.cpp.{release}.obj: 217 | cl $(CLRELEASE) ..\src\$(*B).cpp 218 | 219 | {..\src\}.c.{release}.obj: 220 | cl $(CLRELEASE) ..\src\$(*B).c 221 | 222 | {debug\}.cpp.{release}.obj: 223 | cl $(CLRELEASE) debug\$(*B).cpp 224 | 225 | {..\test\}.cpp.{debug}.obj: 226 | cl $(CLDEBUG) ..\test\$(*B).cpp 227 | -------------------------------------------------------------------------------- /windows/test.scm: -------------------------------------------------------------------------------- 1 | (import (foment base)) 2 | 3 | (define (server) 4 | (define (loop s) 5 | ;; (let ((bv (recv-socket s 128 0))) 6 | ;; (if (> (bytevector-length bv) 0) 7 | (let ((bv (read-bytevector 128 s))) 8 | (if (not (eof-object? bv)) 9 | (begin 10 | (display (utf8->string bv)) 11 | (newline) 12 | (loop s))))) 13 | (let ((s (make-socket (address-family inet) (socket-domain stream) (ip-protocol tcp)))) 14 | (bind-socket s "localhost" "12345" (address-family inet) (socket-domain stream) 15 | (ip-protocol tcp)) 16 | (listen-socket s) 17 | (loop (accept-socket s)))) 18 | 19 | (define (client) 20 | (define (loop s) 21 | ;; (socket-send s (string->utf8 (read-line)) 0) 22 | (write-bytevector (string->utf8 (read-line)) s) 23 | (loop s)) 24 | (let ((s (make-socket (address-family inet) (socket-domain stream) (ip-protocol tcp)))) 25 | (connect-socket s "localhost" "12345" (address-family inet) (socket-domain stream) 26 | 0 (ip-protocol tcp)) 27 | (loop s))) 28 | 29 | (cond 30 | ((member "client" (command-line)) (client)) 31 | ((member "server" (command-line)) (server)) 32 | (else (display "error: expected client or server on the command line") (newline))) 33 | 34 | --------------------------------------------------------------------------------