├── Cargo.lock ├── Cargo.nix ├── Cargo.toml ├── KLambda ├── core.kl ├── declarations.kl ├── load.kl ├── macros.kl ├── prolog.kl ├── reader.kl ├── sequent.kl ├── sys.kl ├── t-star.kl ├── toplevel.kl ├── track.kl ├── types.kl ├── writer.kl └── yacc.kl ├── default.nix ├── nix ├── crates-io.nix ├── default.nix └── release.nix ├── shen-rust.org └── src └── main.rs /Cargo.lock: -------------------------------------------------------------------------------- 1 | # This file is automatically @generated by Cargo. 2 | # It is not intended for manual editing. 3 | [[package]] 4 | name = "aster" 5 | version = "0.25.0" 6 | source = "registry+https://github.com/rust-lang/crates.io-index" 7 | dependencies = [ 8 | "syntex_syntax 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)", 9 | ] 10 | 11 | [[package]] 12 | name = "bitflags" 13 | version = "0.5.0" 14 | source = "registry+https://github.com/rust-lang/crates.io-index" 15 | 16 | [[package]] 17 | name = "cfg-if" 18 | version = "0.1.9" 19 | source = "registry+https://github.com/rust-lang/crates.io-index" 20 | 21 | [[package]] 22 | name = "fuchsia-cprng" 23 | version = "0.1.1" 24 | source = "registry+https://github.com/rust-lang/crates.io-index" 25 | 26 | [[package]] 27 | name = "kernel32-sys" 28 | version = "0.2.2" 29 | source = "registry+https://github.com/rust-lang/crates.io-index" 30 | dependencies = [ 31 | "winapi 0.2.8 (registry+https://github.com/rust-lang/crates.io-index)", 32 | "winapi-build 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)", 33 | ] 34 | 35 | [[package]] 36 | name = "libc" 37 | version = "0.2.60" 38 | source = "registry+https://github.com/rust-lang/crates.io-index" 39 | 40 | [[package]] 41 | name = "log" 42 | version = "0.3.9" 43 | source = "registry+https://github.com/rust-lang/crates.io-index" 44 | dependencies = [ 45 | "log 0.4.7 (registry+https://github.com/rust-lang/crates.io-index)", 46 | ] 47 | 48 | [[package]] 49 | name = "log" 50 | version = "0.4.7" 51 | source = "registry+https://github.com/rust-lang/crates.io-index" 52 | dependencies = [ 53 | "cfg-if 0.1.9 (registry+https://github.com/rust-lang/crates.io-index)", 54 | ] 55 | 56 | [[package]] 57 | name = "nom" 58 | version = "1.2.4" 59 | source = "registry+https://github.com/rust-lang/crates.io-index" 60 | 61 | [[package]] 62 | name = "quasi" 63 | version = "0.18.0" 64 | source = "registry+https://github.com/rust-lang/crates.io-index" 65 | dependencies = [ 66 | "syntex_errors 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)", 67 | "syntex_syntax 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)", 68 | ] 69 | 70 | [[package]] 71 | name = "rand" 72 | version = "0.3.23" 73 | source = "registry+https://github.com/rust-lang/crates.io-index" 74 | dependencies = [ 75 | "libc 0.2.60 (registry+https://github.com/rust-lang/crates.io-index)", 76 | "rand 0.4.6 (registry+https://github.com/rust-lang/crates.io-index)", 77 | ] 78 | 79 | [[package]] 80 | name = "rand" 81 | version = "0.4.6" 82 | source = "registry+https://github.com/rust-lang/crates.io-index" 83 | dependencies = [ 84 | "fuchsia-cprng 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)", 85 | "libc 0.2.60 (registry+https://github.com/rust-lang/crates.io-index)", 86 | "rand_core 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)", 87 | "rdrand 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", 88 | "winapi 0.3.7 (registry+https://github.com/rust-lang/crates.io-index)", 89 | ] 90 | 91 | [[package]] 92 | name = "rand_core" 93 | version = "0.3.1" 94 | source = "registry+https://github.com/rust-lang/crates.io-index" 95 | dependencies = [ 96 | "rand_core 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", 97 | ] 98 | 99 | [[package]] 100 | name = "rand_core" 101 | version = "0.4.0" 102 | source = "registry+https://github.com/rust-lang/crates.io-index" 103 | 104 | [[package]] 105 | name = "rdrand" 106 | version = "0.4.0" 107 | source = "registry+https://github.com/rust-lang/crates.io-index" 108 | dependencies = [ 109 | "rand_core 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)", 110 | ] 111 | 112 | [[package]] 113 | name = "redox_syscall" 114 | version = "0.1.56" 115 | source = "registry+https://github.com/rust-lang/crates.io-index" 116 | 117 | [[package]] 118 | name = "ref_eq" 119 | version = "1.0.0" 120 | source = "registry+https://github.com/rust-lang/crates.io-index" 121 | 122 | [[package]] 123 | name = "rustc-serialize" 124 | version = "0.3.24" 125 | source = "registry+https://github.com/rust-lang/crates.io-index" 126 | 127 | [[package]] 128 | name = "shen-rust" 129 | version = "0.0.1" 130 | dependencies = [ 131 | "aster 0.25.0 (registry+https://github.com/rust-lang/crates.io-index)", 132 | "libc 0.2.60 (registry+https://github.com/rust-lang/crates.io-index)", 133 | "nom 1.2.4 (registry+https://github.com/rust-lang/crates.io-index)", 134 | "quasi 0.18.0 (registry+https://github.com/rust-lang/crates.io-index)", 135 | "ref_eq 1.0.0 (registry+https://github.com/rust-lang/crates.io-index)", 136 | "syntex 0.42.2 (registry+https://github.com/rust-lang/crates.io-index)", 137 | "syntex_syntax 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)", 138 | "time 0.1.42 (registry+https://github.com/rust-lang/crates.io-index)", 139 | "uuid 0.2.3 (registry+https://github.com/rust-lang/crates.io-index)", 140 | ] 141 | 142 | [[package]] 143 | name = "syntex" 144 | version = "0.42.2" 145 | source = "registry+https://github.com/rust-lang/crates.io-index" 146 | dependencies = [ 147 | "syntex_errors 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)", 148 | "syntex_syntax 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)", 149 | ] 150 | 151 | [[package]] 152 | name = "syntex_errors" 153 | version = "0.42.0" 154 | source = "registry+https://github.com/rust-lang/crates.io-index" 155 | dependencies = [ 156 | "libc 0.2.60 (registry+https://github.com/rust-lang/crates.io-index)", 157 | "log 0.3.9 (registry+https://github.com/rust-lang/crates.io-index)", 158 | "rustc-serialize 0.3.24 (registry+https://github.com/rust-lang/crates.io-index)", 159 | "syntex_pos 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)", 160 | "term 0.4.6 (registry+https://github.com/rust-lang/crates.io-index)", 161 | "unicode-xid 0.0.3 (registry+https://github.com/rust-lang/crates.io-index)", 162 | ] 163 | 164 | [[package]] 165 | name = "syntex_pos" 166 | version = "0.42.0" 167 | source = "registry+https://github.com/rust-lang/crates.io-index" 168 | dependencies = [ 169 | "rustc-serialize 0.3.24 (registry+https://github.com/rust-lang/crates.io-index)", 170 | ] 171 | 172 | [[package]] 173 | name = "syntex_syntax" 174 | version = "0.42.0" 175 | source = "registry+https://github.com/rust-lang/crates.io-index" 176 | dependencies = [ 177 | "bitflags 0.5.0 (registry+https://github.com/rust-lang/crates.io-index)", 178 | "libc 0.2.60 (registry+https://github.com/rust-lang/crates.io-index)", 179 | "log 0.3.9 (registry+https://github.com/rust-lang/crates.io-index)", 180 | "rustc-serialize 0.3.24 (registry+https://github.com/rust-lang/crates.io-index)", 181 | "syntex_errors 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)", 182 | "syntex_pos 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)", 183 | "term 0.4.6 (registry+https://github.com/rust-lang/crates.io-index)", 184 | "unicode-xid 0.0.3 (registry+https://github.com/rust-lang/crates.io-index)", 185 | ] 186 | 187 | [[package]] 188 | name = "term" 189 | version = "0.4.6" 190 | source = "registry+https://github.com/rust-lang/crates.io-index" 191 | dependencies = [ 192 | "kernel32-sys 0.2.2 (registry+https://github.com/rust-lang/crates.io-index)", 193 | "winapi 0.2.8 (registry+https://github.com/rust-lang/crates.io-index)", 194 | ] 195 | 196 | [[package]] 197 | name = "time" 198 | version = "0.1.42" 199 | source = "registry+https://github.com/rust-lang/crates.io-index" 200 | dependencies = [ 201 | "libc 0.2.60 (registry+https://github.com/rust-lang/crates.io-index)", 202 | "redox_syscall 0.1.56 (registry+https://github.com/rust-lang/crates.io-index)", 203 | "winapi 0.3.7 (registry+https://github.com/rust-lang/crates.io-index)", 204 | ] 205 | 206 | [[package]] 207 | name = "unicode-xid" 208 | version = "0.0.3" 209 | source = "registry+https://github.com/rust-lang/crates.io-index" 210 | 211 | [[package]] 212 | name = "uuid" 213 | version = "0.2.3" 214 | source = "registry+https://github.com/rust-lang/crates.io-index" 215 | dependencies = [ 216 | "rand 0.3.23 (registry+https://github.com/rust-lang/crates.io-index)", 217 | ] 218 | 219 | [[package]] 220 | name = "winapi" 221 | version = "0.2.8" 222 | source = "registry+https://github.com/rust-lang/crates.io-index" 223 | 224 | [[package]] 225 | name = "winapi" 226 | version = "0.3.7" 227 | source = "registry+https://github.com/rust-lang/crates.io-index" 228 | dependencies = [ 229 | "winapi-i686-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", 230 | "winapi-x86_64-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", 231 | ] 232 | 233 | [[package]] 234 | name = "winapi-build" 235 | version = "0.1.1" 236 | source = "registry+https://github.com/rust-lang/crates.io-index" 237 | 238 | [[package]] 239 | name = "winapi-i686-pc-windows-gnu" 240 | version = "0.4.0" 241 | source = "registry+https://github.com/rust-lang/crates.io-index" 242 | 243 | [[package]] 244 | name = "winapi-x86_64-pc-windows-gnu" 245 | version = "0.4.0" 246 | source = "registry+https://github.com/rust-lang/crates.io-index" 247 | 248 | [metadata] 249 | "checksum aster 0.25.0 (registry+https://github.com/rust-lang/crates.io-index)" = "4df293303e8a52e1df7984ac1415e195f5fcbf51e4bb7bda54557861a3954a08" 250 | "checksum bitflags 0.5.0 (registry+https://github.com/rust-lang/crates.io-index)" = "4f67931368edf3a9a51d29886d245f1c3db2f1ef0dcc9e35ff70341b78c10d23" 251 | "checksum cfg-if 0.1.9 (registry+https://github.com/rust-lang/crates.io-index)" = "b486ce3ccf7ffd79fdeb678eac06a9e6c09fc88d33836340becb8fffe87c5e33" 252 | "checksum fuchsia-cprng 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)" = "a06f77d526c1a601b7c4cdd98f54b5eaabffc14d5f2f0296febdc7f357c6d3ba" 253 | "checksum kernel32-sys 0.2.2 (registry+https://github.com/rust-lang/crates.io-index)" = "7507624b29483431c0ba2d82aece8ca6cdba9382bff4ddd0f7490560c056098d" 254 | "checksum libc 0.2.60 (registry+https://github.com/rust-lang/crates.io-index)" = "d44e80633f007889c7eff624b709ab43c92d708caad982295768a7b13ca3b5eb" 255 | "checksum log 0.3.9 (registry+https://github.com/rust-lang/crates.io-index)" = "e19e8d5c34a3e0e2223db8e060f9e8264aeeb5c5fc64a4ee9965c062211c024b" 256 | "checksum log 0.4.7 (registry+https://github.com/rust-lang/crates.io-index)" = "c275b6ad54070ac2d665eef9197db647b32239c9d244bfb6f041a766d00da5b3" 257 | "checksum nom 1.2.4 (registry+https://github.com/rust-lang/crates.io-index)" = "a5b8c256fd9471521bcb84c3cdba98921497f1a331cbc15b8030fc63b82050ce" 258 | "checksum quasi 0.18.0 (registry+https://github.com/rust-lang/crates.io-index)" = "cb7eaef226a434a570fa336bc99502c4f5878208c1ebdd83b2d0bc37b1b1c34c" 259 | "checksum rand 0.3.23 (registry+https://github.com/rust-lang/crates.io-index)" = "64ac302d8f83c0c1974bf758f6b041c6c8ada916fbb44a609158ca8b064cc76c" 260 | "checksum rand 0.4.6 (registry+https://github.com/rust-lang/crates.io-index)" = "552840b97013b1a26992c11eac34bdd778e464601a4c2054b5f0bff7c6761293" 261 | "checksum rand_core 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)" = "7a6fdeb83b075e8266dcc8762c22776f6877a63111121f5f8c7411e5be7eed4b" 262 | "checksum rand_core 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "d0e7a549d590831370895ab7ba4ea0c1b6b011d106b5ff2da6eee112615e6dc0" 263 | "checksum rdrand 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "678054eb77286b51581ba43620cc911abf02758c91f93f479767aed0f90458b2" 264 | "checksum redox_syscall 0.1.56 (registry+https://github.com/rust-lang/crates.io-index)" = "2439c63f3f6139d1b57529d16bc3b8bb855230c8efcc5d3a896c8bea7c3b1e84" 265 | "checksum ref_eq 1.0.0 (registry+https://github.com/rust-lang/crates.io-index)" = "b5be05580cabe5669689db3f2fad4af6af21eb2a5c7edef0bd195f28757cabd9" 266 | "checksum rustc-serialize 0.3.24 (registry+https://github.com/rust-lang/crates.io-index)" = "dcf128d1287d2ea9d80910b5f1120d0b8eede3fbf1abe91c40d39ea7d51e6fda" 267 | "checksum syntex 0.42.2 (registry+https://github.com/rust-lang/crates.io-index)" = "0a30b08a6b383a22e5f6edc127d169670d48f905bb00ca79a00ea3e442ebe317" 268 | "checksum syntex_errors 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)" = "04c48f32867b6114449155b2a82114b86d4b09e1bddb21c47ff104ab9172b646" 269 | "checksum syntex_pos 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)" = "3fd49988e52451813c61fecbe9abb5cfd4e1b7bb6cdbb980a6fbcbab859171a6" 270 | "checksum syntex_syntax 0.42.0 (registry+https://github.com/rust-lang/crates.io-index)" = "7628a0506e8f9666fdabb5f265d0059b059edac9a3f810bda077abb5d826bd8d" 271 | "checksum term 0.4.6 (registry+https://github.com/rust-lang/crates.io-index)" = "fa63644f74ce96fbeb9b794f66aff2a52d601cbd5e80f4b97123e3899f4570f1" 272 | "checksum time 0.1.42 (registry+https://github.com/rust-lang/crates.io-index)" = "db8dcfca086c1143c9270ac42a2bbd8a7ee477b78ac8e45b19abfb0cbede4b6f" 273 | "checksum unicode-xid 0.0.3 (registry+https://github.com/rust-lang/crates.io-index)" = "36dff09cafb4ec7c8cf0023eb0b686cb6ce65499116a12201c9e11840ca01beb" 274 | "checksum uuid 0.2.3 (registry+https://github.com/rust-lang/crates.io-index)" = "885acc3b17fdef6230d1f7765dff1106dfd5e75a93c2f26459fbf600ed6dcc14" 275 | "checksum winapi 0.2.8 (registry+https://github.com/rust-lang/crates.io-index)" = "167dc9d6949a9b857f3451275e911c3f44255842c1f7a76f33c55103a909087a" 276 | "checksum winapi 0.3.7 (registry+https://github.com/rust-lang/crates.io-index)" = "f10e386af2b13e47c89e7236a7a14a086791a2b88ebad6df9bf42040195cf770" 277 | "checksum winapi-build 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)" = "2d315eee3b34aca4797b2da6b13ed88266e6d612562a0c46390af8299fc699bc" 278 | "checksum winapi-i686-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "ac3b87c63620426dd9b991e5ce0329eff545bccbbb34f3be09ff6fb6ab51b7b6" 279 | "checksum winapi-x86_64-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "712e227841d057c1ee1cd2fb22fa7e5a5461ae8e48fa2ca79ec42cfc1931183f" 280 | -------------------------------------------------------------------------------- /Cargo.nix: -------------------------------------------------------------------------------- 1 | # Generated by carnix 0.9.8: carnix generate-nix --src ../. 2 | { lib, buildPlatform, buildRustCrate, buildRustCrateHelpers, cratesIO, fetchgit }: 3 | with buildRustCrateHelpers; 4 | let inherit (lib.lists) fold; 5 | inherit (lib.attrsets) recursiveUpdate; 6 | in 7 | rec { 8 | crates = cratesIO // rec { 9 | # shen-rust-0.0.1 10 | 11 | crates.shen_rust."0.0.1" = deps: { features?(features_.shen_rust."0.0.1" deps {}) }: buildRustCrate { 12 | crateName = "shen-rust"; 13 | version = "0.0.1"; 14 | authors = [ "aditya.siram@gmail.com" ]; 15 | src = exclude [ ".git" "target" ] ./.; 16 | dependencies = mapFeatures features ([ 17 | (cratesIO.crates."aster"."${deps."shen_rust"."0.0.1"."aster"}" deps) 18 | (cratesIO.crates."libc"."${deps."shen_rust"."0.0.1"."libc"}" deps) 19 | (cratesIO.crates."nom"."${deps."shen_rust"."0.0.1"."nom"}" deps) 20 | (cratesIO.crates."quasi"."${deps."shen_rust"."0.0.1"."quasi"}" deps) 21 | (cratesIO.crates."ref_eq"."${deps."shen_rust"."0.0.1"."ref_eq"}" deps) 22 | (cratesIO.crates."syntex"."${deps."shen_rust"."0.0.1"."syntex"}" deps) 23 | (cratesIO.crates."syntex_syntax"."${deps."shen_rust"."0.0.1"."syntex_syntax"}" deps) 24 | (cratesIO.crates."time"."${deps."shen_rust"."0.0.1"."time"}" deps) 25 | (cratesIO.crates."uuid"."${deps."shen_rust"."0.0.1"."uuid"}" deps) 26 | ]); 27 | }; 28 | features_.shen_rust."0.0.1" = deps: f: updateFeatures f (rec { 29 | aster = fold recursiveUpdate {} [ 30 | { "${deps.shen_rust."0.0.1".aster}"."with-syntex" = true; } 31 | { "${deps.shen_rust."0.0.1".aster}".default = true; } 32 | ]; 33 | libc."${deps.shen_rust."0.0.1".libc}".default = true; 34 | nom."${deps.shen_rust."0.0.1".nom}".default = true; 35 | quasi = fold recursiveUpdate {} [ 36 | { "${deps.shen_rust."0.0.1".quasi}"."with-syntex" = true; } 37 | { "${deps.shen_rust."0.0.1".quasi}".default = true; } 38 | ]; 39 | ref_eq."${deps.shen_rust."0.0.1".ref_eq}".default = true; 40 | shen_rust."0.0.1".default = (f.shen_rust."0.0.1".default or true); 41 | syntex."${deps.shen_rust."0.0.1".syntex}".default = true; 42 | syntex_syntax."${deps.shen_rust."0.0.1".syntex_syntax}".default = true; 43 | time."${deps.shen_rust."0.0.1".time}".default = true; 44 | uuid = fold recursiveUpdate {} [ 45 | { "${deps.shen_rust."0.0.1".uuid}"."v4" = true; } 46 | { "${deps.shen_rust."0.0.1".uuid}".default = true; } 47 | ]; 48 | }) [ 49 | (cratesIO.features_.aster."${deps."shen_rust"."0.0.1"."aster"}" deps) 50 | (cratesIO.features_.libc."${deps."shen_rust"."0.0.1"."libc"}" deps) 51 | (cratesIO.features_.nom."${deps."shen_rust"."0.0.1"."nom"}" deps) 52 | (cratesIO.features_.quasi."${deps."shen_rust"."0.0.1"."quasi"}" deps) 53 | (cratesIO.features_.ref_eq."${deps."shen_rust"."0.0.1"."ref_eq"}" deps) 54 | (cratesIO.features_.syntex."${deps."shen_rust"."0.0.1"."syntex"}" deps) 55 | (cratesIO.features_.syntex_syntax."${deps."shen_rust"."0.0.1"."syntex_syntax"}" deps) 56 | (cratesIO.features_.time."${deps."shen_rust"."0.0.1"."time"}" deps) 57 | (cratesIO.features_.uuid."${deps."shen_rust"."0.0.1"."uuid"}" deps) 58 | ]; 59 | 60 | 61 | # end 62 | 63 | }; 64 | 65 | shen_rust = crates.crates.shen_rust."0.0.1" deps; 66 | __all = [ (shen_rust {}) ]; 67 | deps.aster."0.25.0" = { 68 | syntex_syntax = "0.42.0"; 69 | }; 70 | deps.bitflags."0.5.0" = {}; 71 | deps.cfg_if."0.1.9" = {}; 72 | deps.fuchsia_cprng."0.1.1" = {}; 73 | deps.kernel32_sys."0.2.2" = { 74 | winapi = "0.2.8"; 75 | winapi_build = "0.1.1"; 76 | }; 77 | deps.libc."0.2.60" = {}; 78 | deps.log."0.3.9" = { 79 | log = "0.4.7"; 80 | }; 81 | deps.log."0.4.7" = { 82 | cfg_if = "0.1.9"; 83 | }; 84 | deps.nom."1.2.4" = {}; 85 | deps.quasi."0.18.0" = { 86 | syntex_errors = "0.42.0"; 87 | syntex_syntax = "0.42.0"; 88 | }; 89 | deps.rand."0.3.23" = { 90 | libc = "0.2.60"; 91 | rand = "0.4.6"; 92 | }; 93 | deps.rand."0.4.6" = { 94 | rand_core = "0.3.1"; 95 | rdrand = "0.4.0"; 96 | fuchsia_cprng = "0.1.1"; 97 | libc = "0.2.60"; 98 | winapi = "0.3.7"; 99 | }; 100 | deps.rand_core."0.3.1" = { 101 | rand_core = "0.4.0"; 102 | }; 103 | deps.rand_core."0.4.0" = {}; 104 | deps.rdrand."0.4.0" = { 105 | rand_core = "0.3.1"; 106 | }; 107 | deps.redox_syscall."0.1.56" = {}; 108 | deps.ref_eq."1.0.0" = {}; 109 | deps.rustc_serialize."0.3.24" = {}; 110 | deps.shen_rust."0.0.1" = { 111 | aster = "0.25.0"; 112 | libc = "0.2.60"; 113 | nom = "1.2.4"; 114 | quasi = "0.18.0"; 115 | ref_eq = "1.0.0"; 116 | syntex = "0.42.2"; 117 | syntex_syntax = "0.42.0"; 118 | time = "0.1.42"; 119 | uuid = "0.2.3"; 120 | }; 121 | deps.syntex."0.42.2" = { 122 | syntex_errors = "0.42.0"; 123 | syntex_syntax = "0.42.0"; 124 | }; 125 | deps.syntex_errors."0.42.0" = { 126 | libc = "0.2.60"; 127 | log = "0.3.9"; 128 | rustc_serialize = "0.3.24"; 129 | syntex_pos = "0.42.0"; 130 | term = "0.4.6"; 131 | unicode_xid = "0.0.3"; 132 | }; 133 | deps.syntex_pos."0.42.0" = { 134 | rustc_serialize = "0.3.24"; 135 | }; 136 | deps.syntex_syntax."0.42.0" = { 137 | bitflags = "0.5.0"; 138 | libc = "0.2.60"; 139 | log = "0.3.9"; 140 | rustc_serialize = "0.3.24"; 141 | syntex_errors = "0.42.0"; 142 | syntex_pos = "0.42.0"; 143 | term = "0.4.6"; 144 | unicode_xid = "0.0.3"; 145 | }; 146 | deps.term."0.4.6" = { 147 | kernel32_sys = "0.2.2"; 148 | winapi = "0.2.8"; 149 | }; 150 | deps.time."0.1.42" = { 151 | libc = "0.2.60"; 152 | redox_syscall = "0.1.56"; 153 | winapi = "0.3.7"; 154 | }; 155 | deps.unicode_xid."0.0.3" = {}; 156 | deps.uuid."0.2.3" = { 157 | rand = "0.3.23"; 158 | }; 159 | deps.winapi."0.2.8" = {}; 160 | deps.winapi."0.3.7" = { 161 | winapi_i686_pc_windows_gnu = "0.4.0"; 162 | winapi_x86_64_pc_windows_gnu = "0.4.0"; 163 | }; 164 | deps.winapi_build."0.1.1" = {}; 165 | deps.winapi_i686_pc_windows_gnu."0.4.0" = {}; 166 | deps.winapi_x86_64_pc_windows_gnu."0.4.0" = {}; 167 | } 168 | -------------------------------------------------------------------------------- /Cargo.toml: -------------------------------------------------------------------------------- 1 | # [[file:shen-rust.org::*Package%20Details][Package\ Details:1]] 2 | [package] 3 | name = "shen-rust" 4 | version = "0.0.1" 5 | authors = ["aditya.siram@gmail.com"] 6 | description = "An implementation of Shen in Rust" 7 | repository = "https://github.com/deech/shen-rust" 8 | license = "MIT" 9 | 10 | [dependencies] 11 | libc = "*" 12 | nom = "^1.2.4" 13 | time = "^0.1" 14 | uuid = { version = "^0.2", features = ["v4"] } 15 | ref_eq = "^1.0.0" 16 | syntex = { version = "^0.42.2" } 17 | syntex_syntax = { version = "^0.42.0" } 18 | aster = { version = "^0.25.0", features = ["with-syntex"] } 19 | quasi = { version = "^0.18.0", features = ["with-syntex"] } 20 | # Package\ Details:1 ends here 21 | -------------------------------------------------------------------------------- /KLambda/core.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun shen.shen->kl (V13104 V13105) (compile (lambda X (shen. X)) (cons V13104 V13105) (lambda X (shen.shen-syntax-error V13104 X)))) 27 | 28 | (defun shen.shen-syntax-error (V13112 V13113) (cond ((cons? V13113) (simple-error (cn "syntax error in " (shen.app V13112 (cn " here: 29 | 30 | " (shen.app (shen.next-50 50 (hd V13113)) " 31 | " shen.a)) shen.a)))) (true (simple-error (cn "syntax error in " (shen.app V13112 " 32 | " shen.a)))))) 33 | 34 | (defun shen. (V13115) (let YaccParse (let Parse_shen. (shen. V13115) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.compile_to_machine_code (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V13115) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.compile_to_machine_code (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) YaccParse))) 35 | 36 | (defun shen. (V13117) (if (cons? (hd V13117)) (let Parse_X (hd (hd V13117)) (shen.pair (hd (shen.pair (tl (hd V13117)) (shen.hdtl V13117))) (if (and (symbol? Parse_X) (not (shen.sysfunc? Parse_X))) Parse_X (simple-error (shen.app Parse_X " is not a legitimate function name. 37 | " shen.a))))) (fail))) 38 | 39 | (defun shen.sysfunc? (V13119) (element? V13119 (get (intern "shen") shen.external-symbols (value *property-vector*)))) 40 | 41 | (defun shen. (V13121) (if (and (cons? (hd V13121)) (= { (hd (hd V13121)))) (let Parse_shen. (shen. (shen.pair (tl (hd V13121)) (shen.hdtl V13121))) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= } (hd (hd Parse_shen.)))) (shen.pair (hd (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (shen.demodulate (shen.curry-type (shen.hdtl Parse_shen.)))) (fail)) (fail))) (fail))) 42 | 43 | (defun shen.curry-type (V13123) (cond ((and (cons? V13123) (and (cons? (tl V13123)) (and (= --> (hd (tl V13123))) (and (cons? (tl (tl V13123))) (and (cons? (tl (tl (tl V13123)))) (= --> (hd (tl (tl (tl V13123)))))))))) (shen.curry-type (cons (hd V13123) (cons --> (cons (tl (tl V13123)) ()))))) ((and (cons? V13123) (and (cons? (tl V13123)) (and (= * (hd (tl V13123))) (and (cons? (tl (tl V13123))) (and (cons? (tl (tl (tl V13123)))) (= * (hd (tl (tl (tl V13123)))))))))) (shen.curry-type (cons (hd V13123) (cons * (cons (tl (tl V13123)) ()))))) ((cons? V13123) (map (lambda Z (shen.curry-type Z)) V13123)) (true V13123))) 44 | 45 | (defun shen. (V13125) (let YaccParse (if (cons? (hd V13125)) (let Parse_X (hd (hd V13125)) (let Parse_shen. (shen. (shen.pair (tl (hd V13125)) (shen.hdtl V13125))) (if (not (= (fail) Parse_shen.)) (if (not (element? Parse_X (cons { (cons } ())))) (shen.pair (hd Parse_shen.) (cons Parse_X (shen.hdtl Parse_shen.))) (fail)) (fail)))) (fail)) (if (= YaccParse (fail)) (let Parse_ ( V13125) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) YaccParse))) 46 | 47 | (defun shen. (V13127) (let YaccParse (let Parse_shen. (shen. V13127) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.linearise (shen.hdtl Parse_shen.)) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V13127) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.linearise (shen.hdtl Parse_shen.)) ())) (fail))) YaccParse))) 48 | 49 | (defun shen. (V13129) (let YaccParse (let Parse_shen. (shen. V13129) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= -> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= where (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (cons where (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V13129) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= -> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))) (fail))) (fail)) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V13129) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= <- (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= where (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (cons where (cons (shen.hdtl Parse_shen.) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.) ())) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V13129) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= <- (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.) ())) ()))) (fail))) (fail)) (fail))) YaccParse)) YaccParse)) YaccParse))) 50 | 51 | (defun shen.fail_if (V13132 V13133) (if (V13132 V13133) (fail) V13133)) 52 | 53 | (defun shen.succeeds? (V13139) (cond ((= V13139 (fail)) false) (true true))) 54 | 55 | (defun shen. (V13141) (let YaccParse (let Parse_shen. (shen. V13141) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V13141) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) YaccParse))) 56 | 57 | (defun shen. (V13148) (let YaccParse (if (and (cons? (hd V13148)) (cons? (hd (hd V13148)))) (if (and (cons? (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (= @p (hd (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))))) (let Parse_shen. (shen. (shen.pair (tl (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (shen.hdtl (shen.pair (hd (hd V13148)) (hd (tl V13148)))))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd (shen.pair (tl (hd V13148)) (hd (tl V13148)))) (cons @p (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ())))) (fail))) (fail))) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (and (cons? (hd V13148)) (cons? (hd (hd V13148)))) (if (and (cons? (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (= cons (hd (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))))) (let Parse_shen. (shen. (shen.pair (tl (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (shen.hdtl (shen.pair (hd (hd V13148)) (hd (tl V13148)))))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd (shen.pair (tl (hd V13148)) (hd (tl V13148)))) (cons cons (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ())))) (fail))) (fail))) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (and (cons? (hd V13148)) (cons? (hd (hd V13148)))) (if (and (cons? (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (= @v (hd (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))))) (let Parse_shen. (shen. (shen.pair (tl (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (shen.hdtl (shen.pair (hd (hd V13148)) (hd (tl V13148)))))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd (shen.pair (tl (hd V13148)) (hd (tl V13148)))) (cons @v (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ())))) (fail))) (fail))) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (and (cons? (hd V13148)) (cons? (hd (hd V13148)))) (if (and (cons? (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (= @s (hd (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))))) (let Parse_shen. (shen. (shen.pair (tl (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (shen.hdtl (shen.pair (hd (hd V13148)) (hd (tl V13148)))))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd (shen.pair (tl (hd V13148)) (hd (tl V13148)))) (cons @s (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ())))) (fail))) (fail))) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (and (cons? (hd V13148)) (cons? (hd (hd V13148)))) (if (and (cons? (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (= vector (hd (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))))) (if (and (cons? (hd (shen.pair (tl (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (shen.hdtl (shen.pair (hd (hd V13148)) (hd (tl V13148))))))) (= 0 (hd (hd (shen.pair (tl (hd (shen.pair (hd (hd V13148)) (hd (tl V13148))))) (shen.hdtl (shen.pair (hd (hd V13148)) (hd (tl V13148))))))))) (shen.pair (hd (shen.pair (tl (hd V13148)) (hd (tl V13148)))) (cons vector (cons 0 ()))) (fail)) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (cons? (hd V13148)) (let Parse_X (hd (hd V13148)) (if (cons? Parse_X) (shen.pair (hd (shen.pair (tl (hd V13148)) (shen.hdtl V13148))) (shen.constructor-error Parse_X)) (fail))) (fail)) (if (= YaccParse (fail)) (let Parse_shen. (shen. V13148) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse))) 58 | 59 | (defun shen.constructor-error (V13150) (simple-error (shen.app V13150 " is not a legitimate constructor 60 | " shen.a))) 61 | 62 | (defun shen. (V13152) (let YaccParse (if (cons? (hd V13152)) (let Parse_X (hd (hd V13152)) (if (= Parse_X _) (shen.pair (hd (shen.pair (tl (hd V13152)) (shen.hdtl V13152))) (gensym Parse_Y)) (fail))) (fail)) (if (= YaccParse (fail)) (if (cons? (hd V13152)) (let Parse_X (hd (hd V13152)) (if (not (element? Parse_X (cons -> (cons <- ())))) (shen.pair (hd (shen.pair (tl (hd V13152)) (shen.hdtl V13152))) Parse_X) (fail))) (fail)) YaccParse))) 63 | 64 | (defun shen. (V13154) (let Parse_shen. (shen. V13154) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail)))) 65 | 66 | (defun shen. (V13156) (let Parse_shen. (shen. V13156) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail)))) 67 | 68 | (defun shen. (V13158) (if (cons? (hd V13158)) (let Parse_X (hd (hd V13158)) (shen.pair (hd (shen.pair (tl (hd V13158)) (shen.hdtl V13158))) Parse_X)) (fail))) 69 | 70 | (defun shen. (V13160) (if (cons? (hd V13160)) (let Parse_X (hd (hd V13160)) (shen.pair (hd (shen.pair (tl (hd V13160)) (shen.hdtl V13160))) Parse_X)) (fail))) 71 | 72 | (defun shen.compile_to_machine_code (V13163 V13164) (let Lambda+ (shen.compile_to_lambda+ V13163 V13164) (let KL (shen.compile_to_kl V13163 Lambda+) (let Record (shen.record-source V13163 KL) KL)))) 73 | 74 | (defun shen.record-source (V13169 V13170) (cond ((value shen.*installing-kl*) shen.skip) (true (put V13169 shen.source V13170 (value *property-vector*))))) 75 | 76 | (defun shen.compile_to_lambda+ (V13173 V13174) (let Arity (shen.aritycheck V13173 V13174) (let UpDateSymbolTable (shen.update-symbol-table V13173 Arity) (let Free (map (lambda Rule (shen.free_variable_check V13173 Rule)) V13174) (let Variables (shen.parameters Arity) (let Strip (map (lambda X (shen.strip-protect X)) V13174) (let Abstractions (map (lambda X (shen.abstract_rule X)) Strip) (let Applications (map (lambda X (shen.application_build Variables X)) Abstractions) (cons Variables (cons Applications ())))))))))) 77 | 78 | (defun shen.update-symbol-table (V13177 V13178) (set shen.*symbol-table* (shen.update-symbol-table-h V13177 V13178 (value shen.*symbol-table*) ()))) 79 | 80 | (defun shen.update-symbol-table-h (V13186 V13187 V13188 V13189) (cond ((= () V13188) (let NewEntry (cons V13186 (eval-kl (shen.lambda-form V13186 V13187))) (cons NewEntry V13189))) ((and (cons? V13188) (and (cons? (hd V13188)) (= (hd (hd V13188)) V13186))) (let ChangedEntry (cons (hd (hd V13188)) (eval-kl (shen.lambda-form (hd (hd V13188)) V13187))) (append (tl V13188) (cons ChangedEntry V13189)))) ((cons? V13188) (shen.update-symbol-table-h V13186 V13187 (tl V13188) (cons (hd V13188) V13189))) (true (shen.f_error shen.update-symbol-table-h)))) 81 | 82 | (defun shen.free_variable_check (V13192 V13193) (cond ((and (cons? V13193) (and (cons? (tl V13193)) (= () (tl (tl V13193))))) (let Bound (shen.extract_vars (hd V13193)) (let Free (shen.extract_free_vars Bound (hd (tl V13193))) (shen.free_variable_warnings V13192 Free)))) (true (shen.f_error shen.free_variable_check)))) 83 | 84 | (defun shen.extract_vars (V13195) (cond ((variable? V13195) (cons V13195 ())) ((cons? V13195) (union (shen.extract_vars (hd V13195)) (shen.extract_vars (tl V13195)))) (true ()))) 85 | 86 | (defun shen.extract_free_vars (V13207 V13208) (cond ((and (cons? V13208) (and (cons? (tl V13208)) (and (= () (tl (tl V13208))) (= (hd V13208) protect)))) ()) ((and (variable? V13208) (not (element? V13208 V13207))) (cons V13208 ())) ((and (cons? V13208) (and (= lambda (hd V13208)) (and (cons? (tl V13208)) (and (cons? (tl (tl V13208))) (= () (tl (tl (tl V13208)))))))) (shen.extract_free_vars (cons (hd (tl V13208)) V13207) (hd (tl (tl V13208))))) ((and (cons? V13208) (and (= let (hd V13208)) (and (cons? (tl V13208)) (and (cons? (tl (tl V13208))) (and (cons? (tl (tl (tl V13208)))) (= () (tl (tl (tl (tl V13208)))))))))) (union (shen.extract_free_vars V13207 (hd (tl (tl V13208)))) (shen.extract_free_vars (cons (hd (tl V13208)) V13207) (hd (tl (tl (tl V13208))))))) ((cons? V13208) (union (shen.extract_free_vars V13207 (hd V13208)) (shen.extract_free_vars V13207 (tl V13208)))) (true ()))) 87 | 88 | (defun shen.free_variable_warnings (V13213 V13214) (cond ((= () V13214) _) (true (simple-error (cn "error: the following variables are free in " (shen.app V13213 (cn ": " (shen.app (shen.list_variables V13214) "" shen.a)) shen.a)))))) 89 | 90 | (defun shen.list_variables (V13216) (cond ((and (cons? V13216) (= () (tl V13216))) (cn (str (hd V13216)) ".")) ((cons? V13216) (cn (str (hd V13216)) (cn ", " (shen.list_variables (tl V13216))))) (true (shen.f_error shen.list_variables)))) 91 | 92 | (defun shen.strip-protect (V13218) (cond ((and (cons? V13218) (and (cons? (tl V13218)) (and (= () (tl (tl V13218))) (= (hd V13218) protect)))) (shen.strip-protect (hd (tl V13218)))) ((cons? V13218) (map (lambda Z (shen.strip-protect Z)) V13218)) (true V13218))) 93 | 94 | (defun shen.linearise (V13220) (cond ((and (cons? V13220) (and (cons? (tl V13220)) (= () (tl (tl V13220))))) (shen.linearise_help (shen.flatten (hd V13220)) (hd V13220) (hd (tl V13220)))) (true (shen.f_error shen.linearise)))) 95 | 96 | (defun shen.flatten (V13222) (cond ((= () V13222) ()) ((cons? V13222) (append (shen.flatten (hd V13222)) (shen.flatten (tl V13222)))) (true (cons V13222 ())))) 97 | 98 | (defun shen.linearise_help (V13226 V13227 V13228) (cond ((= () V13226) (cons V13227 (cons V13228 ()))) ((cons? V13226) (if (and (variable? (hd V13226)) (element? (hd V13226) (tl V13226))) (let Var (gensym (hd V13226)) (let NewAction (cons where (cons (cons = (cons (hd V13226) (cons Var ()))) (cons V13228 ()))) (let NewPatts (shen.linearise_X (hd V13226) Var V13227) (shen.linearise_help (tl V13226) NewPatts NewAction)))) (shen.linearise_help (tl V13226) V13227 V13228))) (true (shen.f_error shen.linearise_help)))) 99 | 100 | (defun shen.linearise_X (V13241 V13242 V13243) (cond ((= V13243 V13241) V13242) ((cons? V13243) (let L (shen.linearise_X V13241 V13242 (hd V13243)) (if (= L (hd V13243)) (cons (hd V13243) (shen.linearise_X V13241 V13242 (tl V13243))) (cons L (tl V13243))))) (true V13243))) 101 | 102 | (defun shen.aritycheck (V13246 V13247) (cond ((and (cons? V13247) (and (cons? (hd V13247)) (and (cons? (tl (hd V13247))) (and (= () (tl (tl (hd V13247)))) (= () (tl V13247)))))) (do (shen.aritycheck-action (hd (tl (hd V13247)))) (shen.aritycheck-name V13246 (arity V13246) (length (hd (hd V13247)))))) ((and (cons? V13247) (and (cons? (hd V13247)) (and (cons? (tl (hd V13247))) (and (= () (tl (tl (hd V13247)))) (and (cons? (tl V13247)) (and (cons? (hd (tl V13247))) (and (cons? (tl (hd (tl V13247)))) (= () (tl (tl (hd (tl V13247)))))))))))) (if (= (length (hd (hd V13247))) (length (hd (hd (tl V13247))))) (do (shen.aritycheck-action (hd (tl (hd V13247)))) (shen.aritycheck V13246 (tl V13247))) (simple-error (cn "arity error in " (shen.app V13246 " 103 | " shen.a))))) (true (shen.f_error shen.aritycheck)))) 104 | 105 | (defun shen.aritycheck-name (V13260 V13261 V13262) (cond ((= -1 V13261) V13262) ((= V13262 V13261) V13262) (true (do (shen.prhush (cn " 106 | warning: changing the arity of " (shen.app V13260 " can cause errors. 107 | " shen.a)) (stoutput)) V13262)))) 108 | 109 | (defun shen.aritycheck-action (V13268) (cond ((cons? V13268) (do (shen.aah (hd V13268) (tl V13268)) (map (lambda Y (shen.aritycheck-action Y)) V13268))) (true shen.skip))) 110 | 111 | (defun shen.aah (V13271 V13272) (let Arity (arity V13271) (let Len (length V13272) (if (and (> Arity -1) (> Len Arity)) (shen.prhush (cn "warning: " (shen.app V13271 (cn " might not like " (shen.app Len (cn " argument" (shen.app (if (> Len 1) "s" "") ". 112 | " shen.a)) shen.a)) shen.a)) (stoutput)) shen.skip)))) 113 | 114 | (defun shen.abstract_rule (V13274) (cond ((and (cons? V13274) (and (cons? (tl V13274)) (= () (tl (tl V13274))))) (shen.abstraction_build (hd V13274) (hd (tl V13274)))) (true (shen.f_error shen.abstract_rule)))) 115 | 116 | (defun shen.abstraction_build (V13277 V13278) (cond ((= () V13277) V13278) ((cons? V13277) (cons /. (cons (hd V13277) (cons (shen.abstraction_build (tl V13277) V13278) ())))) (true (shen.f_error shen.abstraction_build)))) 117 | 118 | (defun shen.parameters (V13280) (cond ((= 0 V13280) ()) (true (cons (gensym V) (shen.parameters (- V13280 1)))))) 119 | 120 | (defun shen.application_build (V13283 V13284) (cond ((= () V13283) V13284) ((cons? V13283) (shen.application_build (tl V13283) (cons V13284 (cons (hd V13283) ())))) (true (shen.f_error shen.application_build)))) 121 | 122 | (defun shen.compile_to_kl (V13287 V13288) (cond ((and (cons? V13288) (and (cons? (tl V13288)) (= () (tl (tl V13288))))) (let Arity (shen.store-arity V13287 (length (hd V13288))) (let Reduce (map (lambda X (shen.reduce X)) (hd (tl V13288))) (let CondExpression (shen.cond-expression V13287 (hd V13288) Reduce) (let TypeTable (if (value shen.*optimise*) (shen.typextable (shen.get-type V13287) (hd V13288)) shen.skip) (let TypedCondExpression (if (value shen.*optimise*) (shen.assign-types (hd V13288) TypeTable CondExpression) CondExpression) (let KL (cons defun (cons V13287 (cons (hd V13288) (cons TypedCondExpression ())))) KL))))))) (true (shen.f_error shen.compile_to_kl)))) 123 | 124 | (defun shen.get-type (V13294) (cond ((cons? V13294) shen.skip) (true (let FType (assoc V13294 (value shen.*signedfuncs*)) (if (empty? FType) shen.skip (tl FType)))))) 125 | 126 | (defun shen.typextable (V13305 V13306) (cond ((and (cons? V13305) (and (cons? (tl V13305)) (and (= --> (hd (tl V13305))) (and (cons? (tl (tl V13305))) (and (= () (tl (tl (tl V13305)))) (cons? V13306)))))) (if (variable? (hd V13305)) (shen.typextable (hd (tl (tl V13305))) (tl V13306)) (cons (cons (hd V13306) (hd V13305)) (shen.typextable (hd (tl (tl V13305))) (tl V13306))))) (true ()))) 127 | 128 | (defun shen.assign-types (V13310 V13311 V13312) (cond ((and (cons? V13312) (and (= let (hd V13312)) (and (cons? (tl V13312)) (and (cons? (tl (tl V13312))) (and (cons? (tl (tl (tl V13312)))) (= () (tl (tl (tl (tl V13312)))))))))) (cons let (cons (hd (tl V13312)) (cons (shen.assign-types V13310 V13311 (hd (tl (tl V13312)))) (cons (shen.assign-types (cons (hd (tl V13312)) V13310) V13311 (hd (tl (tl (tl V13312))))) ()))))) ((and (cons? V13312) (and (= lambda (hd V13312)) (and (cons? (tl V13312)) (and (cons? (tl (tl V13312))) (= () (tl (tl (tl V13312)))))))) (cons lambda (cons (hd (tl V13312)) (cons (shen.assign-types (cons (hd (tl V13312)) V13310) V13311 (hd (tl (tl V13312)))) ())))) ((and (cons? V13312) (= cond (hd V13312))) (cons cond (map (lambda Y (cons (shen.assign-types V13310 V13311 (hd Y)) (cons (shen.assign-types V13310 V13311 (hd (tl Y))) ()))) (tl V13312)))) ((cons? V13312) (let NewTable (shen.typextable (shen.get-type (hd V13312)) (tl V13312)) (cons (hd V13312) (map (lambda Y (shen.assign-types V13310 (append V13311 NewTable) Y)) (tl V13312))))) (true (let AtomType (assoc V13312 V13311) (if (cons? AtomType) (cons type (cons V13312 (cons (tl AtomType) ()))) (if (element? V13312 V13310) V13312 (shen.atom-type V13312))))))) 129 | 130 | (defun shen.atom-type (V13314) (if (string? V13314) (cons type (cons V13314 (cons string ()))) (if (number? V13314) (cons type (cons V13314 (cons number ()))) (if (boolean? V13314) (cons type (cons V13314 (cons boolean ()))) (if (symbol? V13314) (cons type (cons V13314 (cons symbol ()))) V13314))))) 131 | 132 | (defun shen.store-arity (V13319 V13320) (cond ((value shen.*installing-kl*) shen.skip) (true (put V13319 arity V13320 (value *property-vector*))))) 133 | 134 | (defun shen.reduce (V13322) (do (set shen.*teststack* ()) (let Result (shen.reduce_help V13322) (cons (cons : (cons shen.tests (reverse (value shen.*teststack*)))) (cons Result ()))))) 135 | 136 | (defun shen.reduce_help (V13324) (cond ((and (cons? V13324) (and (cons? (hd V13324)) (and (= /. (hd (hd V13324))) (and (cons? (tl (hd V13324))) (and (cons? (hd (tl (hd V13324)))) (and (= cons (hd (hd (tl (hd V13324))))) (and (cons? (tl (hd (tl (hd V13324))))) (and (cons? (tl (tl (hd (tl (hd V13324)))))) (and (= () (tl (tl (tl (hd (tl (hd V13324))))))) (and (cons? (tl (tl (hd V13324)))) (and (= () (tl (tl (tl (hd V13324))))) (and (cons? (tl V13324)) (= () (tl (tl V13324))))))))))))))) (do (shen.add_test (cons cons? (tl V13324))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V13324))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V13324)))))) (cons (shen.ebr (hd (tl V13324)) (hd (tl (hd V13324))) (hd (tl (tl (hd V13324))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hd (tl V13324)) ())) (cons (cons tl (tl V13324)) ())) (shen.reduce_help Application))))) ((and (cons? V13324) (and (cons? (hd V13324)) (and (= /. (hd (hd V13324))) (and (cons? (tl (hd V13324))) (and (cons? (hd (tl (hd V13324)))) (and (= @p (hd (hd (tl (hd V13324))))) (and (cons? (tl (hd (tl (hd V13324))))) (and (cons? (tl (tl (hd (tl (hd V13324)))))) (and (= () (tl (tl (tl (hd (tl (hd V13324))))))) (and (cons? (tl (tl (hd V13324)))) (and (= () (tl (tl (tl (hd V13324))))) (and (cons? (tl V13324)) (= () (tl (tl V13324))))))))))))))) (do (shen.add_test (cons tuple? (tl V13324))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V13324))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V13324)))))) (cons (shen.ebr (hd (tl V13324)) (hd (tl (hd V13324))) (hd (tl (tl (hd V13324))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons fst (tl V13324)) ())) (cons (cons snd (tl V13324)) ())) (shen.reduce_help Application))))) ((and (cons? V13324) (and (cons? (hd V13324)) (and (= /. (hd (hd V13324))) (and (cons? (tl (hd V13324))) (and (cons? (hd (tl (hd V13324)))) (and (= @v (hd (hd (tl (hd V13324))))) (and (cons? (tl (hd (tl (hd V13324))))) (and (cons? (tl (tl (hd (tl (hd V13324)))))) (and (= () (tl (tl (tl (hd (tl (hd V13324))))))) (and (cons? (tl (tl (hd V13324)))) (and (= () (tl (tl (tl (hd V13324))))) (and (cons? (tl V13324)) (= () (tl (tl V13324))))))))))))))) (do (shen.add_test (cons shen.+vector? (tl V13324))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V13324))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V13324)))))) (cons (shen.ebr (hd (tl V13324)) (hd (tl (hd V13324))) (hd (tl (tl (hd V13324))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hdv (tl V13324)) ())) (cons (cons tlv (tl V13324)) ())) (shen.reduce_help Application))))) ((and (cons? V13324) (and (cons? (hd V13324)) (and (= /. (hd (hd V13324))) (and (cons? (tl (hd V13324))) (and (cons? (hd (tl (hd V13324)))) (and (= @s (hd (hd (tl (hd V13324))))) (and (cons? (tl (hd (tl (hd V13324))))) (and (cons? (tl (tl (hd (tl (hd V13324)))))) (and (= () (tl (tl (tl (hd (tl (hd V13324))))))) (and (cons? (tl (tl (hd V13324)))) (and (= () (tl (tl (tl (hd V13324))))) (and (cons? (tl V13324)) (= () (tl (tl V13324))))))))))))))) (do (shen.add_test (cons shen.+string? (tl V13324))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V13324))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V13324)))))) (cons (shen.ebr (hd (tl V13324)) (hd (tl (hd V13324))) (hd (tl (tl (hd V13324))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons pos (cons (hd (tl V13324)) (cons 0 ()))) ())) (cons (cons tlstr (tl V13324)) ())) (shen.reduce_help Application))))) ((and (cons? V13324) (and (cons? (hd V13324)) (and (= /. (hd (hd V13324))) (and (cons? (tl (hd V13324))) (and (cons? (tl (tl (hd V13324)))) (and (= () (tl (tl (tl (hd V13324))))) (and (cons? (tl V13324)) (and (= () (tl (tl V13324))) (not (variable? (hd (tl (hd V13324))))))))))))) (do (shen.add_test (cons = (cons (hd (tl (hd V13324))) (tl V13324)))) (shen.reduce_help (hd (tl (tl (hd V13324))))))) ((and (cons? V13324) (and (cons? (hd V13324)) (and (= /. (hd (hd V13324))) (and (cons? (tl (hd V13324))) (and (cons? (tl (tl (hd V13324)))) (and (= () (tl (tl (tl (hd V13324))))) (and (cons? (tl V13324)) (= () (tl (tl V13324)))))))))) (shen.reduce_help (shen.ebr (hd (tl V13324)) (hd (tl (hd V13324))) (hd (tl (tl (hd V13324))))))) ((and (cons? V13324) (and (= where (hd V13324)) (and (cons? (tl V13324)) (and (cons? (tl (tl V13324))) (= () (tl (tl (tl V13324)))))))) (do (shen.add_test (hd (tl V13324))) (shen.reduce_help (hd (tl (tl V13324)))))) ((and (cons? V13324) (and (cons? (tl V13324)) (= () (tl (tl V13324))))) (let Z (shen.reduce_help (hd V13324)) (if (= (hd V13324) Z) V13324 (shen.reduce_help (cons Z (tl V13324)))))) (true V13324))) 137 | 138 | (defun shen.+string? (V13326) (cond ((= "" V13326) false) (true (string? V13326)))) 139 | 140 | (defun shen.+vector (V13328) (cond ((= V13328 (vector 0)) false) (true (vector? V13328)))) 141 | 142 | (defun shen.ebr (V13342 V13343 V13344) (cond ((= V13344 V13343) V13342) ((and (cons? V13344) (and (= /. (hd V13344)) (and (cons? (tl V13344)) (and (cons? (tl (tl V13344))) (and (= () (tl (tl (tl V13344)))) (> (occurrences V13343 (hd (tl V13344))) 0)))))) V13344) ((and (cons? V13344) (and (= lambda (hd V13344)) (and (cons? (tl V13344)) (and (cons? (tl (tl V13344))) (and (= () (tl (tl (tl V13344)))) (> (occurrences V13343 (hd (tl V13344))) 0)))))) V13344) ((and (cons? V13344) (and (= let (hd V13344)) (and (cons? (tl V13344)) (and (cons? (tl (tl V13344))) (and (cons? (tl (tl (tl V13344)))) (and (= () (tl (tl (tl (tl V13344))))) (= (hd (tl V13344)) V13343))))))) (cons let (cons (hd (tl V13344)) (cons (shen.ebr V13342 (hd (tl V13344)) (hd (tl (tl V13344)))) (tl (tl (tl V13344))))))) ((cons? V13344) (cons (shen.ebr V13342 V13343 (hd V13344)) (shen.ebr V13342 V13343 (tl V13344)))) (true V13344))) 143 | 144 | (defun shen.add_test (V13346) (set shen.*teststack* (cons V13346 (value shen.*teststack*)))) 145 | 146 | (defun shen.cond-expression (V13350 V13351 V13352) (let Err (shen.err-condition V13350) (let Cases (shen.case-form V13352 Err) (let EncodeChoices (shen.encode-choices Cases V13350) (shen.cond-form EncodeChoices))))) 147 | 148 | (defun shen.cond-form (V13356) (cond ((and (cons? V13356) (and (cons? (hd V13356)) (and (= true (hd (hd V13356))) (and (cons? (tl (hd V13356))) (= () (tl (tl (hd V13356)))))))) (hd (tl (hd V13356)))) (true (cons cond V13356)))) 149 | 150 | (defun shen.encode-choices (V13361 V13362) (cond ((= () V13361) ()) ((and (cons? V13361) (and (cons? (hd V13361)) (and (= true (hd (hd V13361))) (and (cons? (tl (hd V13361))) (and (cons? (hd (tl (hd V13361)))) (and (= shen.choicepoint! (hd (hd (tl (hd V13361))))) (and (cons? (tl (hd (tl (hd V13361))))) (and (= () (tl (tl (hd (tl (hd V13361)))))) (and (= () (tl (tl (hd V13361)))) (= () (tl V13361))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V13361))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (if (value shen.*installing-kl*) (cons shen.sys-error (cons V13362 ())) (cons shen.f_error (cons V13362 ()))) (cons Result ())))) ())))) ())) ())) ((and (cons? V13361) (and (cons? (hd V13361)) (and (= true (hd (hd V13361))) (and (cons? (tl (hd V13361))) (and (cons? (hd (tl (hd V13361)))) (and (= shen.choicepoint! (hd (hd (tl (hd V13361))))) (and (cons? (tl (hd (tl (hd V13361))))) (and (= () (tl (tl (hd (tl (hd V13361)))))) (= () (tl (tl (hd V13361)))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V13361))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (shen.cond-form (shen.encode-choices (tl V13361) V13362)) (cons Result ())))) ())))) ())) ())) ((and (cons? V13361) (and (cons? (hd V13361)) (and (cons? (tl (hd V13361))) (and (cons? (hd (tl (hd V13361)))) (and (= shen.choicepoint! (hd (hd (tl (hd V13361))))) (and (cons? (tl (hd (tl (hd V13361))))) (and (= () (tl (tl (hd (tl (hd V13361)))))) (= () (tl (tl (hd V13361))))))))))) (cons (cons true (cons (cons let (cons Freeze (cons (cons freeze (cons (shen.cond-form (shen.encode-choices (tl V13361) V13362)) ())) (cons (cons if (cons (hd (hd V13361)) (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V13361))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (cons thaw (cons Freeze ())) (cons Result ())))) ())))) (cons (cons thaw (cons Freeze ())) ())))) ())))) ())) ())) ((and (cons? V13361) (and (cons? (hd V13361)) (and (cons? (tl (hd V13361))) (= () (tl (tl (hd V13361))))))) (cons (hd V13361) (shen.encode-choices (tl V13361) V13362))) (true (shen.f_error shen.encode-choices)))) 151 | 152 | (defun shen.case-form (V13369 V13370) (cond ((= () V13369) (cons V13370 ())) ((and (cons? V13369) (and (cons? (hd V13369)) (and (cons? (hd (hd V13369))) (and (= : (hd (hd (hd V13369)))) (and (cons? (tl (hd (hd V13369)))) (and (= shen.tests (hd (tl (hd (hd V13369))))) (and (= () (tl (tl (hd (hd V13369))))) (and (cons? (tl (hd V13369))) (and (cons? (hd (tl (hd V13369)))) (and (= shen.choicepoint! (hd (hd (tl (hd V13369))))) (and (cons? (tl (hd (tl (hd V13369))))) (and (= () (tl (tl (hd (tl (hd V13369)))))) (= () (tl (tl (hd V13369)))))))))))))))) (cons (cons true (tl (hd V13369))) (shen.case-form (tl V13369) V13370))) ((and (cons? V13369) (and (cons? (hd V13369)) (and (cons? (hd (hd V13369))) (and (= : (hd (hd (hd V13369)))) (and (cons? (tl (hd (hd V13369)))) (and (= shen.tests (hd (tl (hd (hd V13369))))) (and (= () (tl (tl (hd (hd V13369))))) (and (cons? (tl (hd V13369))) (= () (tl (tl (hd V13369)))))))))))) (cons (cons true (tl (hd V13369))) ())) ((and (cons? V13369) (and (cons? (hd V13369)) (and (cons? (hd (hd V13369))) (and (= : (hd (hd (hd V13369)))) (and (cons? (tl (hd (hd V13369)))) (and (= shen.tests (hd (tl (hd (hd V13369))))) (and (cons? (tl (hd V13369))) (= () (tl (tl (hd V13369))))))))))) (cons (cons (shen.embed-and (tl (tl (hd (hd V13369))))) (tl (hd V13369))) (shen.case-form (tl V13369) V13370))) (true (shen.f_error shen.case-form)))) 153 | 154 | (defun shen.embed-and (V13372) (cond ((and (cons? V13372) (= () (tl V13372))) (hd V13372)) ((cons? V13372) (cons and (cons (hd V13372) (cons (shen.embed-and (tl V13372)) ())))) (true (shen.f_error shen.embed-and)))) 155 | 156 | (defun shen.err-condition (V13374) (cons true (cons (cons shen.f_error (cons V13374 ())) ()))) 157 | 158 | (defun shen.sys-error (V13376) (simple-error (cn "system function " (shen.app V13376 ": unexpected argument 159 | " shen.a)))) 160 | 161 | 162 | 163 | -------------------------------------------------------------------------------- /KLambda/declarations.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (set shen.*installing-kl* false) 27 | 28 | (set shen.*history* ()) 29 | 30 | (set shen.*tc* false) 31 | 32 | (set *property-vector* (vector 20000)) 33 | 34 | (set shen.*process-counter* 0) 35 | 36 | (set shen.*varcounter* (vector 1000)) 37 | 38 | (set shen.*prologvectors* (vector 1000)) 39 | 40 | (set shen.*macroreg* (cons shen.timer-macro (cons shen.cases-macro (cons shen.abs-macro (cons shen.put/get-macro (cons shen.compile-macro (cons shen.datatype-macro (cons shen.let-macro (cons shen.assoc-macro (cons shen.make-string-macro (cons shen.output-macro (cons shen.input-macro (cons shen.error-macro (cons shen.prolog-macro (cons shen.synonyms-macro (cons shen.nl-macro (cons shen.@s-macro (cons shen.defprolog-macro (cons shen.function-macro ()))))))))))))))))))) 41 | 42 | (set *macros* (cons (lambda X (shen.timer-macro X)) (cons (lambda X (shen.cases-macro X)) (cons (lambda X (shen.abs-macro X)) (cons (lambda X (shen.put/get-macro X)) (cons (lambda X (shen.compile-macro X)) (cons (lambda X (shen.datatype-macro X)) (cons (lambda X (shen.let-macro X)) (cons (lambda X (shen.assoc-macro X)) (cons (lambda X (shen.make-string-macro X)) (cons (lambda X (shen.output-macro X)) (cons (lambda X (shen.input-macro X)) (cons (lambda X (shen.error-macro X)) (cons (lambda X (shen.prolog-macro X)) (cons (lambda X (shen.synonyms-macro X)) (cons (lambda X (shen.nl-macro X)) (cons (lambda X (shen.@s-macro X)) (cons (lambda X (shen.defprolog-macro X)) (cons (lambda X (shen.function-macro X)) ()))))))))))))))))))) 43 | 44 | (set *home-directory* ()) 45 | 46 | (set shen.*gensym* 0) 47 | 48 | (set shen.*tracking* ()) 49 | 50 | (set *home-directory* "") 51 | 52 | (set shen.*alphabet* (cons A (cons B (cons C (cons D (cons E (cons F (cons G (cons H (cons I (cons J (cons K (cons L (cons M (cons N (cons O (cons P (cons Q (cons R (cons S (cons T (cons U (cons V (cons W (cons X (cons Y (cons Z ()))))))))))))))))))))))))))) 53 | 54 | (set shen.*special* (cons @p (cons @s (cons @v (cons cons (cons lambda (cons let (cons where (cons set (cons open ())))))))))) 55 | 56 | (set shen.*extraspecial* (cons define (cons shen.process-datatype (cons input+ (cons defcc (cons shen.read+ (cons defmacro ()))))))) 57 | 58 | (set shen.*spy* false) 59 | 60 | (set shen.*datatypes* ()) 61 | 62 | (set shen.*alldatatypes* ()) 63 | 64 | (set shen.*shen-type-theory-enabled?* true) 65 | 66 | (set shen.*synonyms* ()) 67 | 68 | (set shen.*system* ()) 69 | 70 | (set shen.*signedfuncs* ()) 71 | 72 | (set shen.*maxcomplexity* 128) 73 | 74 | (set shen.*occurs* true) 75 | 76 | (set shen.*maxinferences* 1000000) 77 | 78 | (set *maximum-print-sequence-size* 20) 79 | 80 | (set shen.*catch* 0) 81 | 82 | (set shen.*call* 0) 83 | 84 | (set shen.*infs* 0) 85 | 86 | (set *hush* false) 87 | 88 | (set shen.*optimise* false) 89 | 90 | (set *version* "Shen 19.2") 91 | 92 | (defun shen.initialise_arity_table (V13378) (cond ((= () V13378) ()) ((and (cons? V13378) (cons? (tl V13378))) (let DecArity (put (hd V13378) arity (hd (tl V13378)) (value *property-vector*)) (shen.initialise_arity_table (tl (tl V13378))))) (true (shen.f_error shen.initialise_arity_table)))) 93 | 94 | (defun arity (V13380) (trap-error (get V13380 arity (value *property-vector*)) (lambda E -1))) 95 | 96 | (shen.initialise_arity_table (cons abort (cons 0 (cons absvector? (cons 1 (cons absvector (cons 1 (cons adjoin (cons 2 (cons and (cons 2 (cons append (cons 2 (cons arity (cons 1 (cons assoc (cons 2 (cons boolean? (cons 1 (cons cd (cons 1 (cons compile (cons 3 (cons concat (cons 2 (cons cons (cons 2 (cons cons? (cons 1 (cons cn (cons 2 (cons declare (cons 2 (cons destroy (cons 1 (cons difference (cons 2 (cons do (cons 2 (cons element? (cons 2 (cons empty? (cons 1 (cons enable-type-theory (cons 1 (cons shen.interror (cons 2 (cons eval (cons 1 (cons eval-kl (cons 1 (cons explode (cons 1 (cons external (cons 1 (cons fail-if (cons 2 (cons fail (cons 0 (cons fix (cons 2 (cons findall (cons 5 (cons freeze (cons 1 (cons fst (cons 1 (cons gensym (cons 1 (cons get (cons 3 (cons get-time (cons 1 (cons address-> (cons 3 (cons <-address (cons 2 (cons <-vector (cons 2 (cons > (cons 2 (cons >= (cons 2 (cons = (cons 2 (cons hd (cons 1 (cons hdv (cons 1 (cons hdstr (cons 1 (cons head (cons 1 (cons if (cons 3 (cons integer? (cons 1 (cons intern (cons 1 (cons identical (cons 4 (cons inferences (cons 0 (cons input (cons 1 (cons input+ (cons 2 (cons implementation (cons 0 (cons intersection (cons 2 (cons internal (cons 1 (cons it (cons 0 (cons kill (cons 0 (cons language (cons 0 (cons length (cons 1 (cons lineread (cons 1 (cons load (cons 1 (cons < (cons 2 (cons <= (cons 2 (cons vector (cons 1 (cons macroexpand (cons 1 (cons map (cons 2 (cons mapcan (cons 2 (cons maxinferences (cons 1 (cons not (cons 1 (cons nth (cons 2 (cons n->string (cons 1 (cons number? (cons 1 (cons occurs-check (cons 1 (cons occurrences (cons 2 (cons occurs-check (cons 1 (cons optimise (cons 1 (cons or (cons 2 (cons os (cons 0 (cons package (cons 3 (cons package? (cons 1 (cons port (cons 0 (cons porters (cons 0 (cons pos (cons 2 (cons print (cons 1 (cons profile (cons 1 (cons profile-results (cons 1 (cons pr (cons 2 (cons ps (cons 1 (cons preclude (cons 1 (cons preclude-all-but (cons 1 (cons protect (cons 1 (cons address-> (cons 3 (cons put (cons 4 (cons shen.reassemble (cons 2 (cons read-file-as-string (cons 1 (cons read-file (cons 1 (cons read (cons 1 (cons read-byte (cons 1 (cons read-from-string (cons 1 (cons receive (cons 1 (cons release (cons 0 (cons remove (cons 2 (cons require (cons 3 (cons reverse (cons 1 (cons set (cons 2 (cons simple-error (cons 1 (cons snd (cons 1 (cons specialise (cons 1 (cons spy (cons 1 (cons step (cons 1 (cons stinput (cons 0 (cons stoutput (cons 0 (cons string->n (cons 1 (cons string->symbol (cons 1 (cons string? (cons 1 (cons subst (cons 3 (cons sum (cons 1 (cons symbol? (cons 1 (cons systemf (cons 1 (cons tail (cons 1 (cons tl (cons 1 (cons tc (cons 1 (cons tc? (cons 0 (cons thaw (cons 1 (cons tlstr (cons 1 (cons track (cons 1 (cons trap-error (cons 2 (cons tuple? (cons 1 (cons type (cons 2 (cons return (cons 3 (cons undefmacro (cons 1 (cons unput (cons 3 (cons unprofile (cons 1 (cons unify (cons 4 (cons unify! (cons 4 (cons union (cons 2 (cons untrack (cons 1 (cons unspecialise (cons 1 (cons undefmacro (cons 1 (cons vector (cons 1 (cons vector-> (cons 3 (cons value (cons 1 (cons variable? (cons 1 (cons version (cons 0 (cons write-byte (cons 2 (cons write-to-file (cons 2 (cons y-or-n? (cons 1 (cons + (cons 2 (cons * (cons 2 (cons / (cons 2 (cons - (cons 2 (cons == (cons 2 (cons (cons 1 (cons @p (cons 2 (cons @v (cons 2 (cons @s (cons 2 (cons preclude (cons 1 (cons include (cons 1 (cons preclude-all-but (cons 1 (cons include-all-but (cons 1 ()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 97 | 98 | (defun systemf (V13382) (let Shen (intern "shen") (let External (get Shen shen.external-symbols (value *property-vector*)) (let Place (put Shen shen.external-symbols (adjoin V13382 External) (value *property-vector*)) V13382)))) 99 | 100 | (defun adjoin (V13385 V13386) (if (element? V13385 V13386) V13386 (cons V13385 V13386))) 101 | 102 | (put (intern "shen") shen.external-symbols (cons ! (cons } (cons { (cons --> (cons <-- (cons && (cons : (cons ; (cons :- (cons := (cons _ (cons *language* (cons *implementation* (cons *stinput* (cons *stoutput* (cons *home-directory* (cons *version* (cons *maximum-print-sequence-size* (cons *macros* (cons *os* (cons *release* (cons *property-vector* (cons @v (cons @p (cons @s (cons *port* (cons *porters* (cons *hush* (cons <- (cons -> (cons (cons == (cons = (cons >= (cons > (cons /. (cons =! (cons $ (cons - (cons / (cons * (cons + (cons <= (cons < (cons >> (cons (vector 0) (cons y-or-n? (cons write-to-file (cons write-byte (cons where (cons when (cons warn (cons version (cons verified (cons variable? (cons value (cons vector-> (cons <-vector (cons vector (cons vector? (cons unspecialise (cons untrack (cons unit (cons shen.unix (cons union (cons unify (cons unify! (cons unput (cons unprofile (cons undefmacro (cons return (cons type (cons tuple? (cons true (cons trap-error (cons track (cons time (cons thaw (cons tc? (cons tc (cons tl (cons tlstr (cons tlv (cons tail (cons systemf (cons synonyms (cons symbol (cons symbol? (cons string->symbol (cons sum (cons subst (cons string? (cons string->n (cons stream (cons string (cons stinput (cons stoutput (cons step (cons spy (cons specialise (cons snd (cons simple-error (cons set (cons save (cons str (cons run (cons reverse (cons remove (cons release (cons read (cons receive (cons read-file (cons read-file-as-bytelist (cons read-file-as-string (cons read-byte (cons read-from-string (cons package? (cons put (cons preclude (cons preclude-all-but (cons ps (cons prolog? (cons protect (cons profile-results (cons profile (cons print (cons pr (cons pos (cons porters (cons port (cons package (cons output (cons out (cons os (cons or (cons optimise (cons open (cons occurrences (cons occurs-check (cons n->string (cons number? (cons number (cons null (cons nth (cons not (cons nl (cons mode (cons macroexpand (cons maxinferences (cons mapcan (cons map (cons make-string (cons load (cons loaded (cons list (cons lineread (cons limit (cons length (cons let (cons lazy (cons lambda (cons language (cons kill (cons is (cons intersection (cons inferences (cons intern (cons integer? (cons input (cons input+ (cons include (cons include-all-but (cons it (cons in (cons internal (cons implementation (cons if (cons identical (cons head (cons hd (cons hdv (cons hdstr (cons hash (cons get (cons get-time (cons gensym (cons function (cons fst (cons freeze (cons fix (cons file (cons fail (cons fail-if (cons fwhen (cons findall (cons false (cons enable-type-theory (cons explode (cons external (cons exception (cons eval-kl (cons eval (cons error-to-string (cons error (cons empty? (cons element? (cons do (cons difference (cons destroy (cons defun (cons define (cons defmacro (cons defcc (cons defprolog (cons declare (cons datatype (cons cut (cons cn (cons cons? (cons cons (cons cond (cons concat (cons compile (cons cd (cons cases (cons call (cons close (cons bind (cons bound? (cons boolean? (cons boolean (cons bar! (cons assoc (cons arity (cons append (cons and (cons adjoin (cons <-address (cons address-> (cons absvector? (cons absvector (cons abort ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (value *property-vector*)) 103 | 104 | (defun shen.symbol-table-entry (V13388) (let ArityF (arity V13388) (if (= ArityF -1) () (if (= ArityF 0) () (cons (cons V13388 (eval-kl (shen.lambda-form V13388 ArityF))) ()))))) 105 | 106 | (defun shen.lambda-form (V13391 V13392) (cond ((= 0 V13392) V13391) (true (let X (gensym V) (cons lambda (cons X (cons (shen.lambda-form (shen.add-end V13391 X) (- V13392 1)) ()))))))) 107 | 108 | (defun shen.add-end (V13395 V13396) (cond ((cons? V13395) (append V13395 (cons V13396 ()))) (true (cons V13395 (cons V13396 ()))))) 109 | 110 | (set shen.*symbol-table* (cons (cons shen.datatype-error (lambda X (shen.datatype-error X))) (cons (cons shen.tuple (lambda X (shen.tuple X))) (cons (cons shen.pvar (lambda X (shen.pvar X))) (mapcan (lambda X (shen.symbol-table-entry X)) (external (intern "shen"))))))) 111 | 112 | (defun specialise (V13398) (do (set shen.*special* (cons V13398 (value shen.*special*))) V13398)) 113 | 114 | (defun unspecialise (V13400) (do (set shen.*special* (remove V13400 (value shen.*special*))) V13400)) 115 | 116 | 117 | 118 | -------------------------------------------------------------------------------- /KLambda/load.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun load (V13402) (let Load (let Start (get-time run) (let Result (shen.load-help (value shen.*tc*) (read-file V13402)) (let Finish (get-time run) (let Time (- Finish Start) (let Message (shen.prhush (cn " 27 | run time: " (cn (str Time) " secs 28 | ")) (stoutput)) Result))))) (let Infs (if (value shen.*tc*) (shen.prhush (cn " 29 | typechecked in " (shen.app (inferences) " inferences 30 | " shen.a)) (stoutput)) shen.skip) loaded))) 31 | 32 | (defun shen.load-help (V13409 V13410) (cond ((= false V13409) (map (lambda X (shen.prhush (shen.app (shen.eval-without-macros X) " 33 | " shen.s) (stoutput))) V13410)) (true (let RemoveSynonyms (mapcan (lambda X (shen.remove-synonyms X)) V13410) (let Table (mapcan (lambda X (shen.typetable X)) RemoveSynonyms) (let Assume (map (lambda X (shen.assumetype X)) Table) (trap-error (map (lambda X (shen.typecheck-and-load X)) RemoveSynonyms) (lambda E (shen.unwind-types E Table))))))))) 34 | 35 | (defun shen.remove-synonyms (V13412) (cond ((and (cons? V13412) (= shen.synonyms-help (hd V13412))) (do (eval V13412) ())) (true (cons V13412 ())))) 36 | 37 | (defun shen.typecheck-and-load (V13414) (do (nl 1) (shen.typecheck-and-evaluate V13414 (gensym A)))) 38 | 39 | (defun shen.typetable (V13420) (cond ((and (cons? V13420) (and (= define (hd V13420)) (cons? (tl V13420)))) (let Sig (compile (lambda Y (shen. Y)) (tl (tl V13420)) (lambda E (simple-error (shen.app (hd (tl V13420)) " lacks a proper signature. 40 | " shen.a)))) (cons (cons (hd (tl V13420)) Sig) ()))) (true ()))) 41 | 42 | (defun shen.assumetype (V13422) (cond ((cons? V13422) (declare (hd V13422) (tl V13422))) (true (shen.f_error shen.assumetype)))) 43 | 44 | (defun shen.unwind-types (V13429 V13430) (cond ((= () V13430) (simple-error (error-to-string V13429))) ((and (cons? V13430) (cons? (hd V13430))) (do (shen.remtype (hd (hd V13430))) (shen.unwind-types V13429 (tl V13430)))) (true (shen.f_error shen.unwind-types)))) 45 | 46 | (defun shen.remtype (V13432) (set shen.*signedfuncs* (shen.removetype V13432 (value shen.*signedfuncs*)))) 47 | 48 | (defun shen.removetype (V13440 V13441) (cond ((= () V13441) ()) ((and (cons? V13441) (and (cons? (hd V13441)) (= (hd (hd V13441)) V13440))) (shen.removetype (hd (hd V13441)) (tl V13441))) ((cons? V13441) (cons (hd V13441) (shen.removetype V13440 (tl V13441)))) (true (shen.f_error shen.removetype)))) 49 | 50 | (defun shen. (V13443) (let Parse_shen. (shen. V13443) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail)))) 51 | 52 | (defun write-to-file (V13446 V13447) (let Stream (open V13446 out) (let String (if (string? V13447) (shen.app V13447 " 53 | 54 | " shen.a) (shen.app V13447 " 55 | 56 | " shen.s)) (let Write (pr String Stream) (let Close (close Stream) V13447))))) 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /KLambda/macros.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun macroexpand (V13449) (let Y (shen.compose (value *macros*) V13449) (if (= V13449 Y) V13449 (shen.walk (lambda Z (macroexpand Z)) Y)))) 27 | 28 | (defun shen.error-macro (V13451) (cond ((and (cons? V13451) (and (= error (hd V13451)) (cons? (tl V13451)))) (cons simple-error (cons (shen.mkstr (hd (tl V13451)) (tl (tl V13451))) ()))) (true V13451))) 29 | 30 | (defun shen.output-macro (V13453) (cond ((and (cons? V13453) (and (= output (hd V13453)) (cons? (tl V13453)))) (cons shen.prhush (cons (shen.mkstr (hd (tl V13453)) (tl (tl V13453))) (cons (cons stoutput ()) ())))) ((and (cons? V13453) (and (= pr (hd V13453)) (and (cons? (tl V13453)) (= () (tl (tl V13453)))))) (cons pr (cons (hd (tl V13453)) (cons (cons stoutput ()) ())))) (true V13453))) 31 | 32 | (defun shen.make-string-macro (V13455) (cond ((and (cons? V13455) (and (= make-string (hd V13455)) (cons? (tl V13455)))) (shen.mkstr (hd (tl V13455)) (tl (tl V13455)))) (true V13455))) 33 | 34 | (defun shen.input-macro (V13457) (cond ((and (cons? V13457) (and (= lineread (hd V13457)) (= () (tl V13457)))) (cons lineread (cons (cons stinput ()) ()))) ((and (cons? V13457) (and (= input (hd V13457)) (= () (tl V13457)))) (cons input (cons (cons stinput ()) ()))) ((and (cons? V13457) (and (= read (hd V13457)) (= () (tl V13457)))) (cons read (cons (cons stinput ()) ()))) ((and (cons? V13457) (and (= input+ (hd V13457)) (and (cons? (tl V13457)) (= () (tl (tl V13457)))))) (cons input+ (cons (hd (tl V13457)) (cons (cons stinput ()) ())))) ((and (cons? V13457) (and (= read-byte (hd V13457)) (= () (tl V13457)))) (cons read-byte (cons (cons stinput ()) ()))) (true V13457))) 35 | 36 | (defun shen.compose (V13460 V13461) (cond ((= () V13460) V13461) ((cons? V13460) (shen.compose (tl V13460) ((hd V13460) V13461))) (true (shen.f_error shen.compose)))) 37 | 38 | (defun shen.compile-macro (V13463) (cond ((and (cons? V13463) (and (= compile (hd V13463)) (and (cons? (tl V13463)) (and (cons? (tl (tl V13463))) (= () (tl (tl (tl V13463)))))))) (cons compile (cons (hd (tl V13463)) (cons (hd (tl (tl V13463))) (cons (cons lambda (cons E (cons (cons if (cons (cons cons? (cons E ())) (cons (cons error (cons "parse error here: ~S~%" (cons E ()))) (cons (cons error (cons "parse error~%" ())) ())))) ()))) ()))))) (true V13463))) 39 | 40 | (defun shen.prolog-macro (V13465) (cond ((and (cons? V13465) (= prolog? (hd V13465))) (let F (gensym shen.f) (let Receive (shen.receive-terms (tl V13465)) (let PrologDef (eval (append (cons defprolog (cons F ())) (append Receive (append (cons <-- ()) (append (shen.pass-literals (tl V13465)) (cons ; ())))))) (let Query (cons F (append Receive (cons (cons shen.start-new-prolog-process ()) (cons (cons freeze (cons true ())) ())))) Query))))) (true V13465))) 41 | 42 | (defun shen.receive-terms (V13471) (cond ((= () V13471) ()) ((and (cons? V13471) (and (cons? (hd V13471)) (and (= receive (hd (hd V13471))) (and (cons? (tl (hd V13471))) (= () (tl (tl (hd V13471)))))))) (cons (hd (tl (hd V13471))) (shen.receive-terms (tl V13471)))) ((cons? V13471) (shen.receive-terms (tl V13471))) (true (shen.f_error shen.receive-terms)))) 43 | 44 | (defun shen.pass-literals (V13475) (cond ((= () V13475) ()) ((and (cons? V13475) (and (cons? (hd V13475)) (and (= receive (hd (hd V13475))) (and (cons? (tl (hd V13475))) (= () (tl (tl (hd V13475)))))))) (shen.pass-literals (tl V13475))) ((cons? V13475) (cons (hd V13475) (shen.pass-literals (tl V13475)))) (true (shen.f_error shen.pass-literals)))) 45 | 46 | (defun shen.defprolog-macro (V13477) (cond ((and (cons? V13477) (and (= defprolog (hd V13477)) (cons? (tl V13477)))) (compile (lambda Y (shen. Y)) (tl V13477) (lambda Y (shen.prolog-error (hd (tl V13477)) Y)))) (true V13477))) 47 | 48 | (defun shen.datatype-macro (V13479) (cond ((and (cons? V13479) (and (= datatype (hd V13479)) (cons? (tl V13479)))) (cons shen.process-datatype (cons (shen.intern-type (hd (tl V13479))) (cons (cons compile (cons (cons lambda (cons X (cons (cons shen. (cons X ())) ()))) (cons (shen.rcons_form (tl (tl V13479))) (cons (cons function (cons shen.datatype-error ())) ())))) ())))) (true V13479))) 49 | 50 | (defun shen.intern-type (V13481) (intern (cn "type#" (str V13481)))) 51 | 52 | (defun shen.@s-macro (V13483) (cond ((and (cons? V13483) (and (= @s (hd V13483)) (and (cons? (tl V13483)) (and (cons? (tl (tl V13483))) (cons? (tl (tl (tl V13483)))))))) (cons @s (cons (hd (tl V13483)) (cons (shen.@s-macro (cons @s (tl (tl V13483)))) ())))) ((and (cons? V13483) (and (= @s (hd V13483)) (and (cons? (tl V13483)) (and (cons? (tl (tl V13483))) (and (= () (tl (tl (tl V13483)))) (string? (hd (tl V13483)))))))) (let E (explode (hd (tl V13483))) (if (> (length E) 1) (shen.@s-macro (cons @s (append E (tl (tl V13483))))) V13483))) (true V13483))) 53 | 54 | (defun shen.synonyms-macro (V13485) (cond ((and (cons? V13485) (= synonyms (hd V13485))) (cons shen.synonyms-help (cons (shen.rcons_form (shen.curry-synonyms (tl V13485))) ()))) (true V13485))) 55 | 56 | (defun shen.curry-synonyms (V13487) (map (lambda X (shen.curry-type X)) V13487)) 57 | 58 | (defun shen.nl-macro (V13489) (cond ((and (cons? V13489) (and (= nl (hd V13489)) (= () (tl V13489)))) (cons nl (cons 1 ()))) (true V13489))) 59 | 60 | (defun shen.assoc-macro (V13491) (cond ((and (cons? V13491) (and (cons? (tl V13491)) (and (cons? (tl (tl V13491))) (and (cons? (tl (tl (tl V13491)))) (element? (hd V13491) (cons @p (cons @v (cons append (cons and (cons or (cons + (cons * (cons do ()))))))))))))) (cons (hd V13491) (cons (hd (tl V13491)) (cons (shen.assoc-macro (cons (hd V13491) (tl (tl V13491)))) ())))) (true V13491))) 61 | 62 | (defun shen.let-macro (V13493) (cond ((and (cons? V13493) (and (= let (hd V13493)) (and (cons? (tl V13493)) (and (cons? (tl (tl V13493))) (and (cons? (tl (tl (tl V13493)))) (cons? (tl (tl (tl (tl V13493)))))))))) (cons let (cons (hd (tl V13493)) (cons (hd (tl (tl V13493))) (cons (shen.let-macro (cons let (tl (tl (tl V13493))))) ()))))) (true V13493))) 63 | 64 | (defun shen.abs-macro (V13495) (cond ((and (cons? V13495) (and (= /. (hd V13495)) (and (cons? (tl V13495)) (and (cons? (tl (tl V13495))) (cons? (tl (tl (tl V13495)))))))) (cons lambda (cons (hd (tl V13495)) (cons (shen.abs-macro (cons /. (tl (tl V13495)))) ())))) ((and (cons? V13495) (and (= /. (hd V13495)) (and (cons? (tl V13495)) (and (cons? (tl (tl V13495))) (= () (tl (tl (tl V13495)))))))) (cons lambda (tl V13495))) (true V13495))) 65 | 66 | (defun shen.cases-macro (V13499) (cond ((and (cons? V13499) (and (= cases (hd V13499)) (and (cons? (tl V13499)) (and (= true (hd (tl V13499))) (cons? (tl (tl V13499))))))) (hd (tl (tl V13499)))) ((and (cons? V13499) (and (= cases (hd V13499)) (and (cons? (tl V13499)) (and (cons? (tl (tl V13499))) (= () (tl (tl (tl V13499)))))))) (cons if (cons (hd (tl V13499)) (cons (hd (tl (tl V13499))) (cons (cons simple-error (cons "error: cases exhausted" ())) ()))))) ((and (cons? V13499) (and (= cases (hd V13499)) (and (cons? (tl V13499)) (cons? (tl (tl V13499)))))) (cons if (cons (hd (tl V13499)) (cons (hd (tl (tl V13499))) (cons (shen.cases-macro (cons cases (tl (tl (tl V13499))))) ()))))) ((and (cons? V13499) (and (= cases (hd V13499)) (and (cons? (tl V13499)) (= () (tl (tl V13499)))))) (simple-error "error: odd number of case elements 67 | ")) (true V13499))) 68 | 69 | (defun shen.timer-macro (V13501) (cond ((and (cons? V13501) (and (= time (hd V13501)) (and (cons? (tl V13501)) (= () (tl (tl V13501)))))) (shen.let-macro (cons let (cons Start (cons (cons get-time (cons run ())) (cons Result (cons (hd (tl V13501)) (cons Finish (cons (cons get-time (cons run ())) (cons Time (cons (cons - (cons Finish (cons Start ()))) (cons Message (cons (cons shen.prhush (cons (cons cn (cons " 70 | run time: " (cons (cons cn (cons (cons str (cons Time ())) (cons " secs 71 | " ()))) ()))) (cons (cons stoutput ()) ()))) (cons Result ())))))))))))))) (true V13501))) 72 | 73 | (defun shen.tuple-up (V13503) (cond ((cons? V13503) (cons @p (cons (hd V13503) (cons (shen.tuple-up (tl V13503)) ())))) (true V13503))) 74 | 75 | (defun shen.put/get-macro (V13505) (cond ((and (cons? V13505) (and (= put (hd V13505)) (and (cons? (tl V13505)) (and (cons? (tl (tl V13505))) (and (cons? (tl (tl (tl V13505)))) (= () (tl (tl (tl (tl V13505)))))))))) (cons put (cons (hd (tl V13505)) (cons (hd (tl (tl V13505))) (cons (hd (tl (tl (tl V13505)))) (cons (cons value (cons *property-vector* ())) ())))))) ((and (cons? V13505) (and (= get (hd V13505)) (and (cons? (tl V13505)) (and (cons? (tl (tl V13505))) (= () (tl (tl (tl V13505)))))))) (cons get (cons (hd (tl V13505)) (cons (hd (tl (tl V13505))) (cons (cons value (cons *property-vector* ())) ()))))) ((and (cons? V13505) (and (= unput (hd V13505)) (and (cons? (tl V13505)) (and (cons? (tl (tl V13505))) (= () (tl (tl (tl V13505)))))))) (cons unput (cons (hd (tl V13505)) (cons (hd (tl (tl V13505))) (cons (cons value (cons *property-vector* ())) ()))))) (true V13505))) 76 | 77 | (defun shen.function-macro (V13507) (cond ((and (cons? V13507) (and (= function (hd V13507)) (and (cons? (tl V13507)) (= () (tl (tl V13507)))))) (shen.function-abstraction (hd (tl V13507)) (arity (hd (tl V13507))))) (true V13507))) 78 | 79 | (defun shen.function-abstraction (V13510 V13511) (cond ((= 0 V13511) (simple-error (shen.app V13510 " has no lambda form 80 | " shen.a))) ((= -1 V13511) (cons function (cons V13510 ()))) (true (shen.function-abstraction-help V13510 V13511 ())))) 81 | 82 | (defun shen.function-abstraction-help (V13515 V13516 V13517) (cond ((= 0 V13516) (cons V13515 V13517)) (true (let X (gensym V) (cons /. (cons X (cons (shen.function-abstraction-help V13515 (- V13516 1) (append V13517 (cons X ()))) ()))))))) 83 | 84 | (defun undefmacro (V13519) (let MacroReg (value shen.*macroreg*) (let Pos (shen.findpos V13519 MacroReg) (let Remove1 (set shen.*macroreg* (remove V13519 MacroReg)) (let Remove2 (set *macros* (shen.remove-nth Pos (value *macros*))) V13519))))) 85 | 86 | (defun shen.findpos (V13529 V13530) (cond ((= () V13530) (simple-error (shen.app V13529 " is not a macro 87 | " shen.a))) ((and (cons? V13530) (= (hd V13530) V13529)) 1) ((cons? V13530) (+ 1 (shen.findpos V13529 (tl V13530)))) (true (shen.f_error shen.findpos)))) 88 | 89 | (defun shen.remove-nth (V13535 V13536) (cond ((and (= 1 V13535) (cons? V13536)) (tl V13536)) ((cons? V13536) (cons (hd V13536) (shen.remove-nth (- V13535 1) (tl V13536)))) (true (shen.f_error shen.remove-nth)))) 90 | 91 | 92 | 93 | -------------------------------------------------------------------------------- /KLambda/reader.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun read-file-as-bytelist (V14083) (let Stream (open V14083 in) (let Byte (read-byte Stream) (let Bytes (shen.read-file-as-bytelist-help Stream Byte ()) (let Close (close Stream) (reverse Bytes)))))) 27 | 28 | (defun shen.read-file-as-bytelist-help (V14087 V14088 V14089) (cond ((= -1 V14088) V14089) (true (shen.read-file-as-bytelist-help V14087 (read-byte V14087) (cons V14088 V14089))))) 29 | 30 | (defun read-file-as-string (V14091) (let Stream (open V14091 in) (shen.rfas-h Stream (read-byte Stream) ""))) 31 | 32 | (defun shen.rfas-h (V14095 V14096 V14097) (cond ((= -1 V14096) (do (close V14095) V14097)) (true (shen.rfas-h V14095 (read-byte V14095) (cn V14097 (n->string V14096)))))) 33 | 34 | (defun input (V14099) (eval-kl (read V14099))) 35 | 36 | (defun input+ (V14102 V14103) (let Mono? (shen.monotype V14102) (let Input (read V14103) (if (= false (shen.typecheck Input (shen.demodulate V14102))) (simple-error (cn "type error: " (shen.app Input (cn " is not of type " (shen.app V14102 " 37 | " shen.r)) shen.r))) (eval-kl Input))))) 38 | 39 | (defun shen.monotype (V14105) (cond ((cons? V14105) (map (lambda Z (shen.monotype Z)) V14105)) (true (if (variable? V14105) (simple-error (cn "input+ expects a monotype: not " (shen.app V14105 " 40 | " shen.a))) V14105)))) 41 | 42 | (defun read (V14107) (hd (shen.read-loop V14107 (read-byte V14107) ()))) 43 | 44 | (defun it () (value shen.*it*)) 45 | 46 | (defun shen.read-loop (V14115 V14116 V14117) (cond ((= 94 V14116) (simple-error "read aborted")) ((= -1 V14116) (if (empty? V14117) (simple-error "error: empty stream") (compile (lambda X (shen. X)) V14117 (lambda E E)))) ((shen.terminator? V14116) (let AllBytes (append V14117 (cons V14116 ())) (let It (shen.record-it AllBytes) (let Read (compile (lambda X (shen. X)) AllBytes (lambda E shen.nextbyte)) (if (or (= Read shen.nextbyte) (empty? Read)) (shen.read-loop V14115 (read-byte V14115) AllBytes) Read))))) (true (shen.read-loop V14115 (read-byte V14115) (append V14117 (cons V14116 ())))))) 47 | 48 | (defun shen.terminator? (V14119) (element? V14119 (cons 9 (cons 10 (cons 13 (cons 32 (cons 34 (cons 41 (cons 93 ()))))))))) 49 | 50 | (defun lineread (V14121) (shen.lineread-loop (read-byte V14121) () V14121)) 51 | 52 | (defun shen.lineread-loop (V14126 V14127 V14128) (cond ((= -1 V14126) (if (empty? V14127) (simple-error "empty stream") (compile (lambda X (shen. X)) V14127 (lambda E E)))) ((= V14126 (shen.hat)) (simple-error "line read aborted")) ((element? V14126 (cons (shen.newline) (cons (shen.carriage-return) ()))) (let Line (compile (lambda X (shen. X)) V14127 (lambda E shen.nextline)) (let It (shen.record-it V14127) (if (or (= Line shen.nextline) (empty? Line)) (shen.lineread-loop (read-byte V14128) (append V14127 (cons V14126 ())) V14128) Line)))) (true (shen.lineread-loop (read-byte V14128) (append V14127 (cons V14126 ())) V14128)))) 53 | 54 | (defun shen.record-it (V14130) (let TrimLeft (shen.trim-whitespace V14130) (let TrimRight (shen.trim-whitespace (reverse TrimLeft)) (let Trimmed (reverse TrimRight) (shen.record-it-h Trimmed))))) 55 | 56 | (defun shen.trim-whitespace (V14132) (cond ((and (cons? V14132) (element? (hd V14132) (cons 9 (cons 10 (cons 13 (cons 32 ())))))) (shen.trim-whitespace (tl V14132))) (true V14132))) 57 | 58 | (defun shen.record-it-h (V14134) (do (set shen.*it* (shen.cn-all (map (lambda X (n->string X)) V14134))) V14134)) 59 | 60 | (defun shen.cn-all (V14136) (cond ((= () V14136) "") ((cons? V14136) (cn (hd V14136) (shen.cn-all (tl V14136)))) (true (shen.f_error shen.cn-all)))) 61 | 62 | (defun read-file (V14138) (let Bytelist (read-file-as-bytelist V14138) (compile (lambda X (shen. X)) Bytelist (lambda X (shen.read-error X))))) 63 | 64 | (defun read-from-string (V14140) (let Ns (map (lambda X (string->n X)) (explode V14140)) (compile (lambda X (shen. X)) Ns (lambda X (shen.read-error X))))) 65 | 66 | (defun shen.read-error (V14148) (cond ((and (cons? V14148) (and (cons? (hd V14148)) (and (cons? (tl V14148)) (= () (tl (tl V14148)))))) (simple-error (cn "read error here: 67 | 68 | " (shen.app (shen.compress-50 50 (hd V14148)) " 69 | " shen.a)))) (true (simple-error "read error 70 | ")))) 71 | 72 | (defun shen.compress-50 (V14155 V14156) (cond ((= () V14156) "") ((= 0 V14155) "") ((cons? V14156) (cn (n->string (hd V14156)) (shen.compress-50 (- V14155 1) (tl V14156)))) (true (shen.f_error shen.compress-50)))) 73 | 74 | (defun shen. (V14158) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (macroexpand (shen.cons_form (shen.hdtl Parse_shen.))) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.package-macro (macroexpand (shen.hdtl Parse_shen.)) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons { (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons } (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons bar! (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons ; (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons := (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons :- (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons : (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (intern ",") (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (macroexpand (shen.hdtl Parse_shen.)) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14158) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V14158) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse))) 75 | 76 | (defun shen. (V14160) (if (and (cons? (hd V14160)) (= 91 (hd (hd V14160)))) (shen.pair (hd (shen.pair (tl (hd V14160)) (shen.hdtl V14160))) shen.skip) (fail))) 77 | 78 | (defun shen. (V14162) (if (and (cons? (hd V14162)) (= 93 (hd (hd V14162)))) (shen.pair (hd (shen.pair (tl (hd V14162)) (shen.hdtl V14162))) shen.skip) (fail))) 79 | 80 | (defun shen. (V14164) (if (and (cons? (hd V14164)) (= 123 (hd (hd V14164)))) (shen.pair (hd (shen.pair (tl (hd V14164)) (shen.hdtl V14164))) shen.skip) (fail))) 81 | 82 | (defun shen. (V14166) (if (and (cons? (hd V14166)) (= 125 (hd (hd V14166)))) (shen.pair (hd (shen.pair (tl (hd V14166)) (shen.hdtl V14166))) shen.skip) (fail))) 83 | 84 | (defun shen. (V14168) (if (and (cons? (hd V14168)) (= 124 (hd (hd V14168)))) (shen.pair (hd (shen.pair (tl (hd V14168)) (shen.hdtl V14168))) shen.skip) (fail))) 85 | 86 | (defun shen. (V14170) (if (and (cons? (hd V14170)) (= 59 (hd (hd V14170)))) (shen.pair (hd (shen.pair (tl (hd V14170)) (shen.hdtl V14170))) shen.skip) (fail))) 87 | 88 | (defun shen. (V14172) (if (and (cons? (hd V14172)) (= 58 (hd (hd V14172)))) (shen.pair (hd (shen.pair (tl (hd V14172)) (shen.hdtl V14172))) shen.skip) (fail))) 89 | 90 | (defun shen. (V14174) (if (and (cons? (hd V14174)) (= 44 (hd (hd V14174)))) (shen.pair (hd (shen.pair (tl (hd V14174)) (shen.hdtl V14174))) shen.skip) (fail))) 91 | 92 | (defun shen. (V14176) (if (and (cons? (hd V14176)) (= 61 (hd (hd V14176)))) (shen.pair (hd (shen.pair (tl (hd V14176)) (shen.hdtl V14176))) shen.skip) (fail))) 93 | 94 | (defun shen. (V14178) (if (and (cons? (hd V14178)) (= 45 (hd (hd V14178)))) (shen.pair (hd (shen.pair (tl (hd V14178)) (shen.hdtl V14178))) shen.skip) (fail))) 95 | 96 | (defun shen. (V14180) (if (and (cons? (hd V14180)) (= 40 (hd (hd V14180)))) (shen.pair (hd (shen.pair (tl (hd V14180)) (shen.hdtl V14180))) shen.skip) (fail))) 97 | 98 | (defun shen. (V14182) (if (and (cons? (hd V14182)) (= 41 (hd (hd V14182)))) (shen.pair (hd (shen.pair (tl (hd V14182)) (shen.hdtl V14182))) shen.skip) (fail))) 99 | 100 | (defun shen. (V14184) (let YaccParse (let Parse_shen. (shen. V14184) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.control-chars (shen.hdtl Parse_shen.))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14184) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14184) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (if (= (shen.hdtl Parse_shen.) "<>") (cons vector (cons 0 ())) (intern (shen.hdtl Parse_shen.)))) (fail))) YaccParse)) YaccParse))) 101 | 102 | (defun shen.control-chars (V14186) (cond ((= () V14186) "") ((and (cons? V14186) (and (= "c" (hd V14186)) (and (cons? (tl V14186)) (= "#" (hd (tl V14186)))))) (let CodePoint (shen.code-point (tl (tl V14186))) (let AfterCodePoint (shen.after-codepoint (tl (tl V14186))) (@s (n->string (shen.decimalise CodePoint)) (shen.control-chars AfterCodePoint))))) ((cons? V14186) (@s (hd V14186) (shen.control-chars (tl V14186)))) (true (shen.f_error shen.control-chars)))) 103 | 104 | (defun shen.code-point (V14190) (cond ((and (cons? V14190) (= ";" (hd V14190))) "") ((and (cons? V14190) (element? (hd V14190) (cons "0" (cons "1" (cons "2" (cons "3" (cons "4" (cons "5" (cons "6" (cons "7" (cons "8" (cons "9" (cons "0" ()))))))))))))) (cons (hd V14190) (shen.code-point (tl V14190)))) (true (simple-error (cn "code point parse error " (shen.app V14190 " 105 | " shen.a)))))) 106 | 107 | (defun shen.after-codepoint (V14196) (cond ((= () V14196) ()) ((and (cons? V14196) (= ";" (hd V14196))) (tl V14196)) ((cons? V14196) (shen.after-codepoint (tl V14196))) (true (shen.f_error shen.after-codepoint)))) 108 | 109 | (defun shen.decimalise (V14198) (shen.pre (reverse (shen.digits->integers V14198)) 0)) 110 | 111 | (defun shen.digits->integers (V14204) (cond ((and (cons? V14204) (= "0" (hd V14204))) (cons 0 (shen.digits->integers (tl V14204)))) ((and (cons? V14204) (= "1" (hd V14204))) (cons 1 (shen.digits->integers (tl V14204)))) ((and (cons? V14204) (= "2" (hd V14204))) (cons 2 (shen.digits->integers (tl V14204)))) ((and (cons? V14204) (= "3" (hd V14204))) (cons 3 (shen.digits->integers (tl V14204)))) ((and (cons? V14204) (= "4" (hd V14204))) (cons 4 (shen.digits->integers (tl V14204)))) ((and (cons? V14204) (= "5" (hd V14204))) (cons 5 (shen.digits->integers (tl V14204)))) ((and (cons? V14204) (= "6" (hd V14204))) (cons 6 (shen.digits->integers (tl V14204)))) ((and (cons? V14204) (= "7" (hd V14204))) (cons 7 (shen.digits->integers (tl V14204)))) ((and (cons? V14204) (= "8" (hd V14204))) (cons 8 (shen.digits->integers (tl V14204)))) ((and (cons? V14204) (= "9" (hd V14204))) (cons 9 (shen.digits->integers (tl V14204)))) (true ()))) 112 | 113 | (defun shen. (V14206) (let Parse_shen. (shen. V14206) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (@s (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail)))) 114 | 115 | (defun shen. (V14208) (let YaccParse (let Parse_shen. (shen. V14208) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (@s (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V14208) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) "") (fail))) YaccParse))) 116 | 117 | (defun shen. (V14210) (let YaccParse (let Parse_shen. (shen. V14210) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14210) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) YaccParse))) 118 | 119 | (defun shen. (V14212) (if (cons? (hd V14212)) (let Parse_Byte (hd (hd V14212)) (if (shen.numbyte? Parse_Byte) (shen.pair (hd (shen.pair (tl (hd V14212)) (shen.hdtl V14212))) (n->string Parse_Byte)) (fail))) (fail))) 120 | 121 | (defun shen.numbyte? (V14218) (cond ((= 48 V14218) true) ((= 49 V14218) true) ((= 50 V14218) true) ((= 51 V14218) true) ((= 52 V14218) true) ((= 53 V14218) true) ((= 54 V14218) true) ((= 55 V14218) true) ((= 56 V14218) true) ((= 57 V14218) true) (true false))) 122 | 123 | (defun shen. (V14220) (if (cons? (hd V14220)) (let Parse_Byte (hd (hd V14220)) (if (shen.symbol-code? Parse_Byte) (shen.pair (hd (shen.pair (tl (hd V14220)) (shen.hdtl V14220))) (n->string Parse_Byte)) (fail))) (fail))) 124 | 125 | (defun shen.symbol-code? (V14222) (or (= V14222 126) (or (and (> V14222 94) (< V14222 123)) (or (and (> V14222 59) (< V14222 91)) (or (and (> V14222 41) (and (< V14222 58) (not (= V14222 44)))) (or (and (> V14222 34) (< V14222 40)) (= V14222 33))))))) 126 | 127 | (defun shen. (V14224) (let Parse_shen. (shen. V14224) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (fail)))) 128 | 129 | (defun shen. (V14226) (if (cons? (hd V14226)) (let Parse_Byte (hd (hd V14226)) (if (= Parse_Byte 34) (shen.pair (hd (shen.pair (tl (hd V14226)) (shen.hdtl V14226))) Parse_Byte) (fail))) (fail))) 130 | 131 | (defun shen. (V14228) (let YaccParse (let Parse_shen. (shen. V14228) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V14228) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) YaccParse))) 132 | 133 | (defun shen. (V14230) (if (cons? (hd V14230)) (let Parse_Byte (hd (hd V14230)) (shen.pair (hd (shen.pair (tl (hd V14230)) (shen.hdtl V14230))) (n->string Parse_Byte))) (fail))) 134 | 135 | (defun shen. (V14232) (if (cons? (hd V14232)) (let Parse_Byte (hd (hd V14232)) (if (not (= Parse_Byte 34)) (shen.pair (hd (shen.pair (tl (hd V14232)) (shen.hdtl V14232))) (n->string Parse_Byte)) (fail))) (fail))) 136 | 137 | (defun shen. (V14234) (let YaccParse (let Parse_shen. (shen. V14234) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (- 0 (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14234) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14234) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (* (shen.expt 10 (shen.hdtl Parse_shen.)) (+ (shen.pre (reverse (shen.hdtl Parse_shen.)) 0) (shen.post (shen.hdtl Parse_shen.) 1)))) (fail))) (fail))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14234) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (* (shen.expt 10 (shen.hdtl Parse_shen.)) (shen.pre (reverse (shen.hdtl Parse_shen.)) 0))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14234) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (+ (shen.pre (reverse (shen.hdtl Parse_shen.)) 0) (shen.post (shen.hdtl Parse_shen.) 1))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14234) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pre (reverse (shen.hdtl Parse_shen.)) 0)) (fail))) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse))) 138 | 139 | (defun shen. (V14236) (if (and (cons? (hd V14236)) (= 101 (hd (hd V14236)))) (shen.pair (hd (shen.pair (tl (hd V14236)) (shen.hdtl V14236))) shen.skip) (fail))) 140 | 141 | (defun shen. (V14238) (let YaccParse (let Parse_shen. (shen. V14238) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (- 0 (shen.pre (reverse (shen.hdtl Parse_shen.)) 0))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14238) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pre (reverse (shen.hdtl Parse_shen.)) 0)) (fail))) YaccParse))) 142 | 143 | (defun shen. (V14240) (if (cons? (hd V14240)) (let Parse_Byte (hd (hd V14240)) (if (= Parse_Byte 43) (shen.pair (hd (shen.pair (tl (hd V14240)) (shen.hdtl V14240))) Parse_Byte) (fail))) (fail))) 144 | 145 | (defun shen. (V14242) (if (cons? (hd V14242)) (let Parse_Byte (hd (hd V14242)) (if (= Parse_Byte 46) (shen.pair (hd (shen.pair (tl (hd V14242)) (shen.hdtl V14242))) Parse_Byte) (fail))) (fail))) 146 | 147 | (defun shen. (V14244) (let YaccParse (let Parse_shen. (shen. V14244) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V14244) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) YaccParse))) 148 | 149 | (defun shen. (V14246) (let Parse_shen. (shen. V14246) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail)))) 150 | 151 | (defun shen. (V14248) (let YaccParse (let Parse_shen. (shen. V14248) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14248) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) ())) (fail))) YaccParse))) 152 | 153 | (defun shen. (V14250) (if (cons? (hd V14250)) (let Parse_X (hd (hd V14250)) (if (shen.numbyte? Parse_X) (shen.pair (hd (shen.pair (tl (hd V14250)) (shen.hdtl V14250))) (shen.byte->digit Parse_X)) (fail))) (fail))) 154 | 155 | (defun shen.byte->digit (V14252) (cond ((= 48 V14252) 0) ((= 49 V14252) 1) ((= 50 V14252) 2) ((= 51 V14252) 3) ((= 52 V14252) 4) ((= 53 V14252) 5) ((= 54 V14252) 6) ((= 55 V14252) 7) ((= 56 V14252) 8) ((= 57 V14252) 9) (true (shen.f_error shen.byte->digit)))) 156 | 157 | (defun shen.pre (V14257 V14258) (cond ((= () V14257) 0) ((cons? V14257) (+ (* (shen.expt 10 V14258) (hd V14257)) (shen.pre (tl V14257) (+ V14258 1)))) (true (shen.f_error shen.pre)))) 158 | 159 | (defun shen.post (V14263 V14264) (cond ((= () V14263) 0) ((cons? V14263) (+ (* (shen.expt 10 (- 0 V14264)) (hd V14263)) (shen.post (tl V14263) (+ V14264 1)))) (true (shen.f_error shen.post)))) 160 | 161 | (defun shen.expt (V14269 V14270) (cond ((= 0 V14270) 1) ((> V14270 0) (* V14269 (shen.expt V14269 (- V14270 1)))) (true (* 1.0 (/ (shen.expt V14269 (+ V14270 1)) V14269))))) 162 | 163 | (defun shen. (V14272) (let Parse_shen. (shen. V14272) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail)))) 164 | 165 | (defun shen. (V14274) (let Parse_shen. (shen. V14274) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail)))) 166 | 167 | (defun shen. (V14276) (let YaccParse (let Parse_shen. (shen. V14276) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14276) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) YaccParse))) 168 | 169 | (defun shen. (V14278) (let Parse_shen. (shen. V14278) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (fail))) (fail)))) 170 | 171 | (defun shen. (V14280) (if (and (cons? (hd V14280)) (= 92 (hd (hd V14280)))) (shen.pair (hd (shen.pair (tl (hd V14280)) (shen.hdtl V14280))) shen.skip) (fail))) 172 | 173 | (defun shen. (V14282) (let YaccParse (let Parse_shen. (shen. V14282) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V14282) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) shen.skip) (fail))) YaccParse))) 174 | 175 | (defun shen. (V14284) (if (cons? (hd V14284)) (let Parse_X (hd (hd V14284)) (if (not (element? Parse_X (cons 10 (cons 13 ())))) (shen.pair (hd (shen.pair (tl (hd V14284)) (shen.hdtl V14284))) shen.skip) (fail))) (fail))) 176 | 177 | (defun shen. (V14286) (if (cons? (hd V14286)) (let Parse_X (hd (hd V14286)) (if (element? Parse_X (cons 10 (cons 13 ()))) (shen.pair (hd (shen.pair (tl (hd V14286)) (shen.hdtl V14286))) shen.skip) (fail))) (fail))) 178 | 179 | (defun shen. (V14288) (let Parse_shen. (shen. V14288) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (fail)))) 180 | 181 | (defun shen. (V14290) (if (and (cons? (hd V14290)) (= 42 (hd (hd V14290)))) (shen.pair (hd (shen.pair (tl (hd V14290)) (shen.hdtl V14290))) shen.skip) (fail))) 182 | 183 | (defun shen. (V14292) (let YaccParse (let Parse_shen. (shen. V14292) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14292) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= YaccParse (fail)) (if (cons? (hd V14292)) (let Parse_X (hd (hd V14292)) (let Parse_shen. (shen. (shen.pair (tl (hd V14292)) (shen.hdtl V14292))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail)))) (fail)) YaccParse)) YaccParse))) 184 | 185 | (defun shen. (V14294) (let YaccParse (let Parse_shen. (shen. V14294) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14294) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) YaccParse))) 186 | 187 | (defun shen. (V14296) (if (cons? (hd V14296)) (let Parse_X (hd (hd V14296)) (if (let Parse_Case Parse_X (or (= Parse_Case 32) (or (= Parse_Case 13) (or (= Parse_Case 10) (= Parse_Case 9))))) (shen.pair (hd (shen.pair (tl (hd V14296)) (shen.hdtl V14296))) shen.skip) (fail))) (fail))) 188 | 189 | (defun shen.cons_form (V14298) (cond ((= () V14298) ()) ((and (cons? V14298) (and (cons? (tl V14298)) (and (cons? (tl (tl V14298))) (and (= () (tl (tl (tl V14298)))) (= (hd (tl V14298)) bar!))))) (cons cons (cons (hd V14298) (tl (tl V14298))))) ((cons? V14298) (cons cons (cons (hd V14298) (cons (shen.cons_form (tl V14298)) ())))) (true (shen.f_error shen.cons_form)))) 190 | 191 | (defun shen.package-macro (V14303 V14304) (cond ((and (cons? V14303) (and (= $ (hd V14303)) (and (cons? (tl V14303)) (= () (tl (tl V14303)))))) (append (explode (hd (tl V14303))) V14304)) ((and (cons? V14303) (and (= package (hd V14303)) (and (cons? (tl V14303)) (and (= null (hd (tl V14303))) (cons? (tl (tl V14303))))))) (append (tl (tl (tl V14303))) V14304)) ((and (cons? V14303) (and (= package (hd V14303)) (and (cons? (tl V14303)) (cons? (tl (tl V14303)))))) (let ListofExceptions (shen.eval-without-macros (hd (tl (tl V14303)))) (let External (shen.record-exceptions ListofExceptions (hd (tl V14303))) (let PackageNameDot (intern (cn (str (hd (tl V14303))) ".")) (let ExpPackageName (explode (hd (tl V14303))) (let Packaged (shen.packageh PackageNameDot ListofExceptions (tl (tl (tl V14303))) ExpPackageName) (let Internal (shen.record-internal (hd (tl V14303)) (shen.internal-symbols ExpPackageName Packaged)) (append Packaged V14304)))))))) (true (cons V14303 V14304)))) 192 | 193 | (defun shen.record-exceptions (V14307 V14308) (let CurrExceptions (trap-error (get V14308 shen.external-symbols (value *property-vector*)) (lambda E ())) (let AllExceptions (union V14307 CurrExceptions) (put V14308 shen.external-symbols AllExceptions (value *property-vector*))))) 194 | 195 | (defun shen.record-internal (V14311 V14312) (put V14311 shen.internal-symbols (union V14312 (trap-error (get V14311 shen.internal-symbols (value *property-vector*)) (lambda E ()))) (value *property-vector*))) 196 | 197 | (defun shen.internal-symbols (V14323 V14324) (cond ((and (symbol? V14324) (shen.prefix? V14323 (explode V14324))) (cons V14324 ())) ((cons? V14324) (union (shen.internal-symbols V14323 (hd V14324)) (shen.internal-symbols V14323 (tl V14324)))) (true ()))) 198 | 199 | (defun shen.packageh (V14341 V14342 V14343 V14344) (cond ((cons? V14343) (cons (shen.packageh V14341 V14342 (hd V14343) V14344) (shen.packageh V14341 V14342 (tl V14343) V14344))) ((or (shen.sysfunc? V14343) (or (variable? V14343) (or (element? V14343 V14342) (or (shen.doubleunderline? V14343) (shen.singleunderline? V14343))))) V14343) ((and (symbol? V14343) (let ExplodeX (explode V14343) (and (not (shen.prefix? (cons "s" (cons "h" (cons "e" (cons "n" (cons "." ()))))) ExplodeX)) (not (shen.prefix? V14344 ExplodeX))))) (concat V14341 V14343)) (true V14343))) 200 | 201 | 202 | 203 | -------------------------------------------------------------------------------- /KLambda/sequent.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun shen.datatype-error (V14350) (cond ((and (cons? V14350) (and (cons? (tl V14350)) (= () (tl (tl V14350))))) (simple-error (cn "datatype syntax error here: 27 | 28 | " (shen.app (shen.next-50 50 (hd V14350)) " 29 | " shen.a)))) (true (shen.f_error shen.datatype-error)))) 30 | 31 | (defun shen. (V14352) (let YaccParse (let Parse_shen. (shen. V14352) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V14352) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) YaccParse))) 32 | 33 | (defun shen. (V14354) (let YaccParse (let Parse_shen. (shen. V14354) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent shen.single (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14354) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent shen.double (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail))) YaccParse))) 34 | 35 | (defun shen. (V14356) (let YaccParse (let Parse_shen. (shen. V14356) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V14356) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) YaccParse))) 36 | 37 | (defun shen. (V14358) (let YaccParse (if (and (cons? (hd V14358)) (= if (hd (hd V14358)))) (let Parse_shen. (shen. (shen.pair (tl (hd V14358)) (shen.hdtl V14358))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons if (cons (shen.hdtl Parse_shen.) ()))) (fail))) (fail)) (if (= YaccParse (fail)) (if (and (cons? (hd V14358)) (= let (hd (hd V14358)))) (let Parse_shen. (shen. (shen.pair (tl (hd V14358)) (shen.hdtl V14358))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons let (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ())))) (fail))) (fail))) (fail)) YaccParse))) 38 | 39 | (defun shen. (V14360) (if (cons? (hd V14360)) (let Parse_X (hd (hd V14360)) (if (variable? Parse_X) (shen.pair (hd (shen.pair (tl (hd V14360)) (shen.hdtl V14360))) Parse_X) (fail))) (fail))) 40 | 41 | (defun shen. (V14362) (if (cons? (hd V14362)) (let Parse_X (hd (hd V14362)) (if (not (or (element? Parse_X (cons >> (cons ; ()))) (or (shen.singleunderline? Parse_X) (shen.doubleunderline? Parse_X)))) (shen.pair (hd (shen.pair (tl (hd V14362)) (shen.hdtl V14362))) (shen.remove-bar Parse_X)) (fail))) (fail))) 42 | 43 | (defun shen.remove-bar (V14364) (cond ((and (cons? V14364) (and (cons? (tl V14364)) (and (cons? (tl (tl V14364))) (and (= () (tl (tl (tl V14364)))) (= (hd (tl V14364)) bar!))))) (cons (hd V14364) (hd (tl (tl V14364))))) ((cons? V14364) (cons (shen.remove-bar (hd V14364)) (shen.remove-bar (tl V14364)))) (true V14364))) 44 | 45 | (defun shen. (V14366) (let YaccParse (let Parse_shen. (shen. V14366) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V14366) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) YaccParse))) 46 | 47 | (defun shen. (V14368) (if (cons? (hd V14368)) (let Parse_X (hd (hd V14368)) (if (= Parse_X ;) (shen.pair (hd (shen.pair (tl (hd V14368)) (shen.hdtl V14368))) shen.skip) (fail))) (fail))) 48 | 49 | (defun shen. (V14370) (let YaccParse (if (and (cons? (hd V14370)) (= ! (hd (hd V14370)))) (shen.pair (hd (shen.pair (tl (hd V14370)) (shen.hdtl V14370))) !) (fail)) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14370) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= >> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail)) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14370) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent () (shen.hdtl Parse_shen.))) (fail))) YaccParse)) YaccParse))) 50 | 51 | (defun shen. (V14372) (let YaccParse (let Parse_shen. (shen. V14372) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= >> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail)) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14372) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent () (shen.hdtl Parse_shen.))) (fail))) (fail))) YaccParse))) 52 | 53 | (defun shen.sequent (V14375 V14376) (@p V14375 V14376)) 54 | 55 | (defun shen. (V14378) (let YaccParse (let Parse_shen. (shen. V14378) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= YaccParse (fail)) (let YaccParse (let Parse_shen. (shen. V14378) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) ())) (fail))) (if (= YaccParse (fail)) (let Parse_ ( V14378) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) YaccParse)) YaccParse))) 56 | 57 | (defun shen. (V14380) (if (cons? (hd V14380)) (let Parse_X (hd (hd V14380)) (if (= Parse_X (intern ",")) (shen.pair (hd (shen.pair (tl (hd V14380)) (shen.hdtl V14380))) shen.skip) (fail))) (fail))) 58 | 59 | (defun shen. (V14382) (let YaccParse (let Parse_shen. (shen. V14382) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= : (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.curry (shen.hdtl Parse_shen.)) (cons : (cons (shen.demodulate (shen.hdtl Parse_shen.)) ())))) (fail))) (fail)) (fail))) (if (= YaccParse (fail)) (let Parse_shen. (shen. V14382) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) YaccParse))) 60 | 61 | (defun shen. (V14384) (let Parse_shen. (shen. V14384) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.curry-type (shen.hdtl Parse_shen.))) (fail)))) 62 | 63 | (defun shen. (V14386) (if (cons? (hd V14386)) (let Parse_X (hd (hd V14386)) (if (shen.doubleunderline? Parse_X) (shen.pair (hd (shen.pair (tl (hd V14386)) (shen.hdtl V14386))) Parse_X) (fail))) (fail))) 64 | 65 | (defun shen. (V14388) (if (cons? (hd V14388)) (let Parse_X (hd (hd V14388)) (if (shen.singleunderline? Parse_X) (shen.pair (hd (shen.pair (tl (hd V14388)) (shen.hdtl V14388))) Parse_X) (fail))) (fail))) 66 | 67 | (defun shen.singleunderline? (V14390) (and (symbol? V14390) (shen.sh? (str V14390)))) 68 | 69 | (defun shen.sh? (V14392) (cond ((= "_" V14392) true) (true (and (= (pos V14392 0) "_") (shen.sh? (tlstr V14392)))))) 70 | 71 | (defun shen.doubleunderline? (V14394) (and (symbol? V14394) (shen.dh? (str V14394)))) 72 | 73 | (defun shen.dh? (V14396) (cond ((= "=" V14396) true) (true (and (= (pos V14396 0) "=") (shen.dh? (tlstr V14396)))))) 74 | 75 | (defun shen.process-datatype (V14399 V14400) (shen.remember-datatype (shen.s-prolog (shen.rules->horn-clauses V14399 V14400)))) 76 | 77 | (defun shen.remember-datatype (V14406) (cond ((cons? V14406) (do (set shen.*datatypes* (adjoin (hd V14406) (value shen.*datatypes*))) (do (set shen.*alldatatypes* (adjoin (hd V14406) (value shen.*alldatatypes*))) (hd V14406)))) (true (shen.f_error shen.remember-datatype)))) 78 | 79 | (defun shen.rules->horn-clauses (V14411 V14412) (cond ((= () V14412) ()) ((and (cons? V14412) (and (tuple? (hd V14412)) (= shen.single (fst (hd V14412))))) (cons (shen.rule->horn-clause V14411 (snd (hd V14412))) (shen.rules->horn-clauses V14411 (tl V14412)))) ((and (cons? V14412) (and (tuple? (hd V14412)) (= shen.double (fst (hd V14412))))) (shen.rules->horn-clauses V14411 (append (shen.double->singles (snd (hd V14412))) (tl V14412)))) (true (shen.f_error shen.rules->horn-clauses)))) 80 | 81 | (defun shen.double->singles (V14414) (cons (shen.right-rule V14414) (cons (shen.left-rule V14414) ()))) 82 | 83 | (defun shen.right-rule (V14416) (@p shen.single V14416)) 84 | 85 | (defun shen.left-rule (V14418) (cond ((and (cons? V14418) (and (cons? (tl V14418)) (and (cons? (tl (tl V14418))) (and (tuple? (hd (tl (tl V14418)))) (and (= () (fst (hd (tl (tl V14418))))) (= () (tl (tl (tl V14418))))))))) (let Q (gensym Qv) (let NewConclusion (@p (cons (snd (hd (tl (tl V14418)))) ()) Q) (let NewPremises (cons (@p (map (lambda X (shen.right->left X)) (hd (tl V14418))) Q) ()) (@p shen.single (cons (hd V14418) (cons NewPremises (cons NewConclusion ())))))))) (true (shen.f_error shen.left-rule)))) 86 | 87 | (defun shen.right->left (V14424) (cond ((and (tuple? V14424) (= () (fst V14424))) (snd V14424)) (true (simple-error "syntax error with ========== 88 | ")))) 89 | 90 | (defun shen.rule->horn-clause (V14427 V14428) (cond ((and (cons? V14428) (and (cons? (tl V14428)) (and (cons? (tl (tl V14428))) (and (tuple? (hd (tl (tl V14428)))) (= () (tl (tl (tl V14428)))))))) (cons (shen.rule->horn-clause-head V14427 (snd (hd (tl (tl V14428))))) (cons :- (cons (shen.rule->horn-clause-body (hd V14428) (hd (tl V14428)) (fst (hd (tl (tl V14428))))) ())))) (true (shen.f_error shen.rule->horn-clause)))) 91 | 92 | (defun shen.rule->horn-clause-head (V14431 V14432) (cons V14431 (cons (shen.mode-ify V14432) (cons Context_1957 ())))) 93 | 94 | (defun shen.mode-ify (V14434) (cond ((and (cons? V14434) (and (cons? (tl V14434)) (and (= : (hd (tl V14434))) (and (cons? (tl (tl V14434))) (= () (tl (tl (tl V14434)))))))) (cons mode (cons (cons (hd V14434) (cons : (cons (cons mode (cons (hd (tl (tl V14434))) (cons + ()))) ()))) (cons - ())))) (true V14434))) 95 | 96 | (defun shen.rule->horn-clause-body (V14438 V14439 V14440) (let Variables (map (lambda X (shen.extract_vars X)) V14440) (let Predicates (map (lambda X (gensym shen.cl)) V14440) (let SearchLiterals (shen.construct-search-literals Predicates Variables Context_1957 Context1_1957) (let SearchClauses (shen.construct-search-clauses Predicates V14440 Variables) (let SideLiterals (shen.construct-side-literals V14438) (let PremissLiterals (map (lambda X (shen.construct-premiss-literal X (empty? V14440))) V14439) (append SearchLiterals (append SideLiterals PremissLiterals))))))))) 97 | 98 | (defun shen.construct-search-literals (V14449 V14450 V14451 V14452) (cond ((and (= () V14449) (= () V14450)) ()) (true (shen.csl-help V14449 V14450 V14451 V14452)))) 99 | 100 | (defun shen.csl-help (V14459 V14460 V14461 V14462) (cond ((and (= () V14459) (= () V14460)) (cons (cons bind (cons ContextOut_1957 (cons V14461 ()))) ())) ((and (cons? V14459) (cons? V14460)) (cons (cons (hd V14459) (cons V14461 (cons V14462 (hd V14460)))) (shen.csl-help (tl V14459) (tl V14460) V14462 (gensym Context)))) (true (shen.f_error shen.csl-help)))) 101 | 102 | (defun shen.construct-search-clauses (V14466 V14467 V14468) (cond ((and (= () V14466) (and (= () V14467) (= () V14468))) shen.skip) ((and (cons? V14466) (and (cons? V14467) (cons? V14468))) (do (shen.construct-search-clause (hd V14466) (hd V14467) (hd V14468)) (shen.construct-search-clauses (tl V14466) (tl V14467) (tl V14468)))) (true (shen.f_error shen.construct-search-clauses)))) 103 | 104 | (defun shen.construct-search-clause (V14472 V14473 V14474) (shen.s-prolog (cons (shen.construct-base-search-clause V14472 V14473 V14474) (cons (shen.construct-recursive-search-clause V14472 V14473 V14474) ())))) 105 | 106 | (defun shen.construct-base-search-clause (V14478 V14479 V14480) (cons (cons V14478 (cons (cons (shen.mode-ify V14479) In_1957) (cons In_1957 V14480))) (cons :- (cons () ())))) 107 | 108 | (defun shen.construct-recursive-search-clause (V14484 V14485 V14486) (cons (cons V14484 (cons (cons Assumption_1957 Assumptions_1957) (cons (cons Assumption_1957 Out_1957) V14486))) (cons :- (cons (cons (cons V14484 (cons Assumptions_1957 (cons Out_1957 V14486))) ()) ())))) 109 | 110 | (defun shen.construct-side-literals (V14492) (cond ((= () V14492) ()) ((and (cons? V14492) (and (cons? (hd V14492)) (and (= if (hd (hd V14492))) (and (cons? (tl (hd V14492))) (= () (tl (tl (hd V14492)))))))) (cons (cons when (tl (hd V14492))) (shen.construct-side-literals (tl V14492)))) ((and (cons? V14492) (and (cons? (hd V14492)) (and (= let (hd (hd V14492))) (and (cons? (tl (hd V14492))) (and (cons? (tl (tl (hd V14492)))) (= () (tl (tl (tl (hd V14492)))))))))) (cons (cons is (tl (hd V14492))) (shen.construct-side-literals (tl V14492)))) ((cons? V14492) (shen.construct-side-literals (tl V14492))) (true (shen.f_error shen.construct-side-literals)))) 111 | 112 | (defun shen.construct-premiss-literal (V14499 V14500) (cond ((tuple? V14499) (cons shen.t* (cons (shen.recursive_cons_form (snd V14499)) (cons (shen.construct-context V14500 (fst V14499)) ())))) ((= ! V14499) (cons cut (cons Throwcontrol ()))) (true (shen.f_error shen.construct-premiss-literal)))) 113 | 114 | (defun shen.construct-context (V14503 V14504) (cond ((and (= true V14503) (= () V14504)) Context_1957) ((and (= false V14503) (= () V14504)) ContextOut_1957) ((cons? V14504) (cons cons (cons (shen.recursive_cons_form (hd V14504)) (cons (shen.construct-context V14503 (tl V14504)) ())))) (true (shen.f_error shen.construct-context)))) 115 | 116 | (defun shen.recursive_cons_form (V14506) (cond ((cons? V14506) (cons cons (cons (shen.recursive_cons_form (hd V14506)) (cons (shen.recursive_cons_form (tl V14506)) ())))) (true V14506))) 117 | 118 | (defun preclude (V14508) (shen.preclude-h (map (lambda X (shen.intern-type X)) V14508))) 119 | 120 | (defun shen.preclude-h (V14510) (let FilterDatatypes (set shen.*datatypes* (difference (value shen.*datatypes*) V14510)) (value shen.*datatypes*))) 121 | 122 | (defun include (V14512) (shen.include-h (map (lambda X (shen.intern-type X)) V14512))) 123 | 124 | (defun shen.include-h (V14514) (let ValidTypes (intersection V14514 (value shen.*alldatatypes*)) (let NewDatatypes (set shen.*datatypes* (union ValidTypes (value shen.*datatypes*))) (value shen.*datatypes*)))) 125 | 126 | (defun preclude-all-but (V14516) (shen.preclude-h (difference (value shen.*alldatatypes*) (map (lambda X (shen.intern-type X)) V14516)))) 127 | 128 | (defun include-all-but (V14518) (shen.include-h (difference (value shen.*alldatatypes*) (map (lambda X (shen.intern-type X)) V14518)))) 129 | 130 | (defun shen.synonyms-help (V14524) (cond ((= () V14524) (shen.demodulation-function (value shen.*tc*) (mapcan (lambda X (shen.demod-rule X)) (value shen.*synonyms*)))) ((and (cons? V14524) (cons? (tl V14524))) (let Vs (difference (shen.extract_vars (hd (tl V14524))) (shen.extract_vars (hd V14524))) (if (empty? Vs) (do (shen.pushnew (cons (hd V14524) (cons (hd (tl V14524)) ())) shen.*synonyms*) (shen.synonyms-help (tl (tl V14524)))) (shen.free_variable_warnings (hd (tl V14524)) Vs)))) (true (simple-error "odd number of synonyms 131 | ")))) 132 | 133 | (defun shen.pushnew (V14527 V14528) (if (element? V14527 (value V14528)) (value V14528) (set V14528 (cons V14527 (value V14528))))) 134 | 135 | (defun shen.demod-rule (V14530) (cond ((and (cons? V14530) (and (cons? (tl V14530)) (= () (tl (tl V14530))))) (cons (shen.rcons_form (hd V14530)) (cons -> (cons (shen.rcons_form (hd (tl V14530))) ())))) (true (shen.f_error shen.demod-rule)))) 136 | 137 | (defun shen.demodulation-function (V14533 V14534) (do (tc -) (do (eval (cons define (cons shen.demod (append V14534 (shen.default-rule))))) (do (if V14533 (tc +) shen.skip) synonyms)))) 138 | 139 | (defun shen.default-rule () (cons X (cons -> (cons X ())))) 140 | 141 | 142 | 143 | -------------------------------------------------------------------------------- /KLambda/sys.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun thaw (V14536) (V14536)) 27 | 28 | (defun eval (V14538) (let Macroexpand (shen.walk (lambda Y (macroexpand Y)) V14538) (if (shen.packaged? Macroexpand) (map (lambda Z (shen.eval-without-macros Z)) (shen.package-contents Macroexpand)) (shen.eval-without-macros Macroexpand)))) 29 | 30 | (defun shen.eval-without-macros (V14540) (eval-kl (shen.elim-def (shen.proc-input+ V14540)))) 31 | 32 | (defun shen.proc-input+ (V14542) (cond ((and (cons? V14542) (and (= input+ (hd V14542)) (and (cons? (tl V14542)) (and (cons? (tl (tl V14542))) (= () (tl (tl (tl V14542)))))))) (cons input+ (cons (shen.rcons_form (hd (tl V14542))) (tl (tl V14542))))) ((and (cons? V14542) (and (= shen.read+ (hd V14542)) (and (cons? (tl V14542)) (and (cons? (tl (tl V14542))) (= () (tl (tl (tl V14542)))))))) (cons shen.read+ (cons (shen.rcons_form (hd (tl V14542))) (tl (tl V14542))))) ((cons? V14542) (map (lambda Z (shen.proc-input+ Z)) V14542)) (true V14542))) 33 | 34 | (defun shen.elim-def (V14544) (cond ((and (cons? V14544) (and (= define (hd V14544)) (cons? (tl V14544)))) (shen.shen->kl (hd (tl V14544)) (tl (tl V14544)))) ((and (cons? V14544) (and (= defmacro (hd V14544)) (cons? (tl V14544)))) (let Default (cons X (cons -> (cons X ()))) (let Def (shen.elim-def (cons define (cons (hd (tl V14544)) (append (tl (tl V14544)) Default)))) (let MacroAdd (shen.add-macro (hd (tl V14544))) Def)))) ((and (cons? V14544) (and (= defcc (hd V14544)) (cons? (tl V14544)))) (shen.elim-def (shen.yacc V14544))) ((cons? V14544) (map (lambda Z (shen.elim-def Z)) V14544)) (true V14544))) 35 | 36 | (defun shen.add-macro (V14546) (let MacroReg (value shen.*macroreg*) (let NewMacroReg (set shen.*macroreg* (adjoin V14546 (value shen.*macroreg*))) (if (= MacroReg NewMacroReg) shen.skip (set *macros* (cons (function V14546) (value *macros*))))))) 37 | 38 | (defun shen.packaged? (V14554) (cond ((and (cons? V14554) (and (= package (hd V14554)) (and (cons? (tl V14554)) (cons? (tl (tl V14554)))))) true) (true false))) 39 | 40 | (defun external (V14556) (trap-error (get V14556 shen.external-symbols (value *property-vector*)) (lambda E (simple-error (cn "package " (shen.app V14556 " has not been used. 41 | " shen.a)))))) 42 | 43 | (defun internal (V14558) (trap-error (get V14558 shen.internal-symbols (value *property-vector*)) (lambda E (simple-error (cn "package " (shen.app V14558 " has not been used. 44 | " shen.a)))))) 45 | 46 | (defun shen.package-contents (V14562) (cond ((and (cons? V14562) (and (= package (hd V14562)) (and (cons? (tl V14562)) (and (= null (hd (tl V14562))) (cons? (tl (tl V14562))))))) (tl (tl (tl V14562)))) ((and (cons? V14562) (and (= package (hd V14562)) (and (cons? (tl V14562)) (cons? (tl (tl V14562)))))) (shen.packageh (hd (tl V14562)) (hd (tl (tl V14562))) (tl (tl (tl V14562))))) (true (shen.f_error shen.package-contents)))) 47 | 48 | (defun shen.walk (V14565 V14566) (cond ((cons? V14566) (V14565 (map (lambda Z (shen.walk V14565 Z)) V14566))) (true (V14565 V14566)))) 49 | 50 | (defun compile (V14570 V14571 V14572) (let O (V14570 (cons V14571 (cons () ()))) (if (or (= (fail) O) (not (empty? (hd O)))) (V14572 O) (shen.hdtl O)))) 51 | 52 | (defun fail-if (V14575 V14576) (if (V14575 V14576) (fail) V14576)) 53 | 54 | (defun @s (V14579 V14580) (cn V14579 V14580)) 55 | 56 | (defun tc? () (value shen.*tc*)) 57 | 58 | (defun ps (V14582) (trap-error (get V14582 shen.source (value *property-vector*)) (lambda E (simple-error (shen.app V14582 " not found. 59 | " shen.a))))) 60 | 61 | (defun stinput () (value *stinput*)) 62 | 63 | (defun shen.+vector? (V14584) (and (absvector? V14584) (> (<-address V14584 0) 0))) 64 | 65 | (defun vector (V14586) (let Vector (absvector (+ V14586 1)) (let ZeroStamp (address-> Vector 0 V14586) (let Standard (if (= V14586 0) ZeroStamp (shen.fillvector ZeroStamp 1 V14586 (fail))) Standard)))) 66 | 67 | (defun shen.fillvector (V14592 V14593 V14594 V14595) (cond ((= V14594 V14593) (address-> V14592 V14594 V14595)) (true (shen.fillvector (address-> V14592 V14593 V14595) (+ 1 V14593) V14594 V14595)))) 68 | 69 | (defun vector? (V14597) (and (absvector? V14597) (trap-error (>= (<-address V14597 0) 0) (lambda E false)))) 70 | 71 | (defun vector-> (V14601 V14602 V14603) (if (= V14602 0) (simple-error "cannot access 0th element of a vector 72 | ") (address-> V14601 V14602 V14603))) 73 | 74 | (defun <-vector (V14606 V14607) (if (= V14607 0) (simple-error "cannot access 0th element of a vector 75 | ") (let VectorElement (<-address V14606 V14607) (if (= VectorElement (fail)) (simple-error "vector element not found 76 | ") VectorElement)))) 77 | 78 | (defun shen.posint? (V14609) (and (integer? V14609) (>= V14609 0))) 79 | 80 | (defun limit (V14611) (<-address V14611 0)) 81 | 82 | (defun symbol? (V14613) (cond ((or (boolean? V14613) (or (number? V14613) (string? V14613))) false) (true (trap-error (let String (str V14613) (shen.analyse-symbol? String)) (lambda E false))))) 83 | 84 | (defun shen.analyse-symbol? (V14615) (cond ((shen.+string? V14615) (and (shen.alpha? (pos V14615 0)) (shen.alphanums? (tlstr V14615)))) (true (shen.f_error shen.analyse-symbol?)))) 85 | 86 | (defun shen.alpha? (V14617) (element? V14617 (cons "A" (cons "B" (cons "C" (cons "D" (cons "E" (cons "F" (cons "G" (cons "H" (cons "I" (cons "J" (cons "K" (cons "L" (cons "M" (cons "N" (cons "O" (cons "P" (cons "Q" (cons "R" (cons "S" (cons "T" (cons "U" (cons "V" (cons "W" (cons "X" (cons "Y" (cons "Z" (cons "a" (cons "b" (cons "c" (cons "d" (cons "e" (cons "f" (cons "g" (cons "h" (cons "i" (cons "j" (cons "k" (cons "l" (cons "m" (cons "n" (cons "o" (cons "p" (cons "q" (cons "r" (cons "s" (cons "t" (cons "u" (cons "v" (cons "w" (cons "x" (cons "y" (cons "z" (cons "=" (cons "*" (cons "/" (cons "+" (cons "-" (cons "_" (cons "?" (cons "$" (cons "!" (cons "@" (cons "~" (cons ">" (cons "<" (cons "&" (cons "%" (cons "{" (cons "}" (cons ":" (cons ";" (cons "`" (cons "#" (cons "'" (cons "." ()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 87 | 88 | (defun shen.alphanums? (V14619) (cond ((= "" V14619) true) ((shen.+string? V14619) (and (shen.alphanum? (pos V14619 0)) (shen.alphanums? (tlstr V14619)))) (true (shen.f_error shen.alphanums?)))) 89 | 90 | (defun shen.alphanum? (V14621) (or (shen.alpha? V14621) (shen.digit? V14621))) 91 | 92 | (defun shen.digit? (V14623) (element? V14623 (cons "1" (cons "2" (cons "3" (cons "4" (cons "5" (cons "6" (cons "7" (cons "8" (cons "9" (cons "0" ())))))))))))) 93 | 94 | (defun variable? (V14625) (cond ((or (boolean? V14625) (or (number? V14625) (string? V14625))) false) (true (trap-error (let String (str V14625) (shen.analyse-variable? String)) (lambda E false))))) 95 | 96 | (defun shen.analyse-variable? (V14627) (cond ((shen.+string? V14627) (and (shen.uppercase? (pos V14627 0)) (shen.alphanums? (tlstr V14627)))) (true (shen.f_error shen.analyse-variable?)))) 97 | 98 | (defun shen.uppercase? (V14629) (element? V14629 (cons "A" (cons "B" (cons "C" (cons "D" (cons "E" (cons "F" (cons "G" (cons "H" (cons "I" (cons "J" (cons "K" (cons "L" (cons "M" (cons "N" (cons "O" (cons "P" (cons "Q" (cons "R" (cons "S" (cons "T" (cons "U" (cons "V" (cons "W" (cons "X" (cons "Y" (cons "Z" ())))))))))))))))))))))))))))) 99 | 100 | (defun gensym (V14631) (concat V14631 (set shen.*gensym* (+ 1 (value shen.*gensym*))))) 101 | 102 | (defun concat (V14634 V14635) (intern (cn (str V14634) (str V14635)))) 103 | 104 | (defun @p (V14638 V14639) (let Vector (absvector 3) (let Tag (address-> Vector 0 shen.tuple) (let Fst (address-> Vector 1 V14638) (let Snd (address-> Vector 2 V14639) Vector))))) 105 | 106 | (defun fst (V14641) (<-address V14641 1)) 107 | 108 | (defun snd (V14643) (<-address V14643 2)) 109 | 110 | (defun tuple? (V14645) (trap-error (and (absvector? V14645) (= shen.tuple (<-address V14645 0))) (lambda E false))) 111 | 112 | (defun append (V14648 V14649) (cond ((= () V14648) V14649) ((cons? V14648) (cons (hd V14648) (append (tl V14648) V14649))) (true (shen.f_error append)))) 113 | 114 | (defun @v (V14652 V14653) (let Limit (limit V14653) (let NewVector (vector (+ Limit 1)) (let X+NewVector (vector-> NewVector 1 V14652) (if (= Limit 0) X+NewVector (shen.@v-help V14653 1 Limit X+NewVector)))))) 115 | 116 | (defun shen.@v-help (V14659 V14660 V14661 V14662) (cond ((= V14661 V14660) (shen.copyfromvector V14659 V14662 V14661 (+ V14661 1))) (true (shen.@v-help V14659 (+ V14660 1) V14661 (shen.copyfromvector V14659 V14662 V14660 (+ V14660 1)))))) 117 | 118 | (defun shen.copyfromvector (V14667 V14668 V14669 V14670) (trap-error (vector-> V14668 V14670 (<-vector V14667 V14669)) (lambda E V14668))) 119 | 120 | (defun hdv (V14672) (trap-error (<-vector V14672 1) (lambda E (simple-error (cn "hdv needs a non-empty vector as an argument; not " (shen.app V14672 " 121 | " shen.s)))))) 122 | 123 | (defun tlv (V14674) (let Limit (limit V14674) (if (= Limit 0) (simple-error "cannot take the tail of the empty vector 124 | ") (if (= Limit 1) (vector 0) (let NewVector (vector (- Limit 1)) (shen.tlv-help V14674 2 Limit (vector (- Limit 1)))))))) 125 | 126 | (defun shen.tlv-help (V14680 V14681 V14682 V14683) (cond ((= V14682 V14681) (shen.copyfromvector V14680 V14683 V14682 (- V14682 1))) (true (shen.tlv-help V14680 (+ V14681 1) V14682 (shen.copyfromvector V14680 V14683 V14681 (- V14681 1)))))) 127 | 128 | (defun assoc (V14695 V14696) (cond ((= () V14696) ()) ((and (cons? V14696) (and (cons? (hd V14696)) (= (hd (hd V14696)) V14695))) (hd V14696)) ((cons? V14696) (assoc V14695 (tl V14696))) (true (shen.f_error assoc)))) 129 | 130 | (defun boolean? (V14702) (cond ((= true V14702) true) ((= false V14702) true) (true false))) 131 | 132 | (defun nl (V14704) (cond ((= 0 V14704) 0) (true (do (shen.prhush " 133 | " (stoutput)) (nl (- V14704 1)))))) 134 | 135 | (defun difference (V14709 V14710) (cond ((= () V14709) ()) ((cons? V14709) (if (element? (hd V14709) V14710) (difference (tl V14709) V14710) (cons (hd V14709) (difference (tl V14709) V14710)))) (true (shen.f_error difference)))) 136 | 137 | (defun do (V14713 V14714) V14714) 138 | 139 | (defun element? (V14726 V14727) (cond ((= () V14727) false) ((and (cons? V14727) (= (hd V14727) V14726)) true) ((cons? V14727) (element? V14726 (tl V14727))) (true (shen.f_error element?)))) 140 | 141 | (defun empty? (V14733) (cond ((= () V14733) true) (true false))) 142 | 143 | (defun fix (V14736 V14737) (shen.fix-help V14736 V14737 (V14736 V14737))) 144 | 145 | (defun shen.fix-help (V14748 V14749 V14750) (cond ((= V14750 V14749) V14750) (true (shen.fix-help V14748 V14750 (V14748 V14750))))) 146 | 147 | (defun put (V14755 V14756 V14757 V14758) (let N (hash V14755 (limit V14758)) (let Entry (trap-error (<-vector V14758 N) (lambda E ())) (let Change (vector-> V14758 N (shen.change-pointer-value V14755 V14756 V14757 Entry)) V14757)))) 148 | 149 | (defun unput (V14762 V14763 V14764) (let N (hash V14762 (limit V14764)) (let Entry (trap-error (<-vector V14764 N) (lambda E ())) (let Change (vector-> V14764 N (shen.remove-pointer V14762 V14763 Entry)) V14762)))) 150 | 151 | (defun shen.remove-pointer (V14772 V14773 V14774) (cond ((= () V14774) ()) ((and (cons? V14774) (and (cons? (hd V14774)) (and (cons? (hd (hd V14774))) (and (cons? (tl (hd (hd V14774)))) (and (= () (tl (tl (hd (hd V14774))))) (and (= (hd (tl (hd (hd V14774)))) V14773) (= (hd (hd (hd V14774))) V14772))))))) (tl V14774)) ((cons? V14774) (cons (hd V14774) (shen.remove-pointer V14772 V14773 (tl V14774)))) (true (shen.f_error shen.remove-pointer)))) 152 | 153 | (defun shen.change-pointer-value (V14783 V14784 V14785 V14786) (cond ((= () V14786) (cons (cons (cons V14783 (cons V14784 ())) V14785) ())) ((and (cons? V14786) (and (cons? (hd V14786)) (and (cons? (hd (hd V14786))) (and (cons? (tl (hd (hd V14786)))) (and (= () (tl (tl (hd (hd V14786))))) (and (= (hd (tl (hd (hd V14786)))) V14784) (= (hd (hd (hd V14786))) V14783))))))) (cons (cons (hd (hd V14786)) V14785) (tl V14786))) ((cons? V14786) (cons (hd V14786) (shen.change-pointer-value V14783 V14784 V14785 (tl V14786)))) (true (shen.f_error shen.change-pointer-value)))) 154 | 155 | (defun get (V14790 V14791 V14792) (let N (hash V14790 (limit V14792)) (let Entry (trap-error (<-vector V14792 N) (lambda E (simple-error "pointer not found 156 | "))) (let Result (assoc (cons V14790 (cons V14791 ())) Entry) (if (empty? Result) (simple-error "value not found 157 | ") (tl Result)))))) 158 | 159 | (defun hash (V14795 V14796) (let Hash (shen.mod (sum (map (lambda X (string->n X)) (explode V14795))) V14796) (if (= 0 Hash) 1 Hash))) 160 | 161 | (defun shen.mod (V14799 V14800) (shen.modh V14799 (shen.multiples V14799 (cons V14800 ())))) 162 | 163 | (defun shen.multiples (V14803 V14804) (cond ((and (cons? V14804) (> (hd V14804) V14803)) (tl V14804)) ((cons? V14804) (shen.multiples V14803 (cons (* 2 (hd V14804)) V14804))) (true (shen.f_error shen.multiples)))) 164 | 165 | (defun shen.modh (V14809 V14810) (cond ((= 0 V14809) 0) ((= () V14810) V14809) ((and (cons? V14810) (> (hd V14810) V14809)) (if (empty? (tl V14810)) V14809 (shen.modh V14809 (tl V14810)))) ((cons? V14810) (shen.modh (- V14809 (hd V14810)) V14810)) (true (shen.f_error shen.modh)))) 166 | 167 | (defun sum (V14812) (cond ((= () V14812) 0) ((cons? V14812) (+ (hd V14812) (sum (tl V14812)))) (true (shen.f_error sum)))) 168 | 169 | (defun head (V14820) (cond ((cons? V14820) (hd V14820)) (true (simple-error "head expects a non-empty list")))) 170 | 171 | (defun tail (V14828) (cond ((cons? V14828) (tl V14828)) (true (simple-error "tail expects a non-empty list")))) 172 | 173 | (defun hdstr (V14830) (pos V14830 0)) 174 | 175 | (defun intersection (V14835 V14836) (cond ((= () V14835) ()) ((cons? V14835) (if (element? (hd V14835) V14836) (cons (hd V14835) (intersection (tl V14835) V14836)) (intersection (tl V14835) V14836))) (true (shen.f_error intersection)))) 176 | 177 | (defun reverse (V14838) (shen.reverse_help V14838 ())) 178 | 179 | (defun shen.reverse_help (V14841 V14842) (cond ((= () V14841) V14842) ((cons? V14841) (shen.reverse_help (tl V14841) (cons (hd V14841) V14842))) (true (shen.f_error shen.reverse_help)))) 180 | 181 | (defun union (V14845 V14846) (cond ((= () V14845) V14846) ((cons? V14845) (if (element? (hd V14845) V14846) (union (tl V14845) V14846) (cons (hd V14845) (union (tl V14845) V14846)))) (true (shen.f_error union)))) 182 | 183 | (defun y-or-n? (V14848) (let Message (shen.prhush (shen.proc-nl V14848) (stoutput)) (let Y-or-N (shen.prhush " (y/n) " (stoutput)) (let Input (shen.app (read (stinput)) "" shen.s) (if (= "y" Input) true (if (= "n" Input) false (do (shen.prhush "please answer y or n 184 | " (stoutput)) (y-or-n? V14848)))))))) 185 | 186 | (defun not (V14850) (if V14850 false true)) 187 | 188 | (defun subst (V14863 V14864 V14865) (cond ((= V14865 V14864) V14863) ((cons? V14865) (map (lambda W (subst V14863 V14864 W)) V14865)) (true V14865))) 189 | 190 | (defun explode (V14867) (shen.explode-h (shen.app V14867 "" shen.a))) 191 | 192 | (defun shen.explode-h (V14869) (cond ((= "" V14869) ()) ((shen.+string? V14869) (cons (pos V14869 0) (shen.explode-h (tlstr V14869)))) (true (shen.f_error shen.explode-h)))) 193 | 194 | (defun cd (V14871) (set *home-directory* (if (= V14871 "") "" (shen.app V14871 "/" shen.a)))) 195 | 196 | (defun map (V14874 V14875) (shen.map-h V14874 V14875 ())) 197 | 198 | (defun shen.map-h (V14881 V14882 V14883) (cond ((= () V14882) (reverse V14883)) ((cons? V14882) (shen.map-h V14881 (tl V14882) (cons (V14881 (hd V14882)) V14883))) (true (shen.f_error shen.map-h)))) 199 | 200 | (defun length (V14885) (shen.length-h V14885 0)) 201 | 202 | (defun shen.length-h (V14888 V14889) (cond ((= () V14888) V14889) (true (shen.length-h (tl V14888) (+ V14889 1))))) 203 | 204 | (defun occurrences (V14901 V14902) (cond ((= V14902 V14901) 1) ((cons? V14902) (+ (occurrences V14901 (hd V14902)) (occurrences V14901 (tl V14902)))) (true 0))) 205 | 206 | (defun nth (V14911 V14912) (cond ((and (= 1 V14911) (cons? V14912)) (hd V14912)) ((cons? V14912) (nth (- V14911 1) (tl V14912))) (true (shen.f_error nth)))) 207 | 208 | (defun integer? (V14914) (and (number? V14914) (let Abs (shen.abs V14914) (shen.integer-test? Abs (shen.magless Abs 1))))) 209 | 210 | (defun shen.abs (V14916) (if (> V14916 0) V14916 (- 0 V14916))) 211 | 212 | (defun shen.magless (V14919 V14920) (let Nx2 (* V14920 2) (if (> Nx2 V14919) V14920 (shen.magless V14919 Nx2)))) 213 | 214 | (defun shen.integer-test? (V14926 V14927) (cond ((= 0 V14926) true) ((> 1 V14926) false) (true (let Abs-N (- V14926 V14927) (if (> 0 Abs-N) (integer? V14926) (shen.integer-test? Abs-N V14927)))))) 215 | 216 | (defun mapcan (V14932 V14933) (cond ((= () V14933) ()) ((cons? V14933) (append (V14932 (hd V14933)) (mapcan V14932 (tl V14933)))) (true (shen.f_error mapcan)))) 217 | 218 | (defun == (V14945 V14946) (cond ((= V14946 V14945) true) (true false))) 219 | 220 | (defun abort () (simple-error "")) 221 | 222 | (defun bound? (V14948) (and (symbol? V14948) (let Val (trap-error (value V14948) (lambda E shen.this-symbol-is-unbound)) (if (= Val shen.this-symbol-is-unbound) false true)))) 223 | 224 | (defun shen.string->bytes (V14950) (cond ((= "" V14950) ()) (true (cons (string->n (pos V14950 0)) (shen.string->bytes (tlstr V14950)))))) 225 | 226 | (defun maxinferences (V14952) (set shen.*maxinferences* V14952)) 227 | 228 | (defun inferences () (value shen.*infs*)) 229 | 230 | (defun protect (V14954) V14954) 231 | 232 | (defun stoutput () (value *stoutput*)) 233 | 234 | (defun string->symbol (V14956) (let Symbol (intern V14956) (if (symbol? Symbol) Symbol (simple-error (cn "cannot intern " (shen.app V14956 " to a symbol" shen.s)))))) 235 | 236 | (defun optimise (V14962) (cond ((= + V14962) (set shen.*optimise* true)) ((= - V14962) (set shen.*optimise* false)) (true (simple-error "optimise expects a + or a -. 237 | ")))) 238 | 239 | (defun os () (value *os*)) 240 | 241 | (defun language () (value *language*)) 242 | 243 | (defun version () (value *version*)) 244 | 245 | (defun port () (value *port*)) 246 | 247 | (defun porters () (value *porters*)) 248 | 249 | (defun implementation () (value *implementation*)) 250 | 251 | (defun release () (value *release*)) 252 | 253 | (defun package? (V14964) (trap-error (do (external V14964) true) (lambda E false))) 254 | 255 | (defun function (V14966) (shen.lookup-func V14966 (value shen.*symbol-table*))) 256 | 257 | (defun shen.lookup-func (V14976 V14977) (cond ((= () V14977) (simple-error (shen.app V14976 " has no lambda expansion 258 | " shen.a))) ((and (cons? V14977) (and (cons? (hd V14977)) (= (hd (hd V14977)) V14976))) (tl (hd V14977))) ((cons? V14977) (shen.lookup-func V14976 (tl V14977))) (true (shen.f_error shen.lookup-func)))) 259 | 260 | 261 | 262 | -------------------------------------------------------------------------------- /KLambda/toplevel.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun shen.shen () (do (shen.credits) (shen.loop))) 27 | 28 | (defun shen.loop () (do (shen.initialise_environment) (do (shen.prompt) (do (trap-error (shen.read-evaluate-print) (lambda E (pr (error-to-string E) (stoutput)))) (shen.loop))))) 29 | 30 | (defun shen.credits () (do (shen.prhush " 31 | Shen, copyright (C) 2010-2015 Mark Tarver 32 | " (stoutput)) (do (shen.prhush (cn "www.shenlanguage.org, " (shen.app (value *version*) " 33 | " shen.a)) (stoutput)) (do (shen.prhush (cn "running under " (shen.app (value *language*) (cn ", implementation: " (shen.app (value *implementation*) "" shen.a)) shen.a)) (stoutput)) (shen.prhush (cn " 34 | port " (shen.app (value *port*) (cn " ported by " (shen.app (value *porters*) " 35 | " shen.a)) shen.a)) (stoutput)))))) 36 | 37 | (defun shen.initialise_environment () (shen.multiple-set (cons shen.*call* (cons 0 (cons shen.*infs* (cons 0 (cons shen.*process-counter* (cons 0 (cons shen.*catch* (cons 0 ())))))))))) 38 | 39 | (defun shen.multiple-set (V15590) (cond ((= () V15590) ()) ((and (cons? V15590) (cons? (tl V15590))) (do (set (hd V15590) (hd (tl V15590))) (shen.multiple-set (tl (tl V15590))))) (true (shen.f_error shen.multiple-set)))) 40 | 41 | (defun destroy (V15592) (declare V15592 symbol)) 42 | 43 | (set shen.*history* ()) 44 | 45 | (defun shen.read-evaluate-print () (let Lineread (shen.toplineread) (let History (value shen.*history*) (let NewLineread (shen.retrieve-from-history-if-needed Lineread History) (let NewHistory (shen.update_history NewLineread History) (let Parsed (fst NewLineread) (shen.toplevel Parsed))))))) 46 | 47 | (defun shen.retrieve-from-history-if-needed (V15604 V15605) (cond ((and (tuple? V15604) (and (cons? (snd V15604)) (element? (hd (snd V15604)) (cons (shen.space) (cons (shen.newline) ()))))) (shen.retrieve-from-history-if-needed (@p (fst V15604) (tl (snd V15604))) V15605)) ((and (tuple? V15604) (and (cons? (snd V15604)) (and (cons? (tl (snd V15604))) (and (= () (tl (tl (snd V15604)))) (and (cons? V15605) (and (= (hd (snd V15604)) (shen.exclamation)) (= (hd (tl (snd V15604))) (shen.exclamation)))))))) (let PastPrint (shen.prbytes (snd (hd V15605))) (hd V15605))) ((and (tuple? V15604) (and (cons? (snd V15604)) (= (hd (snd V15604)) (shen.exclamation)))) (let Key? (shen.make-key (tl (snd V15604)) V15605) (let Find (head (shen.find-past-inputs Key? V15605)) (let PastPrint (shen.prbytes (snd Find)) Find)))) ((and (tuple? V15604) (and (cons? (snd V15604)) (and (= () (tl (snd V15604))) (= (hd (snd V15604)) (shen.percent))))) (do (shen.print-past-inputs (lambda X true) (reverse V15605) 0) (abort))) ((and (tuple? V15604) (and (cons? (snd V15604)) (= (hd (snd V15604)) (shen.percent)))) (let Key? (shen.make-key (tl (snd V15604)) V15605) (let Pastprint (shen.print-past-inputs Key? (reverse V15605) 0) (abort)))) (true V15604))) 48 | 49 | (defun shen.percent () 37) 50 | 51 | (defun shen.exclamation () 33) 52 | 53 | (defun shen.prbytes (V15607) (do (map (lambda Byte (pr (n->string Byte) (stoutput))) V15607) (nl 1))) 54 | 55 | (defun shen.update_history (V15610 V15611) (set shen.*history* (cons V15610 V15611))) 56 | 57 | (defun shen.toplineread () (shen.toplineread_loop (read-byte (stinput)) ())) 58 | 59 | (defun shen.toplineread_loop (V15615 V15616) (cond ((= V15615 (shen.hat)) (simple-error "line read aborted")) ((element? V15615 (cons (shen.newline) (cons (shen.carriage-return) ()))) (let Line (compile (lambda X (shen. X)) V15616 (lambda E shen.nextline)) (let It (shen.record-it V15616) (if (or (= Line shen.nextline) (empty? Line)) (shen.toplineread_loop (read-byte (stinput)) (append V15616 (cons V15615 ()))) (@p Line V15616))))) (true (shen.toplineread_loop (read-byte (stinput)) (append V15616 (cons V15615 ())))))) 60 | 61 | (defun shen.hat () 94) 62 | 63 | (defun shen.newline () 10) 64 | 65 | (defun shen.carriage-return () 13) 66 | 67 | (defun tc (V15622) (cond ((= + V15622) (set shen.*tc* true)) ((= - V15622) (set shen.*tc* false)) (true (simple-error "tc expects a + or -")))) 68 | 69 | (defun shen.prompt () (if (value shen.*tc*) (shen.prhush (cn " 70 | 71 | (" (shen.app (length (value shen.*history*)) "+) " shen.a)) (stoutput)) (shen.prhush (cn " 72 | 73 | (" (shen.app (length (value shen.*history*)) "-) " shen.a)) (stoutput)))) 74 | 75 | (defun shen.toplevel (V15624) (shen.toplevel_evaluate V15624 (value shen.*tc*))) 76 | 77 | (defun shen.find-past-inputs (V15627 V15628) (let F (shen.find V15627 V15628) (if (empty? F) (simple-error "input not found 78 | ") F))) 79 | 80 | (defun shen.make-key (V15631 V15632) (let Atom (hd (compile (lambda X (shen. X)) V15631 (lambda E (if (cons? E) (simple-error (cn "parse error here: " (shen.app E " 81 | " shen.s))) (simple-error "parse error 82 | "))))) (if (integer? Atom) (lambda X (= X (nth (+ Atom 1) (reverse V15632)))) (lambda X (shen.prefix? V15631 (shen.trim-gubbins (snd X))))))) 83 | 84 | (defun shen.trim-gubbins (V15634) (cond ((and (cons? V15634) (= (hd V15634) (shen.space))) (shen.trim-gubbins (tl V15634))) ((and (cons? V15634) (= (hd V15634) (shen.newline))) (shen.trim-gubbins (tl V15634))) ((and (cons? V15634) (= (hd V15634) (shen.carriage-return))) (shen.trim-gubbins (tl V15634))) ((and (cons? V15634) (= (hd V15634) (shen.tab))) (shen.trim-gubbins (tl V15634))) ((and (cons? V15634) (= (hd V15634) (shen.left-round))) (shen.trim-gubbins (tl V15634))) (true V15634))) 85 | 86 | (defun shen.space () 32) 87 | 88 | (defun shen.tab () 9) 89 | 90 | (defun shen.left-round () 40) 91 | 92 | (defun shen.find (V15643 V15644) (cond ((= () V15644) ()) ((and (cons? V15644) (V15643 (hd V15644))) (cons (hd V15644) (shen.find V15643 (tl V15644)))) ((cons? V15644) (shen.find V15643 (tl V15644))) (true (shen.f_error shen.find)))) 93 | 94 | (defun shen.prefix? (V15658 V15659) (cond ((= () V15658) true) ((and (cons? V15658) (and (cons? V15659) (= (hd V15659) (hd V15658)))) (shen.prefix? (tl V15658) (tl V15659))) (true false))) 95 | 96 | (defun shen.print-past-inputs (V15671 V15672 V15673) (cond ((= () V15672) _) ((and (cons? V15672) (not (V15671 (hd V15672)))) (shen.print-past-inputs V15671 (tl V15672) (+ V15673 1))) ((and (cons? V15672) (tuple? (hd V15672))) (do (shen.prhush (shen.app V15673 ". " shen.a) (stoutput)) (do (shen.prbytes (snd (hd V15672))) (shen.print-past-inputs V15671 (tl V15672) (+ V15673 1))))) (true (shen.f_error shen.print-past-inputs)))) 97 | 98 | (defun shen.toplevel_evaluate (V15676 V15677) (cond ((and (cons? V15676) (and (cons? (tl V15676)) (and (= : (hd (tl V15676))) (and (cons? (tl (tl V15676))) (and (= () (tl (tl (tl V15676)))) (= true V15677)))))) (shen.typecheck-and-evaluate (hd V15676) (hd (tl (tl V15676))))) ((and (cons? V15676) (cons? (tl V15676))) (do (shen.toplevel_evaluate (cons (hd V15676) ()) V15677) (do (nl 1) (shen.toplevel_evaluate (tl V15676) V15677)))) ((and (cons? V15676) (and (= () (tl V15676)) (= true V15677))) (shen.typecheck-and-evaluate (hd V15676) (gensym A))) ((and (cons? V15676) (and (= () (tl V15676)) (= false V15677))) (let Eval (shen.eval-without-macros (hd V15676)) (print Eval))) (true (shen.f_error shen.toplevel_evaluate)))) 99 | 100 | (defun shen.typecheck-and-evaluate (V15680 V15681) (let Typecheck (shen.typecheck V15680 V15681) (if (= Typecheck false) (simple-error "type error 101 | ") (let Eval (shen.eval-without-macros V15680) (let Type (shen.pretty-type Typecheck) (shen.prhush (shen.app Eval (cn " : " (shen.app Type "" shen.r)) shen.s) (stoutput))))))) 102 | 103 | (defun shen.pretty-type (V15683) (shen.mult_subst (value shen.*alphabet*) (shen.extract-pvars V15683) V15683)) 104 | 105 | (defun shen.extract-pvars (V15689) (cond ((shen.pvar? V15689) (cons V15689 ())) ((cons? V15689) (union (shen.extract-pvars (hd V15689)) (shen.extract-pvars (tl V15689)))) (true ()))) 106 | 107 | (defun shen.mult_subst (V15697 V15698 V15699) (cond ((= () V15697) V15699) ((= () V15698) V15699) ((and (cons? V15697) (cons? V15698)) (shen.mult_subst (tl V15697) (tl V15698) (subst (hd V15697) (hd V15698) V15699))) (true (shen.f_error shen.mult_subst)))) 108 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /KLambda/track.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun shen.f_error (V15701) (do (shen.prhush (cn "partial function " (shen.app V15701 "; 27 | " shen.a)) (stoutput)) (do (if (and (not (shen.tracked? V15701)) (y-or-n? (cn "track " (shen.app V15701 "? " shen.a)))) (shen.track-function (ps V15701)) shen.ok) (simple-error "aborted")))) 28 | 29 | (defun shen.tracked? (V15703) (element? V15703 (value shen.*tracking*))) 30 | 31 | (defun track (V15705) (let Source (ps V15705) (shen.track-function Source))) 32 | 33 | (defun shen.track-function (V15707) (cond ((and (cons? V15707) (and (= defun (hd V15707)) (and (cons? (tl V15707)) (and (cons? (tl (tl V15707))) (and (cons? (tl (tl (tl V15707)))) (= () (tl (tl (tl (tl V15707)))))))))) (let KL (cons defun (cons (hd (tl V15707)) (cons (hd (tl (tl V15707))) (cons (shen.insert-tracking-code (hd (tl V15707)) (hd (tl (tl V15707))) (hd (tl (tl (tl V15707))))) ())))) (let Ob (eval-kl KL) (let Tr (set shen.*tracking* (cons Ob (value shen.*tracking*))) Ob)))) (true (shen.f_error shen.track-function)))) 34 | 35 | (defun shen.insert-tracking-code (V15711 V15712 V15713) (cons do (cons (cons set (cons shen.*call* (cons (cons + (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.input-track (cons (cons value (cons shen.*call* ())) (cons V15711 (cons (shen.cons_form V15712) ())))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons (cons let (cons Result (cons V15713 (cons (cons do (cons (cons shen.output-track (cons (cons value (cons shen.*call* ())) (cons V15711 (cons Result ())))) (cons (cons do (cons (cons set (cons shen.*call* (cons (cons - (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons Result ()))) ()))) ()))) ())))) ()))) ()))) ())))) 36 | 37 | (set shen.*step* false) 38 | 39 | (defun step (V15719) (cond ((= + V15719) (set shen.*step* true)) ((= - V15719) (set shen.*step* false)) (true (simple-error "step expects a + or a -. 40 | ")))) 41 | 42 | (defun spy (V15725) (cond ((= + V15725) (set shen.*spy* true)) ((= - V15725) (set shen.*spy* false)) (true (simple-error "spy expects a + or a -. 43 | ")))) 44 | 45 | (defun shen.terpri-or-read-char () (if (value shen.*step*) (shen.check-byte (read-byte (value *stinput*))) (nl 1))) 46 | 47 | (defun shen.check-byte (V15731) (cond ((= V15731 (shen.hat)) (simple-error "aborted")) (true true))) 48 | 49 | (defun shen.input-track (V15735 V15736 V15737) (do (shen.prhush (cn " 50 | " (shen.app (shen.spaces V15735) (cn "<" (shen.app V15735 (cn "> Inputs to " (shen.app V15736 (cn " 51 | " (shen.app (shen.spaces V15735) "" shen.a)) shen.a)) shen.a)) shen.a)) (stoutput)) (shen.recursively-print V15737))) 52 | 53 | (defun shen.recursively-print (V15739) (cond ((= () V15739) (shen.prhush " ==>" (stoutput))) ((cons? V15739) (do (print (hd V15739)) (do (shen.prhush ", " (stoutput)) (shen.recursively-print (tl V15739))))) (true (shen.f_error shen.recursively-print)))) 54 | 55 | (defun shen.spaces (V15741) (cond ((= 0 V15741) "") (true (cn " " (shen.spaces (- V15741 1)))))) 56 | 57 | (defun shen.output-track (V15745 V15746 V15747) (shen.prhush (cn " 58 | " (shen.app (shen.spaces V15745) (cn "<" (shen.app V15745 (cn "> Output from " (shen.app V15746 (cn " 59 | " (shen.app (shen.spaces V15745) (cn "==> " (shen.app V15747 "" shen.s)) shen.a)) shen.a)) shen.a)) shen.a)) (stoutput))) 60 | 61 | (defun untrack (V15749) (eval (ps V15749))) 62 | 63 | (defun profile (V15751) (shen.profile-help (ps V15751))) 64 | 65 | (defun shen.profile-help (V15757) (cond ((and (cons? V15757) (and (= defun (hd V15757)) (and (cons? (tl V15757)) (and (cons? (tl (tl V15757))) (and (cons? (tl (tl (tl V15757)))) (= () (tl (tl (tl (tl V15757)))))))))) (let G (gensym shen.f) (let Profile (cons defun (cons (hd (tl V15757)) (cons (hd (tl (tl V15757))) (cons (shen.profile-func (hd (tl V15757)) (hd (tl (tl V15757))) (cons G (hd (tl (tl V15757))))) ())))) (let Def (cons defun (cons G (cons (hd (tl (tl V15757))) (cons (subst G (hd (tl V15757)) (hd (tl (tl (tl V15757))))) ())))) (let CompileProfile (shen.eval-without-macros Profile) (let CompileG (shen.eval-without-macros Def) (hd (tl V15757)))))))) (true (simple-error "Cannot profile. 66 | ")))) 67 | 68 | (defun unprofile (V15759) (untrack V15759)) 69 | 70 | (defun shen.profile-func (V15763 V15764 V15765) (cons let (cons Start (cons (cons get-time (cons run ())) (cons (cons let (cons Result (cons V15765 (cons (cons let (cons Finish (cons (cons - (cons (cons get-time (cons run ())) (cons Start ()))) (cons (cons let (cons Record (cons (cons shen.put-profile (cons V15763 (cons (cons + (cons (cons shen.get-profile (cons V15763 ())) (cons Finish ()))) ()))) (cons Result ())))) ())))) ())))) ()))))) 71 | 72 | (defun profile-results (V15767) (let Results (shen.get-profile V15767) (let Initialise (shen.put-profile V15767 0) (@p V15767 Results)))) 73 | 74 | (defun shen.get-profile (V15769) (trap-error (get V15769 profile (value *property-vector*)) (lambda E 0))) 75 | 76 | (defun shen.put-profile (V15772 V15773) (put V15772 profile V15773 (value *property-vector*))) 77 | 78 | 79 | 80 | -------------------------------------------------------------------------------- /KLambda/types.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun declare (V15776 V15777) (let Record (set shen.*signedfuncs* (cons (cons V15776 V15777) (value shen.*signedfuncs*))) (let Variancy (trap-error (shen.variancy-test V15776 V15777) (lambda E shen.skip)) (let Type (shen.rcons_form (shen.demodulate V15777)) (let F* (concat shen.type-signature-of- V15776) (let Parameters (shen.parameters 1) (let Clause (cons (cons F* (cons X ())) (cons :- (cons (cons (cons unify! (cons X (cons Type ()))) ()) ()))) (let AUM_instruction (shen.aum Clause Parameters) (let Code (shen.aum_to_shen AUM_instruction) (let ShenDef (cons define (cons F* (append Parameters (append (cons ProcessN (cons Continuation ())) (cons -> (cons Code ())))))) (let Eval (shen.eval-without-macros ShenDef) V15776))))))))))) 27 | 28 | (defun shen.demodulate (V15779) (trap-error (let Demod (shen.walk (lambda Y (shen.demod Y)) V15779) (if (= Demod V15779) V15779 (shen.demodulate Demod))) (lambda E V15779))) 29 | 30 | (defun shen.variancy-test (V15782 V15783) (let TypeF (shen.typecheck V15782 B) (let Check (if (= symbol TypeF) shen.skip (if (shen.variant? TypeF V15783) shen.skip (shen.prhush (cn "warning: changing the type of " (shen.app V15782 " may create errors 31 | " shen.a)) (stoutput)))) shen.skip))) 32 | 33 | (defun shen.variant? (V15796 V15797) (cond ((= V15797 V15796) true) ((and (cons? V15796) (and (cons? V15797) (= (hd V15797) (hd V15796)))) (shen.variant? (tl V15796) (tl V15797))) ((and (cons? V15796) (and (cons? V15797) (and (shen.pvar? (hd V15796)) (variable? (hd V15797))))) (shen.variant? (subst shen.a (hd V15796) (tl V15796)) (subst shen.a (hd V15797) (tl V15797)))) ((and (cons? V15796) (and (cons? (hd V15796)) (and (cons? V15797) (cons? (hd V15797))))) (shen.variant? (append (hd V15796) (tl V15796)) (append (hd V15797) (tl V15797)))) (true false))) 34 | 35 | (declare absvector? (cons A (cons --> (cons boolean ())))) 36 | 37 | (declare adjoin (cons A (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) 38 | 39 | (declare and (cons boolean (cons --> (cons (cons boolean (cons --> (cons boolean ()))) ())))) 40 | 41 | (declare shen.app (cons A (cons --> (cons (cons string (cons --> (cons (cons symbol (cons --> (cons string ()))) ()))) ())))) 42 | 43 | (declare append (cons (cons list (cons A ())) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) 44 | 45 | (declare arity (cons A (cons --> (cons number ())))) 46 | 47 | (declare assoc (cons A (cons --> (cons (cons (cons list (cons (cons list (cons A ())) ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) 48 | 49 | (declare boolean? (cons A (cons --> (cons boolean ())))) 50 | 51 | (declare bound? (cons symbol (cons --> (cons boolean ())))) 52 | 53 | (declare cd (cons string (cons --> (cons string ())))) 54 | 55 | (declare close (cons (cons stream (cons A ())) (cons --> (cons (cons list (cons B ())) ())))) 56 | 57 | (declare cn (cons string (cons --> (cons (cons string (cons --> (cons string ()))) ())))) 58 | 59 | (declare compile (cons (cons A (cons shen.==> (cons B ()))) (cons --> (cons (cons A (cons --> (cons (cons (cons A (cons --> (cons B ()))) (cons --> (cons B ()))) ()))) ())))) 60 | 61 | (declare cons? (cons A (cons --> (cons boolean ())))) 62 | 63 | (declare destroy (cons (cons A (cons --> (cons B ()))) (cons --> (cons symbol ())))) 64 | 65 | (declare difference (cons (cons list (cons A ())) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) 66 | 67 | (declare do (cons A (cons --> (cons (cons B (cons --> (cons B ()))) ())))) 68 | 69 | (declare (cons (cons list (cons A ())) (cons shen.==> (cons (cons list (cons B ())) ())))) 70 | 71 | (declare shen. (cons (cons list (cons A ())) (cons shen.==> (cons (cons list (cons A ())) ())))) 72 | 73 | (declare element? (cons A (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons boolean ()))) ())))) 74 | 75 | (declare empty? (cons A (cons --> (cons boolean ())))) 76 | 77 | (declare enable-type-theory (cons symbol (cons --> (cons boolean ())))) 78 | 79 | (declare external (cons symbol (cons --> (cons (cons list (cons symbol ())) ())))) 80 | 81 | (declare error-to-string (cons exception (cons --> (cons string ())))) 82 | 83 | (declare explode (cons A (cons --> (cons (cons list (cons string ())) ())))) 84 | 85 | (declare fail (cons --> (cons symbol ()))) 86 | 87 | (declare fail-if (cons (cons symbol (cons --> (cons boolean ()))) (cons --> (cons (cons symbol (cons --> (cons symbol ()))) ())))) 88 | 89 | (declare fix (cons (cons A (cons --> (cons A ()))) (cons --> (cons (cons A (cons --> (cons A ()))) ())))) 90 | 91 | (declare freeze (cons A (cons --> (cons (cons lazy (cons A ())) ())))) 92 | 93 | (declare fst (cons (cons A (cons * (cons B ()))) (cons --> (cons A ())))) 94 | 95 | (declare function (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons A (cons --> (cons B ()))) ())))) 96 | 97 | (declare gensym (cons symbol (cons --> (cons symbol ())))) 98 | 99 | (declare <-vector (cons (cons vector (cons A ())) (cons --> (cons (cons number (cons --> (cons A ()))) ())))) 100 | 101 | (declare vector-> (cons (cons vector (cons A ())) (cons --> (cons (cons number (cons --> (cons (cons A (cons --> (cons (cons vector (cons A ())) ()))) ()))) ())))) 102 | 103 | (declare vector (cons number (cons --> (cons (cons vector (cons A ())) ())))) 104 | 105 | (declare get-time (cons symbol (cons --> (cons number ())))) 106 | 107 | (declare hash (cons A (cons --> (cons (cons number (cons --> (cons number ()))) ())))) 108 | 109 | (declare head (cons (cons list (cons A ())) (cons --> (cons A ())))) 110 | 111 | (declare hdv (cons (cons vector (cons A ())) (cons --> (cons A ())))) 112 | 113 | (declare hdstr (cons string (cons --> (cons string ())))) 114 | 115 | (declare if (cons boolean (cons --> (cons (cons A (cons --> (cons (cons A (cons --> (cons A ()))) ()))) ())))) 116 | 117 | (declare it (cons --> (cons string ()))) 118 | 119 | (declare implementation (cons --> (cons string ()))) 120 | 121 | (declare include (cons (cons list (cons symbol ())) (cons --> (cons (cons list (cons symbol ())) ())))) 122 | 123 | (declare include-all-but (cons (cons list (cons symbol ())) (cons --> (cons (cons list (cons symbol ())) ())))) 124 | 125 | (declare inferences (cons --> (cons number ()))) 126 | 127 | (declare shen.insert (cons A (cons --> (cons (cons string (cons --> (cons string ()))) ())))) 128 | 129 | (declare integer? (cons A (cons --> (cons boolean ())))) 130 | 131 | (declare internal (cons symbol (cons --> (cons (cons list (cons symbol ())) ())))) 132 | 133 | (declare intersection (cons (cons list (cons A ())) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) 134 | 135 | (declare kill (cons --> (cons A ()))) 136 | 137 | (declare language (cons --> (cons string ()))) 138 | 139 | (declare length (cons (cons list (cons A ())) (cons --> (cons number ())))) 140 | 141 | (declare limit (cons (cons vector (cons A ())) (cons --> (cons number ())))) 142 | 143 | (declare load (cons string (cons --> (cons symbol ())))) 144 | 145 | (declare map (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons B ())) ()))) ())))) 146 | 147 | (declare mapcan (cons (cons A (cons --> (cons (cons list (cons B ())) ()))) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons B ())) ()))) ())))) 148 | 149 | (declare maxinferences (cons number (cons --> (cons number ())))) 150 | 151 | (declare n->string (cons number (cons --> (cons string ())))) 152 | 153 | (declare nl (cons number (cons --> (cons number ())))) 154 | 155 | (declare not (cons boolean (cons --> (cons boolean ())))) 156 | 157 | (declare nth (cons number (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons A ()))) ())))) 158 | 159 | (declare number? (cons A (cons --> (cons boolean ())))) 160 | 161 | (declare occurrences (cons A (cons --> (cons (cons B (cons --> (cons number ()))) ())))) 162 | 163 | (declare occurs-check (cons symbol (cons --> (cons boolean ())))) 164 | 165 | (declare optimise (cons symbol (cons --> (cons boolean ())))) 166 | 167 | (declare or (cons boolean (cons --> (cons (cons boolean (cons --> (cons boolean ()))) ())))) 168 | 169 | (declare os (cons --> (cons string ()))) 170 | 171 | (declare package? (cons symbol (cons --> (cons boolean ())))) 172 | 173 | (declare port (cons --> (cons string ()))) 174 | 175 | (declare porters (cons --> (cons string ()))) 176 | 177 | (declare pos (cons string (cons --> (cons (cons number (cons --> (cons string ()))) ())))) 178 | 179 | (declare pr (cons string (cons --> (cons (cons (cons stream (cons out ())) (cons --> (cons string ()))) ())))) 180 | 181 | (declare print (cons A (cons --> (cons A ())))) 182 | 183 | (declare profile (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons A (cons --> (cons B ()))) ())))) 184 | 185 | (declare preclude (cons (cons list (cons symbol ())) (cons --> (cons (cons list (cons symbol ())) ())))) 186 | 187 | (declare shen.proc-nl (cons string (cons --> (cons string ())))) 188 | 189 | (declare profile-results (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons (cons A (cons --> (cons B ()))) (cons * (cons number ()))) ())))) 190 | 191 | (declare protect (cons symbol (cons --> (cons symbol ())))) 192 | 193 | (declare preclude-all-but (cons (cons list (cons symbol ())) (cons --> (cons (cons list (cons symbol ())) ())))) 194 | 195 | (declare shen.prhush (cons string (cons --> (cons (cons (cons stream (cons out ())) (cons --> (cons string ()))) ())))) 196 | 197 | (declare ps (cons symbol (cons --> (cons (cons list (cons unit ())) ())))) 198 | 199 | (declare read (cons (cons stream (cons in ())) (cons --> (cons unit ())))) 200 | 201 | (declare read-byte (cons (cons stream (cons in ())) (cons --> (cons number ())))) 202 | 203 | (declare read-file-as-bytelist (cons string (cons --> (cons (cons list (cons number ())) ())))) 204 | 205 | (declare read-file-as-string (cons string (cons --> (cons string ())))) 206 | 207 | (declare read-file (cons string (cons --> (cons (cons list (cons unit ())) ())))) 208 | 209 | (declare read-from-string (cons string (cons --> (cons (cons list (cons unit ())) ())))) 210 | 211 | (declare release (cons --> (cons string ()))) 212 | 213 | (declare remove (cons A (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) 214 | 215 | (declare reverse (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ())))) 216 | 217 | (declare simple-error (cons string (cons --> (cons A ())))) 218 | 219 | (declare snd (cons (cons A (cons * (cons B ()))) (cons --> (cons B ())))) 220 | 221 | (declare specialise (cons symbol (cons --> (cons symbol ())))) 222 | 223 | (declare spy (cons symbol (cons --> (cons boolean ())))) 224 | 225 | (declare step (cons symbol (cons --> (cons boolean ())))) 226 | 227 | (declare stinput (cons --> (cons (cons stream (cons in ())) ()))) 228 | 229 | (declare stoutput (cons --> (cons (cons stream (cons out ())) ()))) 230 | 231 | (declare string? (cons A (cons --> (cons boolean ())))) 232 | 233 | (declare str (cons A (cons --> (cons string ())))) 234 | 235 | (declare string->n (cons string (cons --> (cons number ())))) 236 | 237 | (declare string->symbol (cons string (cons --> (cons symbol ())))) 238 | 239 | (declare sum (cons (cons list (cons number ())) (cons --> (cons number ())))) 240 | 241 | (declare symbol? (cons A (cons --> (cons boolean ())))) 242 | 243 | (declare systemf (cons symbol (cons --> (cons symbol ())))) 244 | 245 | (declare tail (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ())))) 246 | 247 | (declare tlstr (cons string (cons --> (cons string ())))) 248 | 249 | (declare tlv (cons (cons vector (cons A ())) (cons --> (cons (cons vector (cons A ())) ())))) 250 | 251 | (declare tc (cons symbol (cons --> (cons boolean ())))) 252 | 253 | (declare tc? (cons --> (cons boolean ()))) 254 | 255 | (declare thaw (cons (cons lazy (cons A ())) (cons --> (cons A ())))) 256 | 257 | (declare track (cons symbol (cons --> (cons symbol ())))) 258 | 259 | (declare trap-error (cons A (cons --> (cons (cons (cons exception (cons --> (cons A ()))) (cons --> (cons A ()))) ())))) 260 | 261 | (declare tuple? (cons A (cons --> (cons boolean ())))) 262 | 263 | (declare undefmacro (cons symbol (cons --> (cons symbol ())))) 264 | 265 | (declare union (cons (cons list (cons A ())) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) 266 | 267 | (declare unprofile (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons A (cons --> (cons B ()))) ())))) 268 | 269 | (declare untrack (cons symbol (cons --> (cons symbol ())))) 270 | 271 | (declare unspecialise (cons symbol (cons --> (cons symbol ())))) 272 | 273 | (declare variable? (cons A (cons --> (cons boolean ())))) 274 | 275 | (declare vector? (cons A (cons --> (cons boolean ())))) 276 | 277 | (declare version (cons --> (cons string ()))) 278 | 279 | (declare write-to-file (cons string (cons --> (cons (cons A (cons --> (cons A ()))) ())))) 280 | 281 | (declare write-byte (cons number (cons --> (cons (cons (cons stream (cons out ())) (cons --> (cons number ()))) ())))) 282 | 283 | (declare y-or-n? (cons string (cons --> (cons boolean ())))) 284 | 285 | (declare > (cons number (cons --> (cons (cons number (cons --> (cons boolean ()))) ())))) 286 | 287 | (declare < (cons number (cons --> (cons (cons number (cons --> (cons boolean ()))) ())))) 288 | 289 | (declare >= (cons number (cons --> (cons (cons number (cons --> (cons boolean ()))) ())))) 290 | 291 | (declare <= (cons number (cons --> (cons (cons number (cons --> (cons boolean ()))) ())))) 292 | 293 | (declare = (cons A (cons --> (cons (cons A (cons --> (cons boolean ()))) ())))) 294 | 295 | (declare + (cons number (cons --> (cons (cons number (cons --> (cons number ()))) ())))) 296 | 297 | (declare / (cons number (cons --> (cons (cons number (cons --> (cons number ()))) ())))) 298 | 299 | (declare - (cons number (cons --> (cons (cons number (cons --> (cons number ()))) ())))) 300 | 301 | (declare * (cons number (cons --> (cons (cons number (cons --> (cons number ()))) ())))) 302 | 303 | (declare == (cons A (cons --> (cons (cons B (cons --> (cons boolean ()))) ())))) 304 | 305 | 306 | 307 | -------------------------------------------------------------------------------- /KLambda/writer.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun pr (V15800 V15801) (trap-error (shen.prh V15800 V15801 0) (lambda E V15800))) 27 | 28 | (defun shen.prh (V15805 V15806 V15807) (shen.prh V15805 V15806 (shen.write-char-and-inc V15805 V15806 V15807))) 29 | 30 | (defun shen.write-char-and-inc (V15811 V15812 V15813) (do (write-byte (string->n (pos V15811 V15813)) V15812) (+ V15813 1))) 31 | 32 | (defun print (V15815) (let String (shen.insert V15815 "~S") (let Print (shen.prhush String (stoutput)) V15815))) 33 | 34 | (defun shen.prhush (V15818 V15819) (if (value *hush*) V15818 (pr V15818 V15819))) 35 | 36 | (defun shen.mkstr (V15822 V15823) (cond ((string? V15822) (shen.mkstr-l (shen.proc-nl V15822) V15823)) (true (shen.mkstr-r (cons shen.proc-nl (cons V15822 ())) V15823)))) 37 | 38 | (defun shen.mkstr-l (V15826 V15827) (cond ((= () V15827) V15826) ((cons? V15827) (shen.mkstr-l (shen.insert-l (hd V15827) V15826) (tl V15827))) (true (shen.f_error shen.mkstr-l)))) 39 | 40 | (defun shen.insert-l (V15832 V15833) (cond ((= "" V15833) "") ((and (shen.+string? V15833) (and (= "~" (pos V15833 0)) (and (shen.+string? (tlstr V15833)) (= "A" (pos (tlstr V15833) 0))))) (cons shen.app (cons V15832 (cons (tlstr (tlstr V15833)) (cons shen.a ()))))) ((and (shen.+string? V15833) (and (= "~" (pos V15833 0)) (and (shen.+string? (tlstr V15833)) (= "R" (pos (tlstr V15833) 0))))) (cons shen.app (cons V15832 (cons (tlstr (tlstr V15833)) (cons shen.r ()))))) ((and (shen.+string? V15833) (and (= "~" (pos V15833 0)) (and (shen.+string? (tlstr V15833)) (= "S" (pos (tlstr V15833) 0))))) (cons shen.app (cons V15832 (cons (tlstr (tlstr V15833)) (cons shen.s ()))))) ((shen.+string? V15833) (shen.factor-cn (cons cn (cons (pos V15833 0) (cons (shen.insert-l V15832 (tlstr V15833)) ()))))) ((and (cons? V15833) (and (= cn (hd V15833)) (and (cons? (tl V15833)) (and (cons? (tl (tl V15833))) (= () (tl (tl (tl V15833)))))))) (cons cn (cons (hd (tl V15833)) (cons (shen.insert-l V15832 (hd (tl (tl V15833)))) ())))) ((and (cons? V15833) (and (= shen.app (hd V15833)) (and (cons? (tl V15833)) (and (cons? (tl (tl V15833))) (and (cons? (tl (tl (tl V15833)))) (= () (tl (tl (tl (tl V15833)))))))))) (cons shen.app (cons (hd (tl V15833)) (cons (shen.insert-l V15832 (hd (tl (tl V15833)))) (tl (tl (tl V15833))))))) (true (shen.f_error shen.insert-l)))) 41 | 42 | (defun shen.factor-cn (V15835) (cond ((and (cons? V15835) (and (= cn (hd V15835)) (and (cons? (tl V15835)) (and (cons? (tl (tl V15835))) (and (cons? (hd (tl (tl V15835)))) (and (= cn (hd (hd (tl (tl V15835))))) (and (cons? (tl (hd (tl (tl V15835))))) (and (cons? (tl (tl (hd (tl (tl V15835)))))) (and (= () (tl (tl (tl (hd (tl (tl V15835))))))) (and (= () (tl (tl (tl V15835)))) (and (string? (hd (tl V15835))) (string? (hd (tl (hd (tl (tl V15835))))))))))))))))) (cons cn (cons (cn (hd (tl V15835)) (hd (tl (hd (tl (tl V15835)))))) (tl (tl (hd (tl (tl V15835)))))))) (true V15835))) 43 | 44 | (defun shen.proc-nl (V15837) (cond ((= "" V15837) "") ((and (shen.+string? V15837) (and (= "~" (pos V15837 0)) (and (shen.+string? (tlstr V15837)) (= "%" (pos (tlstr V15837) 0))))) (cn (n->string 10) (shen.proc-nl (tlstr (tlstr V15837))))) ((shen.+string? V15837) (cn (pos V15837 0) (shen.proc-nl (tlstr V15837)))) (true (shen.f_error shen.proc-nl)))) 45 | 46 | (defun shen.mkstr-r (V15840 V15841) (cond ((= () V15841) V15840) ((cons? V15841) (shen.mkstr-r (cons shen.insert (cons (hd V15841) (cons V15840 ()))) (tl V15841))) (true (shen.f_error shen.mkstr-r)))) 47 | 48 | (defun shen.insert (V15844 V15845) (shen.insert-h V15844 V15845 "")) 49 | 50 | (defun shen.insert-h (V15851 V15852 V15853) (cond ((= "" V15852) V15853) ((and (shen.+string? V15852) (and (= "~" (pos V15852 0)) (and (shen.+string? (tlstr V15852)) (= "A" (pos (tlstr V15852) 0))))) (cn V15853 (shen.app V15851 (tlstr (tlstr V15852)) shen.a))) ((and (shen.+string? V15852) (and (= "~" (pos V15852 0)) (and (shen.+string? (tlstr V15852)) (= "R" (pos (tlstr V15852) 0))))) (cn V15853 (shen.app V15851 (tlstr (tlstr V15852)) shen.r))) ((and (shen.+string? V15852) (and (= "~" (pos V15852 0)) (and (shen.+string? (tlstr V15852)) (= "S" (pos (tlstr V15852) 0))))) (cn V15853 (shen.app V15851 (tlstr (tlstr V15852)) shen.s))) ((shen.+string? V15852) (shen.insert-h V15851 (tlstr V15852) (cn V15853 (pos V15852 0)))) (true (shen.f_error shen.insert-h)))) 51 | 52 | (defun shen.app (V15857 V15858 V15859) (cn (shen.arg->str V15857 V15859) V15858)) 53 | 54 | (defun shen.arg->str (V15867 V15868) (cond ((= V15867 (fail)) "...") ((shen.list? V15867) (shen.list->str V15867 V15868)) ((string? V15867) (shen.str->str V15867 V15868)) ((absvector? V15867) (shen.vector->str V15867 V15868)) (true (shen.atom->str V15867)))) 55 | 56 | (defun shen.list->str (V15871 V15872) (cond ((= shen.r V15872) (@s "(" (@s (shen.iter-list V15871 shen.r (shen.maxseq)) ")"))) (true (@s "[" (@s (shen.iter-list V15871 V15872 (shen.maxseq)) "]"))))) 57 | 58 | (defun shen.maxseq () (value *maximum-print-sequence-size*)) 59 | 60 | (defun shen.iter-list (V15886 V15887 V15888) (cond ((= () V15886) "") ((= 0 V15888) "... etc") ((and (cons? V15886) (= () (tl V15886))) (shen.arg->str (hd V15886) V15887)) ((cons? V15886) (@s (shen.arg->str (hd V15886) V15887) (@s " " (shen.iter-list (tl V15886) V15887 (- V15888 1))))) (true (@s "|" (@s " " (shen.arg->str V15886 V15887)))))) 61 | 62 | (defun shen.str->str (V15895 V15896) (cond ((= shen.a V15896) V15895) (true (@s (n->string 34) (@s V15895 (n->string 34)))))) 63 | 64 | (defun shen.vector->str (V15899 V15900) (if (shen.print-vector? V15899) ((function (<-address V15899 0)) V15899) (if (vector? V15899) (@s "<" (@s (shen.iter-vector V15899 1 V15900 (shen.maxseq)) ">")) (@s "<" (@s "<" (@s (shen.iter-vector V15899 0 V15900 (shen.maxseq)) ">>")))))) 65 | 66 | (defun shen.print-vector? (V15902) (let Zero (<-address V15902 0) (if (= Zero shen.tuple) true (if (= Zero shen.pvar) true (if (not (number? Zero)) (shen.fbound? Zero) false))))) 67 | 68 | (defun shen.fbound? (V15904) (trap-error (do (ps V15904) true) (lambda E false))) 69 | 70 | (defun shen.tuple (V15906) (cn "(@p " (shen.app (<-address V15906 1) (cn " " (shen.app (<-address V15906 2) ")" shen.s)) shen.s))) 71 | 72 | (defun shen.iter-vector (V15917 V15918 V15919 V15920) (cond ((= 0 V15920) "... etc") (true (let Item (trap-error (<-address V15917 V15918) (lambda E shen.out-of-bounds)) (let Next (trap-error (<-address V15917 (+ V15918 1)) (lambda E shen.out-of-bounds)) (if (= Item shen.out-of-bounds) "" (if (= Next shen.out-of-bounds) (shen.arg->str Item V15919) (@s (shen.arg->str Item V15919) (@s " " (shen.iter-vector V15917 (+ V15918 1) V15919 (- V15920 1))))))))))) 73 | 74 | (defun shen.atom->str (V15922) (trap-error (str V15922) (lambda E (shen.funexstring)))) 75 | 76 | (defun shen.funexstring () (@s "" (@s "f" (@s "u" (@s "n" (@s "e" (@s (shen.arg->str (gensym (intern "x")) shen.a) ""))))))) 77 | 78 | (defun shen.list? (V15924) (or (empty? V15924) (cons? V15924))) 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /KLambda/yacc.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2015, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of Mark Tarver may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." 25 | 26 | (defun shen.yacc (V15926) (cond ((and (cons? V15926) (and (= defcc (hd V15926)) (cons? (tl V15926)))) (shen.yacc->shen (hd (tl V15926)) (tl (tl V15926)))) (true (shen.f_error shen.yacc)))) 27 | 28 | (defun shen.yacc->shen (V15929 V15930) (let CCRules (shen.split_cc_rules true V15930 ()) (let CCBody (map (lambda X (shen.cc_body X)) CCRules) (let YaccCases (shen.yacc_cases CCBody) (cons define (cons V15929 (cons Stream (cons -> (cons (shen.kill-code YaccCases) ()))))))))) 29 | 30 | (defun shen.kill-code (V15932) (cond ((> (occurrences kill V15932) 0) (cons trap-error (cons V15932 (cons (cons lambda (cons E (cons (cons shen.analyse-kill (cons E ())) ()))) ())))) (true V15932))) 31 | 32 | (defun kill () (simple-error "yacc kill")) 33 | 34 | (defun shen.analyse-kill (V15934) (let String (error-to-string V15934) (if (= String "yacc kill") (fail) V15934))) 35 | 36 | (defun shen.split_cc_rules (V15940 V15941 V15942) (cond ((and (= () V15941) (= () V15942)) ()) ((= () V15941) (cons (shen.split_cc_rule V15940 (reverse V15942) ()) ())) ((and (cons? V15941) (= ; (hd V15941))) (cons (shen.split_cc_rule V15940 (reverse V15942) ()) (shen.split_cc_rules V15940 (tl V15941) ()))) ((cons? V15941) (shen.split_cc_rules V15940 (tl V15941) (cons (hd V15941) V15942))) (true (shen.f_error shen.split_cc_rules)))) 37 | 38 | (defun shen.split_cc_rule (V15950 V15951 V15952) (cond ((and (cons? V15951) (and (= := (hd V15951)) (and (cons? (tl V15951)) (= () (tl (tl V15951)))))) (cons (reverse V15952) (tl V15951))) ((and (cons? V15951) (and (= := (hd V15951)) (and (cons? (tl V15951)) (and (cons? (tl (tl V15951))) (and (= where (hd (tl (tl V15951)))) (and (cons? (tl (tl (tl V15951)))) (= () (tl (tl (tl (tl V15951))))))))))) (cons (reverse V15952) (cons (cons where (cons (hd (tl (tl (tl V15951)))) (cons (hd (tl V15951)) ()))) ()))) ((= () V15951) (do (shen.semantic-completion-warning V15950 V15952) (shen.split_cc_rule V15950 (cons := (cons (shen.default_semantics (reverse V15952)) ())) V15952))) ((cons? V15951) (shen.split_cc_rule V15950 (tl V15951) (cons (hd V15951) V15952))) (true (shen.f_error shen.split_cc_rule)))) 39 | 40 | (defun shen.semantic-completion-warning (V15963 V15964) (cond ((= true V15963) (do (shen.prhush "warning: " (stoutput)) (do (map (lambda X (shen.prhush (shen.app X " " shen.a) (stoutput))) (reverse V15964)) (shen.prhush "has no semantics. 41 | " (stoutput))))) (true shen.skip))) 42 | 43 | (defun shen.default_semantics (V15966) (cond ((= () V15966) ()) ((and (cons? V15966) (and (= () (tl V15966)) (shen.grammar_symbol? (hd V15966)))) (hd V15966)) ((and (cons? V15966) (shen.grammar_symbol? (hd V15966))) (cons append (cons (hd V15966) (cons (shen.default_semantics (tl V15966)) ())))) ((cons? V15966) (cons cons (cons (hd V15966) (cons (shen.default_semantics (tl V15966)) ())))) (true (shen.f_error shen.default_semantics)))) 44 | 45 | (defun shen.grammar_symbol? (V15968) (and (symbol? V15968) (let Cs (shen.strip-pathname (explode V15968)) (and (= (hd Cs) "<") (= (hd (reverse Cs)) ">"))))) 46 | 47 | (defun shen.yacc_cases (V15970) (cond ((and (cons? V15970) (= () (tl V15970))) (hd V15970)) ((cons? V15970) (let P YaccParse (cons let (cons P (cons (hd V15970) (cons (cons if (cons (cons = (cons P (cons (cons fail ()) ()))) (cons (shen.yacc_cases (tl V15970)) (cons P ())))) ())))))) (true (shen.f_error shen.yacc_cases)))) 48 | 49 | (defun shen.cc_body (V15972) (cond ((and (cons? V15972) (and (cons? (tl V15972)) (= () (tl (tl V15972))))) (shen.syntax (hd V15972) Stream (hd (tl V15972)))) (true (shen.f_error shen.cc_body)))) 50 | 51 | (defun shen.syntax (V15976 V15977 V15978) (cond ((and (= () V15976) (and (cons? V15978) (and (= where (hd V15978)) (and (cons? (tl V15978)) (and (cons? (tl (tl V15978))) (= () (tl (tl (tl V15978))))))))) (cons if (cons (shen.semantics (hd (tl V15978))) (cons (cons shen.pair (cons (cons hd (cons V15977 ())) (cons (shen.semantics (hd (tl (tl V15978)))) ()))) (cons (cons fail ()) ()))))) ((= () V15976) (cons shen.pair (cons (cons hd (cons V15977 ())) (cons (shen.semantics V15978) ())))) ((cons? V15976) (if (shen.grammar_symbol? (hd V15976)) (shen.recursive_descent V15976 V15977 V15978) (if (variable? (hd V15976)) (shen.variable-match V15976 V15977 V15978) (if (shen.jump_stream? (hd V15976)) (shen.jump_stream V15976 V15977 V15978) (if (shen.terminal? (hd V15976)) (shen.check_stream V15976 V15977 V15978) (if (cons? (hd V15976)) (shen.list-stream (shen.decons (hd V15976)) (tl V15976) V15977 V15978) (simple-error (shen.app (hd V15976) " is not legal syntax 52 | " shen.a)))))))) (true (shen.f_error shen.syntax)))) 53 | 54 | (defun shen.list-stream (V15983 V15984 V15985 V15986) (let Test (cons and (cons (cons cons? (cons (cons hd (cons V15985 ())) ())) (cons (cons cons? (cons (cons hd (cons (cons hd (cons V15985 ())) ())) ())) ()))) (let Placeholder (gensym shen.place) (let RunOn (shen.syntax V15984 (cons shen.pair (cons (cons tl (cons (cons hd (cons V15985 ())) ())) (cons (cons hd (cons (cons tl (cons V15985 ())) ())) ()))) V15986) (let Action (shen.insert-runon RunOn Placeholder (shen.syntax V15983 (cons shen.pair (cons (cons hd (cons (cons hd (cons V15985 ())) ())) (cons (cons hd (cons (cons tl (cons V15985 ())) ())) ()))) Placeholder)) (cons if (cons Test (cons Action (cons (cons fail ()) ()))))))))) 55 | 56 | (defun shen.decons (V15988) (cond ((and (cons? V15988) (and (= cons (hd V15988)) (and (cons? (tl V15988)) (and (cons? (tl (tl V15988))) (and (= () (hd (tl (tl V15988)))) (= () (tl (tl (tl V15988))))))))) (cons (hd (tl V15988)) ())) ((and (cons? V15988) (and (= cons (hd V15988)) (and (cons? (tl V15988)) (and (cons? (tl (tl V15988))) (= () (tl (tl (tl V15988)))))))) (cons (hd (tl V15988)) (shen.decons (hd (tl (tl V15988)))))) (true V15988))) 57 | 58 | (defun shen.insert-runon (V16003 V16004 V16005) (cond ((and (cons? V16005) (and (= shen.pair (hd V16005)) (and (cons? (tl V16005)) (and (cons? (tl (tl V16005))) (and (= () (tl (tl (tl V16005)))) (= (hd (tl (tl V16005))) V16004)))))) V16003) ((cons? V16005) (map (lambda Z (shen.insert-runon V16003 V16004 Z)) V16005)) (true V16005))) 59 | 60 | (defun shen.strip-pathname (V16011) (cond ((not (element? "." V16011)) V16011) ((cons? V16011) (shen.strip-pathname (tl V16011))) (true (shen.f_error shen.strip-pathname)))) 61 | 62 | (defun shen.recursive_descent (V16015 V16016 V16017) (cond ((cons? V16015) (let Test (cons (hd V16015) (cons V16016 ())) (let Action (shen.syntax (tl V16015) (concat Parse_ (hd V16015)) V16017) (let Else (cons fail ()) (cons let (cons (concat Parse_ (hd V16015)) (cons Test (cons (cons if (cons (cons not (cons (cons = (cons (cons fail ()) (cons (concat Parse_ (hd V16015)) ()))) ())) (cons Action (cons Else ())))) ())))))))) (true (shen.f_error shen.recursive_descent)))) 63 | 64 | (defun shen.variable-match (V16021 V16022 V16023) (cond ((cons? V16021) (let Test (cons cons? (cons (cons hd (cons V16022 ())) ())) (let Action (cons let (cons (concat Parse_ (hd V16021)) (cons (cons hd (cons (cons hd (cons V16022 ())) ())) (cons (shen.syntax (tl V16021) (cons shen.pair (cons (cons tl (cons (cons hd (cons V16022 ())) ())) (cons (cons shen.hdtl (cons V16022 ())) ()))) V16023) ())))) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.f_error shen.variable-match)))) 65 | 66 | (defun shen.terminal? (V16033) (cond ((cons? V16033) false) ((variable? V16033) false) (true true))) 67 | 68 | (defun shen.jump_stream? (V16039) (cond ((= V16039 _) true) (true false))) 69 | 70 | (defun shen.check_stream (V16043 V16044 V16045) (cond ((cons? V16043) (let Test (cons and (cons (cons cons? (cons (cons hd (cons V16044 ())) ())) (cons (cons = (cons (hd V16043) (cons (cons hd (cons (cons hd (cons V16044 ())) ())) ()))) ()))) (let Action (shen.syntax (tl V16043) (cons shen.pair (cons (cons tl (cons (cons hd (cons V16044 ())) ())) (cons (cons shen.hdtl (cons V16044 ())) ()))) V16045) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.f_error shen.check_stream)))) 71 | 72 | (defun shen.jump_stream (V16049 V16050 V16051) (cond ((cons? V16049) (let Test (cons cons? (cons (cons hd (cons V16050 ())) ())) (let Action (shen.syntax (tl V16049) (cons shen.pair (cons (cons tl (cons (cons hd (cons V16050 ())) ())) (cons (cons shen.hdtl (cons V16050 ())) ()))) V16051) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.f_error shen.jump_stream)))) 73 | 74 | (defun shen.semantics (V16053) (cond ((= () V16053) ()) ((shen.grammar_symbol? V16053) (cons shen.hdtl (cons (concat Parse_ V16053) ()))) ((variable? V16053) (concat Parse_ V16053)) ((cons? V16053) (map (lambda Z (shen.semantics Z)) V16053)) (true V16053))) 75 | 76 | (defun shen.snd-or-fail (V16061) (cond ((and (cons? V16061) (and (cons? (tl V16061)) (= () (tl (tl V16061))))) (hd (tl V16061))) (true (fail)))) 77 | 78 | (defun fail () shen.fail!)(defun shen.pair (V16064 V16065) (cons V16064 (cons V16065 ()))) 79 | 80 | (defun shen.hdtl (V16067) (hd (tl V16067))) 81 | 82 | (defun shen. (V16075) (cond ((and (cons? V16075) (and (cons? (tl V16075)) (= () (tl (tl V16075))))) (cons () (cons (hd V16075) ()))) (true (fail)))) 83 | 84 | (defun (V16081) (cond ((and (cons? V16081) (and (cons? (tl V16081)) (= () (tl (tl V16081))))) (cons (hd V16081) (cons () ()))) (true (shen.f_error )))) 85 | 86 | 87 | 88 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import ./nix {}).shen_rust 2 | -------------------------------------------------------------------------------- /nix/default.nix: -------------------------------------------------------------------------------- 1 | { rustRelease ? { channel = "nightly"; date = "2019-07-15"; } }: 2 | 3 | let 4 | # NIXPKGS RELEASE-19.03 (STABLE) BRANCH @ 2019-07-09 5 | nixpkgs = builtins.fetchTarball { 6 | url = "https://github.com/NixOS/nixpkgs/archive/28e64db237dbe1e0d430cb61e7372223b49635b9.tar.gz"; 7 | sha256 = "0hwy0b1axikzx7xlcqf7p7698rhpw3x0hlsm2hk0j8iv6ampdgda"; 8 | }; 9 | in 10 | 11 | import nixpkgs { 12 | overlays = [ 13 | # MOZILLA (RUST) OVERLAY (MASTER BRANCH @ 2019-07-09) 14 | (import 15 | (builtins.fetchTarball 16 | https://github.com/mozilla/nixpkgs-mozilla/archive/200cf0640fd8fdff0e1a342db98c9e31e6f13cd7.tar.gz)) 17 | ]; 18 | 19 | config = { 20 | packageOverrides = super: 21 | let self = super.pkgs; 22 | # TRANSFORM NIXPKGS TARGET -> RUSTC TARGET 23 | target = builtins.replaceStrings 24 | ["armv7l"] ["armv7"] 25 | self.targetPlatform.config; 26 | in { 27 | rust = 28 | self.rustChannelOfTargets 29 | rustRelease.channel 30 | rustRelease.date 31 | [ target ]; 32 | rustc = self.rust; # (A METAPACKAGE THAT INCLUDES 'rustc') 33 | cargo = self.rust; # (A METAPACKAGE THAT INCLUDES 'cargo') 34 | cratesIO = self.callPackage ./crates-io.nix {}; 35 | shen_rust = (self.callPackage ../Cargo.nix {}).shen_rust {}; 36 | }; 37 | }; 38 | } 39 | -------------------------------------------------------------------------------- /nix/release.nix: -------------------------------------------------------------------------------- 1 | let 2 | build = channel: date: 3 | let pkgs = import ./. { 4 | rustRelease = { inherit channel date; }; 5 | }; in pkgs.shen_rust; 6 | 7 | in rec { 8 | 9 | nightly = nightly_2019_07_15; 10 | nightly_2019_07_15 = build "nightly" "2019-07-15"; 11 | nightly_2019_07_01 = build "nightly" "2019-07-01"; 12 | nightly_2019_06_15 = build "nightly" "2019-06-15"; 13 | nightly_2019_06_01 = build "nightly" "2019-06-01"; 14 | 15 | } 16 | --------------------------------------------------------------------------------