shen-ruby 0.10.0 → 0.11.0

Sign up to get free protection for your applications and to get access to all the features.
Files changed (128) hide show
  1. checksums.yaml +4 -4
  2. data/.rspec +1 -0
  3. data/.travis.yml +9 -3
  4. data/Gemfile +1 -4
  5. data/HISTORY.md +16 -0
  6. data/MIT_LICENSE.txt +1 -1
  7. data/README.md +25 -26
  8. data/Rakefile +3 -11
  9. data/bin/shen_test_suite.rb +15 -3
  10. data/bin/srrepl +6 -8
  11. data/lib/shen_ruby.rb +6 -1
  12. data/lib/shen_ruby/converters.rb +23 -0
  13. data/lib/shen_ruby/version.rb +1 -1
  14. data/shen-ruby.gemspec +4 -1
  15. data/shen/lib/shen_ruby/shen.rb +49 -33
  16. data/shen/release/benchmarks/N_queens.shen +45 -45
  17. data/shen/release/benchmarks/README.shen +14 -14
  18. data/shen/release/benchmarks/benchmarks.shen +52 -52
  19. data/shen/release/benchmarks/einstein.shen +32 -32
  20. data/shen/release/benchmarks/interpreter.shen +219 -219
  21. data/shen/release/benchmarks/jnk.shen +193 -193
  22. data/shen/release/benchmarks/powerset.shen +10 -10
  23. data/shen/release/benchmarks/prime.shen +10 -10
  24. data/shen/release/benchmarks/short.shen +129 -129
  25. data/shen/release/k_lambda/core.kl +181 -181
  26. data/shen/release/k_lambda/declarations.kl +131 -131
  27. data/shen/release/k_lambda/load.kl +84 -84
  28. data/shen/release/k_lambda/macros.kl +112 -112
  29. data/shen/release/k_lambda/prolog.kl +252 -252
  30. data/shen/release/k_lambda/reader.kl +222 -222
  31. data/shen/release/k_lambda/sequent.kl +166 -166
  32. data/shen/release/k_lambda/sys.kl +271 -271
  33. data/shen/release/k_lambda/t-star.kl +139 -139
  34. data/shen/release/k_lambda/toplevel.kl +135 -135
  35. data/shen/release/k_lambda/track.kl +103 -103
  36. data/shen/release/k_lambda/types.kl +324 -324
  37. data/shen/release/k_lambda/writer.kl +105 -105
  38. data/shen/release/k_lambda/yacc.kl +113 -113
  39. data/shen/release/test_programs/Chap13/problems.txt +26 -26
  40. data/shen/release/test_programs/README.shen +52 -52
  41. data/shen/release/test_programs/TinyLispFunctions.txt +15 -15
  42. data/shen/release/test_programs/TinyTypes.shen +55 -55
  43. data/shen/release/test_programs/binary.shen +24 -24
  44. data/shen/release/test_programs/bubble_version_1.shen +28 -28
  45. data/shen/release/test_programs/bubble_version_2.shen +22 -22
  46. data/shen/release/test_programs/calculator.shen +21 -21
  47. data/shen/release/test_programs/cartprod.shen +23 -23
  48. data/shen/release/test_programs/change.shen +25 -25
  49. data/shen/release/test_programs/classes-defaults.shen +94 -94
  50. data/shen/release/test_programs/classes-inheritance.shen +100 -100
  51. data/shen/release/test_programs/classes-typed.shen +74 -74
  52. data/shen/release/test_programs/classes-untyped.shen +46 -46
  53. data/shen/release/test_programs/depth_.shen +14 -14
  54. data/shen/release/test_programs/einstein.shen +34 -34
  55. data/shen/release/test_programs/fruit_machine.shen +46 -46
  56. data/shen/release/test_programs/interpreter.shen +217 -217
  57. data/shen/release/test_programs/metaprog.shen +85 -85
  58. data/shen/release/test_programs/minim.shen +192 -192
  59. data/shen/release/test_programs/mutual.shen +11 -11
  60. data/shen/release/test_programs/n_queens.shen +45 -45
  61. data/shen/release/test_programs/newton_version_1.shen +33 -33
  62. data/shen/release/test_programs/newton_version_2.shen +24 -24
  63. data/shen/release/test_programs/parse.prl +14 -14
  64. data/shen/release/test_programs/parser.shen +51 -51
  65. data/shen/release/test_programs/powerset.shen +10 -10
  66. data/shen/release/test_programs/prime.shen +10 -10
  67. data/shen/release/test_programs/prolog.shen +78 -78
  68. data/shen/release/test_programs/proof_assistant.shen +80 -80
  69. data/shen/release/test_programs/proplog_version_1.shen +25 -25
  70. data/shen/release/test_programs/proplog_version_2.shen +27 -27
  71. data/shen/release/test_programs/qmachine.shen +66 -66
  72. data/shen/release/test_programs/red-black.shen +54 -54
  73. data/shen/release/test_programs/search.shen +55 -55
  74. data/shen/release/test_programs/semantic_net.shen +44 -44
  75. data/shen/release/test_programs/spreadsheet.shen +34 -34
  76. data/shen/release/test_programs/stack.shen +27 -27
  77. data/shen/release/test_programs/streams.shen +20 -20
  78. data/shen/release/test_programs/strings.shen +57 -57
  79. data/shen/release/test_programs/structures-typed.shen +71 -71
  80. data/shen/release/test_programs/structures-untyped.shen +41 -41
  81. data/shen/release/test_programs/tests.shen +232 -232
  82. data/shen/release/test_programs/types.shen +11 -11
  83. data/shen/release/test_programs/whist.shen +239 -239
  84. data/shen/release/test_programs/yacc.shen +132 -132
  85. data/spec/shen_ruby/converters_spec.rb +48 -0
  86. data/spec/spec_helper.rb +1 -2
  87. metadata +55 -60
  88. data/k_lambda_spec/atom_spec.rb +0 -85
  89. data/k_lambda_spec/primitives/arithmetic_spec.rb +0 -175
  90. data/k_lambda_spec/primitives/assignments_spec.rb +0 -44
  91. data/k_lambda_spec/primitives/boolean_operations_spec.rb +0 -136
  92. data/k_lambda_spec/primitives/generic_functions_spec.rb +0 -120
  93. data/k_lambda_spec/primitives/lists_spec.rb +0 -40
  94. data/k_lambda_spec/primitives/strings_spec.rb +0 -77
  95. data/k_lambda_spec/primitives/symbols_spec.rb +0 -24
  96. data/k_lambda_spec/primitives/vectors_spec.rb +0 -92
  97. data/k_lambda_spec/spec_helper.rb +0 -29
  98. data/k_lambda_spec/support/shared_examples.rb +0 -124
  99. data/k_lambda_spec/tail_recursion_spec.rb +0 -30
  100. data/lib/kl.rb +0 -7
  101. data/lib/kl/absvector.rb +0 -12
  102. data/lib/kl/compiler.rb +0 -360
  103. data/lib/kl/cons.rb +0 -51
  104. data/lib/kl/empty_list.rb +0 -12
  105. data/lib/kl/environment.rb +0 -163
  106. data/lib/kl/error.rb +0 -4
  107. data/lib/kl/internal_error.rb +0 -7
  108. data/lib/kl/lexer.rb +0 -186
  109. data/lib/kl/primitives/arithmetic.rb +0 -60
  110. data/lib/kl/primitives/assignments.rb +0 -15
  111. data/lib/kl/primitives/booleans.rb +0 -21
  112. data/lib/kl/primitives/error_handling.rb +0 -13
  113. data/lib/kl/primitives/extensions.rb +0 -12
  114. data/lib/kl/primitives/generic_functions.rb +0 -29
  115. data/lib/kl/primitives/lists.rb +0 -23
  116. data/lib/kl/primitives/streams.rb +0 -28
  117. data/lib/kl/primitives/strings.rb +0 -63
  118. data/lib/kl/primitives/symbols.rb +0 -18
  119. data/lib/kl/primitives/time.rb +0 -17
  120. data/lib/kl/primitives/vectors.rb +0 -36
  121. data/lib/kl/reader.rb +0 -46
  122. data/spec/kl/cons_spec.rb +0 -12
  123. data/spec/kl/environment_spec.rb +0 -282
  124. data/spec/kl/interop_spec.rb +0 -68
  125. data/spec/kl/lexer_spec.rb +0 -149
  126. data/spec/kl/primitives/generic_functions_spec.rb +0 -29
  127. data/spec/kl/primitives/symbols_spec.rb +0 -21
  128. data/spec/kl/reader_spec.rb +0 -42
data/shen/release/k_lambda/core.kl CHANGED
@@ -1,181 +1,181 @@
1
- "**********************************************************************************
2
- * The License *
3
- * *
4
- * The user is free to produce commercial applications with the software, to *
5
- * distribute these applications in source or binary form, and to charge monies *
6
- * for them as he sees fit and in concordance with the laws of the land subject *
7
- * to the following license. *
8
- * *
9
- * 1. The license applies to all the software and all derived software and *
10
- * must appear on such. *
11
- * *
12
- * 2. It is illegal to distribute the software without this license attached *
13
- * to it and use of the software implies agreement with the license as such. *
14
- * It is illegal for anyone who is not the copyright holder to tamper with *
15
- * or change the license. *
16
- * *
17
- * 3. Neither the names of Lambda Associates or the copyright holder may be used *
18
- * to endorse or promote products built using the software without specific *
19
- * prior written permission from the copyright holder. *
20
- * *
21
- * 4. That possession of this license does not confer on the copyright holder *
22
- * any special contractual obligation towards the user. That in no event *
23
- * shall the copyright holder be liable for any direct, indirect, incidental, *
24
- * special, exemplary or consequential damages (including but not limited *
25
- * to procurement of substitute goods or services, loss of use, data, *
26
- * interruption), however caused and on any theory of liability, whether in *
27
- * contract, strict liability or tort (including negligence) arising in any *
28
- * way out of the use of the software, even if advised of the possibility of *
29
- * such damage. *
30
- * *
31
- * 5. It is permitted for the user to change the software, for the purpose of *
32
- * improving performance, correcting an error, or porting to a new platform, *
33
- * and distribute the derived version of Shen provided the resulting program *
34
- * conforms in all respects to the Shen standard and is issued under that *
35
- * title. The user must make it clear with his distribution that he/she is *
36
- * the author of the changes and what these changes are and why. *
37
- * *
38
- * 6. Derived versions of this software in whatever form are subject to the same *
39
- * restrictions. In particular it is not permitted to make derived copies of *
40
- * this software which do not conform to the Shen standard or appear under a *
41
- * different title. *
42
- * *
43
- * It is permitted to distribute versions of Shen which incorporate libraries, *
44
- * graphics or other facilities which are not part of the Shen standard. *
45
- * *
46
- * For an explication of this license see www.shenlanguage.org/license.htm which *
47
- * explains this license in full. *
48
- * *
49
- *****************************************************************************************
50
- "(defun shen.shen->kl (V614 V615) (compile (lambda X608 (shen.<define> X608)) (cons V614 V615) (lambda X (shen.shen-syntax-error V614 X))))
51
-
52
- (defun shen.shen-syntax-error (V616 V617) (simple-error (cn "syntax error in " (shen.app V616 (cn " here:
53
-
54
- " (shen.app (shen.next-50 50 V617) "
55
- " shen.a)) shen.a))))
56
-
57
- (defun shen.<define> (V622) (let Result (let Parse_shen.<name> (shen.<name> V622) (if (not (= (fail) Parse_shen.<name>)) (let Parse_shen.<signature> (shen.<signature> Parse_shen.<name>) (if (not (= (fail) Parse_shen.<signature>)) (let Parse_shen.<rules> (shen.<rules> Parse_shen.<signature>) (if (not (= (fail) Parse_shen.<rules>)) (shen.pair (hd Parse_shen.<rules>) (shen.compile_to_machine_code (shen.hdtl Parse_shen.<name>) (shen.hdtl Parse_shen.<rules>))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<name> (shen.<name> V622) (if (not (= (fail) Parse_shen.<name>)) (let Parse_shen.<rules> (shen.<rules> Parse_shen.<name>) (if (not (= (fail) Parse_shen.<rules>)) (shen.pair (hd Parse_shen.<rules>) (shen.compile_to_machine_code (shen.hdtl Parse_shen.<name>) (shen.hdtl Parse_shen.<rules>))) (fail))) (fail))) (if (= Result (fail)) (fail) Result)) Result)))
58
-
59
- (defun shen.<name> (V627) (let Result (if (cons? (hd V627)) (let Parse_X (hd (hd V627)) (shen.pair (hd (shen.pair (tl (hd V627)) (shen.hdtl V627))) (if (and (symbol? Parse_X) (not (shen.sysfunc? Parse_X))) Parse_X (simple-error (shen.app Parse_X " is not a legitimate function name.
60
- " shen.a))))) (fail)) (if (= Result (fail)) (fail) Result)))
61
-
62
- (defun shen.sysfunc? (V628) (element? V628 (get (intern "shen") shen.external-symbols (value *property-vector*))))
63
-
64
- (defun shen.<signature> (V633) (let Result (if (and (cons? (hd V633)) (= { (hd (hd V633)))) (let Parse_shen.<signature-help> (shen.<signature-help> (shen.pair (tl (hd V633)) (shen.hdtl V633))) (if (not (= (fail) Parse_shen.<signature-help>)) (if (and (cons? (hd Parse_shen.<signature-help>)) (= } (hd (hd Parse_shen.<signature-help>)))) (shen.pair (hd (shen.pair (tl (hd Parse_shen.<signature-help>)) (shen.hdtl Parse_shen.<signature-help>))) (shen.demodulate (shen.curry-type (shen.hdtl Parse_shen.<signature-help>)))) (fail)) (fail))) (fail)) (if (= Result (fail)) (fail) Result)))
65
-
66
- (defun shen.curry-type (V634) (cond ((and (cons? V634) (and (cons? (tl V634)) (and (= --> (hd (tl V634))) (and (cons? (tl (tl V634))) (and (cons? (tl (tl (tl V634)))) (= --> (hd (tl (tl (tl V634)))))))))) (shen.curry-type (cons (hd V634) (cons --> (cons (tl (tl V634)) ()))))) ((and (cons? V634) (and (cons? (tl V634)) (and (= * (hd (tl V634))) (and (cons? (tl (tl V634))) (and (cons? (tl (tl (tl V634)))) (= * (hd (tl (tl (tl V634)))))))))) (shen.curry-type (cons (hd V634) (cons * (cons (tl (tl V634)) ()))))) ((cons? V634) (map (lambda X609 (shen.curry-type X609)) V634)) (true V634)))
67
-
68
- (defun shen.<signature-help> (V639) (let Result (if (cons? (hd V639)) (let Parse_X (hd (hd V639)) (let Parse_shen.<signature-help> (shen.<signature-help> (shen.pair (tl (hd V639)) (shen.hdtl V639))) (if (not (= (fail) Parse_shen.<signature-help>)) (if (not (element? Parse_X (cons { (cons } ())))) (shen.pair (hd Parse_shen.<signature-help>) (cons Parse_X (shen.hdtl Parse_shen.<signature-help>))) (fail)) (fail)))) (fail)) (if (= Result (fail)) (let Result (let Parse_<e> (<e> V639) (if (not (= (fail) Parse_<e>)) (shen.pair (hd Parse_<e>) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result)))
69
-
70
- (defun shen.<rules> (V644) (let Result (let Parse_shen.<rule> (shen.<rule> V644) (if (not (= (fail) Parse_shen.<rule>)) (let Parse_shen.<rules> (shen.<rules> Parse_shen.<rule>) (if (not (= (fail) Parse_shen.<rules>)) (shen.pair (hd Parse_shen.<rules>) (cons (shen.linearise (shen.hdtl Parse_shen.<rule>)) (shen.hdtl Parse_shen.<rules>))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<rule> (shen.<rule> V644) (if (not (= (fail) Parse_shen.<rule>)) (shen.pair (hd Parse_shen.<rule>) (cons (shen.linearise (shen.hdtl Parse_shen.<rule>)) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result)))
71
-
72
- (defun shen.<rule> (V649) (let Result (let Parse_shen.<patterns> (shen.<patterns> V649) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= -> (hd (hd Parse_shen.<patterns>)))) (let Parse_shen.<action> (shen.<action> (shen.pair (tl (hd Parse_shen.<patterns>)) (shen.hdtl Parse_shen.<patterns>))) (if (not (= (fail) Parse_shen.<action>)) (if (and (cons? (hd Parse_shen.<action>)) (= where (hd (hd Parse_shen.<action>)))) (let Parse_shen.<guard> (shen.<guard> (shen.pair (tl (hd Parse_shen.<action>)) (shen.hdtl Parse_shen.<action>))) (if (not (= (fail) Parse_shen.<guard>)) (shen.pair (hd Parse_shen.<guard>) (cons (shen.hdtl Parse_shen.<patterns>) (cons (cons where (cons (shen.hdtl Parse_shen.<guard>) (cons (shen.hdtl Parse_shen.<action>) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<patterns> (shen.<patterns> V649) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= -> (hd (hd Parse_shen.<patterns>)))) (let Parse_shen.<action> (shen.<action> (shen.pair (tl (hd Parse_shen.<patterns>)) (shen.hdtl Parse_shen.<patterns>))) (if (not (= (fail) Parse_shen.<action>)) (shen.pair (hd Parse_shen.<action>) (cons (shen.hdtl Parse_shen.<patterns>) (cons (shen.hdtl Parse_shen.<action>) ()))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<patterns> (shen.<patterns> V649) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= <- (hd (hd Parse_shen.<patterns>)))) (let Parse_shen.<action> (shen.<action> (shen.pair (tl (hd Parse_shen.<patterns>)) (shen.hdtl Parse_shen.<patterns>))) (if (not (= (fail) Parse_shen.<action>)) (if (and (cons? (hd Parse_shen.<action>)) (= where (hd (hd Parse_shen.<action>)))) (let Parse_shen.<guard> (shen.<guard> (shen.pair (tl (hd Parse_shen.<action>)) (shen.hdtl Parse_shen.<action>))) (if (not (= (fail) Parse_shen.<guard>)) (shen.pair (hd Parse_shen.<guard>) (cons (shen.hdtl Parse_shen.<patterns>) (cons (cons where (cons (shen.hdtl Parse_shen.<guard>) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.<action>) ())) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<patterns> (shen.<patterns> V649) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= <- (hd (hd Parse_shen.<patterns>)))) (let Parse_shen.<action> (shen.<action> (shen.pair (tl (hd Parse_shen.<patterns>)) (shen.hdtl Parse_shen.<patterns>))) (if (not (= (fail) Parse_shen.<action>)) (shen.pair (hd Parse_shen.<action>) (cons (shen.hdtl Parse_shen.<patterns>) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.<action>) ())) ()))) (fail))) (fail)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)))
73
-
74
- (defun shen.fail_if (V650 V651) (if (V650 V651) (fail) V651))
75
-
76
- (defun shen.succeeds? (V656) (cond ((= V656 (fail)) false) (true true)))
77
-
78
- (defun shen.<patterns> (V661) (let Result (let Parse_shen.<pattern> (shen.<pattern> V661) (if (not (= (fail) Parse_shen.<pattern>)) (let Parse_shen.<patterns> (shen.<patterns> Parse_shen.<pattern>) (if (not (= (fail) Parse_shen.<patterns>)) (shen.pair (hd Parse_shen.<patterns>) (cons (shen.hdtl Parse_shen.<pattern>) (shen.hdtl Parse_shen.<patterns>))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_<e> (<e> V661) (if (not (= (fail) Parse_<e>)) (shen.pair (hd Parse_<e>) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result)))
79
-
80
- (defun shen.<pattern> (V666) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= @p (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (let Parse_shen.<pattern1> (shen.<pattern1> (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd Parse_shen.<pattern2>) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons @p (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= cons (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (let Parse_shen.<pattern1> (shen.<pattern1> (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd Parse_shen.<pattern2>) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons cons (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= @v (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (let Parse_shen.<pattern1> (shen.<pattern1> (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd Parse_shen.<pattern2>) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons @v (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= @s (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (let Parse_shen.<pattern1> (shen.<pattern1> (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd Parse_shen.<pattern2>) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons @s (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= vector (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (if (and (cons? (hd (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (= 0 (hd (hd (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666)))))))) (shen.pair (hd (shen.pair (tl (hd (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (shen.hdtl (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))))) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons vector (cons 0 ())))) (fail)) (fail))) (fail)) (if (= Result (fail)) (let Result (if (cons? (hd V666)) (let Parse_X (hd (hd V666)) (if (cons? Parse_X) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (shen.constructor-error Parse_X)) (fail))) (fail)) (if (= Result (fail)) (let Result (let Parse_shen.<simple_pattern> (shen.<simple_pattern> V666) (if (not (= (fail) Parse_shen.<simple_pattern>)) (shen.pair (hd Parse_shen.<simple_pattern>) (shen.hdtl Parse_shen.<simple_pattern>)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)) Result)) Result)) Result)))
81
-
82
- (defun shen.constructor-error (V667) (simple-error (shen.app V667 " is not a legitimate constructor
83
- " shen.a)))
84
-
85
- (defun shen.<simple_pattern> (V672) (let Result (if (cons? (hd V672)) (let Parse_X (hd (hd V672)) (if (= Parse_X _) (shen.pair (hd (shen.pair (tl (hd V672)) (shen.hdtl V672))) (gensym Parse_Y)) (fail))) (fail)) (if (= Result (fail)) (let Result (if (cons? (hd V672)) (let Parse_X (hd (hd V672)) (if (not (element? Parse_X (cons -> (cons <- ())))) (shen.pair (hd (shen.pair (tl (hd V672)) (shen.hdtl V672))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result)) Result)))
86
-
87
- (defun shen.<pattern1> (V677) (let Result (let Parse_shen.<pattern> (shen.<pattern> V677) (if (not (= (fail) Parse_shen.<pattern>)) (shen.pair (hd Parse_shen.<pattern>) (shen.hdtl Parse_shen.<pattern>)) (fail))) (if (= Result (fail)) (fail) Result)))
88
-
89
- (defun shen.<pattern2> (V682) (let Result (let Parse_shen.<pattern> (shen.<pattern> V682) (if (not (= (fail) Parse_shen.<pattern>)) (shen.pair (hd Parse_shen.<pattern>) (shen.hdtl Parse_shen.<pattern>)) (fail))) (if (= Result (fail)) (fail) Result)))
90
-
91
- (defun shen.<action> (V687) (let Result (if (cons? (hd V687)) (let Parse_X (hd (hd V687)) (shen.pair (hd (shen.pair (tl (hd V687)) (shen.hdtl V687))) Parse_X)) (fail)) (if (= Result (fail)) (fail) Result)))
92
-
93
- (defun shen.<guard> (V692) (let Result (if (cons? (hd V692)) (let Parse_X (hd (hd V692)) (shen.pair (hd (shen.pair (tl (hd V692)) (shen.hdtl V692))) Parse_X)) (fail)) (if (= Result (fail)) (fail) Result)))
94
-
95
- (defun shen.compile_to_machine_code (V693 V694) (let Lambda+ (shen.compile_to_lambda+ V693 V694) (let KL (shen.compile_to_kl V693 Lambda+) (let Record (shen.record-source V693 KL) KL))))
96
-
97
- (defun shen.record-source (V697 V698) (cond ((value shen.*installing-kl*) shen.skip) (true (put V697 shen.source V698 (value *property-vector*)))))
98
-
99
- (defun shen.compile_to_lambda+ (V699 V700) (let Arity (shen.aritycheck V699 V700) (let Free (map (lambda Rule (shen.free_variable_check V699 Rule)) V700) (let Variables (shen.parameters Arity) (let Strip (map (lambda X610 (shen.strip-protect X610)) V700) (let Abstractions (map (lambda X611 (shen.abstract_rule X611)) Strip) (let Applications (map (lambda X (shen.application_build Variables X)) Abstractions) (cons Variables (cons Applications ())))))))))
100
-
101
- (defun shen.free_variable_check (V701 V702) (cond ((and (cons? V702) (and (cons? (tl V702)) (= () (tl (tl V702))))) (let Bound (shen.extract_vars (hd V702)) (let Free (shen.extract_free_vars Bound (hd (tl V702))) (shen.free_variable_warnings V701 Free)))) (true (shen.sys-error shen.free_variable_check))))
102
-
103
- (defun shen.extract_vars (V703) (cond ((variable? V703) (cons V703 ())) ((cons? V703) (union (shen.extract_vars (hd V703)) (shen.extract_vars (tl V703)))) (true ())))
104
-
105
- (defun shen.extract_free_vars (V713 V714) (cond ((and (cons? V714) (and (cons? (tl V714)) (and (= () (tl (tl V714))) (= (hd V714) protect)))) ()) ((and (variable? V714) (not (element? V714 V713))) (cons V714 ())) ((and (cons? V714) (and (= lambda (hd V714)) (and (cons? (tl V714)) (and (cons? (tl (tl V714))) (= () (tl (tl (tl V714)))))))) (shen.extract_free_vars (cons (hd (tl V714)) V713) (hd (tl (tl V714))))) ((and (cons? V714) (and (= let (hd V714)) (and (cons? (tl V714)) (and (cons? (tl (tl V714))) (and (cons? (tl (tl (tl V714)))) (= () (tl (tl (tl (tl V714)))))))))) (union (shen.extract_free_vars V713 (hd (tl (tl V714)))) (shen.extract_free_vars (cons (hd (tl V714)) V713) (hd (tl (tl (tl V714))))))) ((cons? V714) (union (shen.extract_free_vars V713 (hd V714)) (shen.extract_free_vars V713 (tl V714)))) (true ())))
106
-
107
- (defun shen.free_variable_warnings (V717 V718) (cond ((= () V718) _) (true (simple-error (cn "error: the following variables are free in " (shen.app V717 (cn ": " (shen.app (shen.list_variables V718) "" shen.a)) shen.a))))))
108
-
109
- (defun shen.list_variables (V719) (cond ((and (cons? V719) (= () (tl V719))) (cn (str (hd V719)) ".")) ((cons? V719) (cn (str (hd V719)) (cn ", " (shen.list_variables (tl V719))))) (true (shen.sys-error shen.list_variables))))
110
-
111
- (defun shen.strip-protect (V720) (cond ((and (cons? V720) (and (cons? (tl V720)) (and (= () (tl (tl V720))) (= (hd V720) protect)))) (hd (tl V720))) ((cons? V720) (cons (shen.strip-protect (hd V720)) (shen.strip-protect (tl V720)))) (true V720)))
112
-
113
- (defun shen.linearise (V721) (cond ((and (cons? V721) (and (cons? (tl V721)) (= () (tl (tl V721))))) (shen.linearise_help (shen.flatten (hd V721)) (hd V721) (hd (tl V721)))) (true (shen.sys-error shen.linearise))))
114
-
115
- (defun shen.flatten (V722) (cond ((= () V722) ()) ((cons? V722) (append (shen.flatten (hd V722)) (shen.flatten (tl V722)))) (true (cons V722 ()))))
116
-
117
- (defun shen.linearise_help (V723 V724 V725) (cond ((= () V723) (cons V724 (cons V725 ()))) ((cons? V723) (if (and (variable? (hd V723)) (element? (hd V723) (tl V723))) (let Var (gensym (hd V723)) (let NewAction (cons where (cons (cons = (cons (hd V723) (cons Var ()))) (cons V725 ()))) (let NewPatts (shen.linearise_X (hd V723) Var V724) (shen.linearise_help (tl V723) NewPatts NewAction)))) (shen.linearise_help (tl V723) V724 V725))) (true (shen.sys-error shen.linearise_help))))
118
-
119
- (defun shen.linearise_X (V734 V735 V736) (cond ((= V736 V734) V735) ((cons? V736) (let L (shen.linearise_X V734 V735 (hd V736)) (if (= L (hd V736)) (cons (hd V736) (shen.linearise_X V734 V735 (tl V736))) (cons L (tl V736))))) (true V736)))
120
-
121
- (defun shen.aritycheck (V738 V739) (cond ((and (cons? V739) (and (cons? (hd V739)) (and (cons? (tl (hd V739))) (and (= () (tl (tl (hd V739)))) (= () (tl V739)))))) (do (shen.aritycheck-action (hd (tl (hd V739)))) (shen.aritycheck-name V738 (arity V738) (length (hd (hd V739)))))) ((and (cons? V739) (and (cons? (hd V739)) (and (cons? (tl (hd V739))) (and (= () (tl (tl (hd V739)))) (and (cons? (tl V739)) (and (cons? (hd (tl V739))) (and (cons? (tl (hd (tl V739)))) (= () (tl (tl (hd (tl V739)))))))))))) (if (= (length (hd (hd V739))) (length (hd (hd (tl V739))))) (do (shen.aritycheck-action (hd (tl (hd V739)))) (shen.aritycheck V738 (tl V739))) (simple-error (cn "arity error in " (shen.app V738 "
122
- " shen.a))))) (true (shen.sys-error shen.aritycheck))))
123
-
124
- (defun shen.aritycheck-name (V748 V749 V750) (cond ((= -1 V749) V750) ((= V750 V749) V750) (true (do (shen.prhush (cn "
125
- warning: changing the arity of " (shen.app V748 " can cause errors.
126
- " shen.a)) (stoutput)) V750))))
127
-
128
- (defun shen.aritycheck-action (V756) (cond ((cons? V756) (do (shen.aah (hd V756) (tl V756)) (map (lambda X612 (shen.aritycheck-action X612)) V756))) (true shen.skip)))
129
-
130
- (defun shen.aah (V757 V758) (let Arity (arity V757) (let Len (length V758) (if (and (> Arity -1) (> Len Arity)) (shen.prhush (cn "warning: " (shen.app V757 (cn " might not like " (shen.app Len (cn " argument" (shen.app (if (> Len 1) "s" "") ".
131
- " shen.a)) shen.a)) shen.a)) (stoutput)) shen.skip))))
132
-
133
- (defun shen.abstract_rule (V759) (cond ((and (cons? V759) (and (cons? (tl V759)) (= () (tl (tl V759))))) (shen.abstraction_build (hd V759) (hd (tl V759)))) (true (shen.sys-error shen.abstract_rule))))
134
-
135
- (defun shen.abstraction_build (V760 V761) (cond ((= () V760) V761) ((cons? V760) (cons /. (cons (hd V760) (cons (shen.abstraction_build (tl V760) V761) ())))) (true (shen.sys-error shen.abstraction_build))))
136
-
137
- (defun shen.parameters (V762) (cond ((= 0 V762) ()) (true (cons (gensym V) (shen.parameters (- V762 1))))))
138
-
139
- (defun shen.application_build (V763 V764) (cond ((= () V763) V764) ((cons? V763) (shen.application_build (tl V763) (cons V764 (cons (hd V763) ())))) (true (shen.sys-error shen.application_build))))
140
-
141
- (defun shen.compile_to_kl (V765 V766) (cond ((and (cons? V766) (and (cons? (tl V766)) (= () (tl (tl V766))))) (let Arity (shen.store-arity V765 (length (hd V766))) (let Reduce (map (lambda X613 (shen.reduce X613)) (hd (tl V766))) (let CondExpression (shen.cond-expression V765 (hd V766) Reduce) (let TypeTable (if (value shen.*optimise*) (shen.typextable (shen.get-type V765) (hd V766)) shen.skip) (let TypedCondExpression (if (value shen.*optimise*) (shen.assign-types (hd V766) TypeTable CondExpression) CondExpression) (let KL (cons defun (cons V765 (cons (hd V766) (cons TypedCondExpression ())))) KL))))))) (true (shen.sys-error shen.compile_to_kl))))
142
-
143
- (defun shen.get-type (V771) (cond ((cons? V771) shen.skip) (true (let FType (assoc V771 (value shen.*signedfuncs*)) (if (empty? FType) shen.skip (tl FType))))))
144
-
145
- (defun shen.typextable (V780 V781) (cond ((and (cons? V780) (and (cons? (tl V780)) (and (= --> (hd (tl V780))) (and (cons? (tl (tl V780))) (and (= () (tl (tl (tl V780)))) (cons? V781)))))) (if (variable? (hd V780)) (shen.typextable (hd (tl (tl V780))) (tl V781)) (cons (cons (hd V781) (hd V780)) (shen.typextable (hd (tl (tl V780))) (tl V781))))) (true ())))
146
-
147
- (defun shen.assign-types (V782 V783 V784) (cond ((and (cons? V784) (and (= let (hd V784)) (and (cons? (tl V784)) (and (cons? (tl (tl V784))) (and (cons? (tl (tl (tl V784)))) (= () (tl (tl (tl (tl V784)))))))))) (cons let (cons (hd (tl V784)) (cons (shen.assign-types V782 V783 (hd (tl (tl V784)))) (cons (shen.assign-types (cons (hd (tl V784)) V782) V783 (hd (tl (tl (tl V784))))) ()))))) ((and (cons? V784) (and (= lambda (hd V784)) (and (cons? (tl V784)) (and (cons? (tl (tl V784))) (= () (tl (tl (tl V784)))))))) (cons lambda (cons (hd (tl V784)) (cons (shen.assign-types (cons (hd (tl V784)) V782) V783 (hd (tl (tl V784)))) ())))) ((and (cons? V784) (= cond (hd V784))) (cons cond (map (lambda Y (cons (shen.assign-types V782 V783 (hd Y)) (cons (shen.assign-types V782 V783 (hd (tl Y))) ()))) (tl V784)))) ((cons? V784) (let NewTable (shen.typextable (shen.get-type (hd V784)) (tl V784)) (cons (hd V784) (map (lambda Y (shen.assign-types V782 (append V783 NewTable) Y)) (tl V784))))) (true (let AtomType (assoc V784 V783) (if (cons? AtomType) (cons type (cons V784 (cons (tl AtomType) ()))) (if (element? V784 V782) V784 (shen.atom-type V784)))))))
148
-
149
- (defun shen.atom-type (V785) (if (string? V785) (cons type (cons V785 (cons string ()))) (if (number? V785) (cons type (cons V785 (cons number ()))) (if (boolean? V785) (cons type (cons V785 (cons boolean ()))) (if (symbol? V785) (cons type (cons V785 (cons symbol ()))) V785)))))
150
-
151
- (defun shen.store-arity (V788 V789) (cond ((value shen.*installing-kl*) shen.skip) (true (put V788 arity V789 (value *property-vector*)))))
152
-
153
- (defun shen.reduce (V790) (do (set shen.*teststack* ()) (let Result (shen.reduce_help V790) (cons (cons : (cons shen.tests (reverse (value shen.*teststack*)))) (cons Result ())))))
154
-
155
- (defun shen.reduce_help (V791) (cond ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (hd (tl (hd V791)))) (and (= cons (hd (hd (tl (hd V791))))) (and (cons? (tl (hd (tl (hd V791))))) (and (cons? (tl (tl (hd (tl (hd V791)))))) (and (= () (tl (tl (tl (hd (tl (hd V791))))))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791))))))))))))))) (do (shen.add_test (cons cons? (tl V791))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V791))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V791)))))) (cons (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hd (tl V791)) ())) (cons (cons tl (tl V791)) ())) (shen.reduce_help Application))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (hd (tl (hd V791)))) (and (= @p (hd (hd (tl (hd V791))))) (and (cons? (tl (hd (tl (hd V791))))) (and (cons? (tl (tl (hd (tl (hd V791)))))) (and (= () (tl (tl (tl (hd (tl (hd V791))))))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791))))))))))))))) (do (shen.add_test (cons tuple? (tl V791))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V791))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V791)))))) (cons (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons fst (tl V791)) ())) (cons (cons snd (tl V791)) ())) (shen.reduce_help Application))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (hd (tl (hd V791)))) (and (= @v (hd (hd (tl (hd V791))))) (and (cons? (tl (hd (tl (hd V791))))) (and (cons? (tl (tl (hd (tl (hd V791)))))) (and (= () (tl (tl (tl (hd (tl (hd V791))))))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791))))))))))))))) (do (shen.add_test (cons shen.+vector? (tl V791))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V791))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V791)))))) (cons (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hdv (tl V791)) ())) (cons (cons tlv (tl V791)) ())) (shen.reduce_help Application))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (hd (tl (hd V791)))) (and (= @s (hd (hd (tl (hd V791))))) (and (cons? (tl (hd (tl (hd V791))))) (and (cons? (tl (tl (hd (tl (hd V791)))))) (and (= () (tl (tl (tl (hd (tl (hd V791))))))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791))))))))))))))) (do (shen.add_test (cons shen.+string? (tl V791))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V791))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V791)))))) (cons (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons pos (cons (hd (tl V791)) (cons 0 ()))) ())) (cons (cons tlstr (tl V791)) ())) (shen.reduce_help Application))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (and (= () (tl (tl V791))) (not (variable? (hd (tl (hd V791))))))))))))) (do (shen.add_test (cons = (cons (hd (tl (hd V791))) (tl V791)))) (shen.reduce_help (hd (tl (tl (hd V791))))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791)))))))))) (shen.reduce_help (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))))) ((and (cons? V791) (and (= where (hd V791)) (and (cons? (tl V791)) (and (cons? (tl (tl V791))) (= () (tl (tl (tl V791)))))))) (do (shen.add_test (hd (tl V791))) (shen.reduce_help (hd (tl (tl V791)))))) ((and (cons? V791) (and (cons? (tl V791)) (= () (tl (tl V791))))) (let Z (shen.reduce_help (hd V791)) (if (= (hd V791) Z) V791 (shen.reduce_help (cons Z (tl V791)))))) (true V791)))
156
-
157
- (defun shen.+string? (V792) (cond ((= "" V792) false) (true (string? V792))))
158
-
159
- (defun shen.+vector (V793) (cond ((= V793 (vector 0)) false) (true (vector? V793))))
160
-
161
- (defun shen.ebr (V802 V803 V804) (cond ((= V804 V803) V802) ((and (cons? V804) (and (= /. (hd V804)) (and (cons? (tl V804)) (and (cons? (tl (tl V804))) (and (= () (tl (tl (tl V804)))) (> (occurrences V803 (hd (tl V804))) 0)))))) V804) ((and (cons? V804) (and (= let (hd V804)) (and (cons? (tl V804)) (and (cons? (tl (tl V804))) (and (cons? (tl (tl (tl V804)))) (and (= () (tl (tl (tl (tl V804))))) (= (hd (tl V804)) V803))))))) (cons let (cons (hd (tl V804)) (cons (shen.ebr V802 (hd (tl V804)) (hd (tl (tl V804)))) (tl (tl (tl V804))))))) ((cons? V804) (cons (shen.ebr V802 V803 (hd V804)) (shen.ebr V802 V803 (tl V804)))) (true V804)))
162
-
163
- (defun shen.add_test (V807) (set shen.*teststack* (cons V807 (value shen.*teststack*))))
164
-
165
- (defun shen.cond-expression (V808 V809 V810) (let Err (shen.err-condition V808) (let Cases (shen.case-form V810 Err) (let EncodeChoices (shen.encode-choices Cases V808) (shen.cond-form EncodeChoices)))))
166
-
167
- (defun shen.cond-form (V813) (cond ((and (cons? V813) (and (cons? (hd V813)) (and (= true (hd (hd V813))) (and (cons? (tl (hd V813))) (= () (tl (tl (hd V813)))))))) (hd (tl (hd V813)))) (true (cons cond V813))))
168
-
169
- (defun shen.encode-choices (V816 V817) (cond ((= () V816) ()) ((and (cons? V816) (and (cons? (hd V816)) (and (= true (hd (hd V816))) (and (cons? (tl (hd V816))) (and (cons? (hd (tl (hd V816)))) (and (= shen.choicepoint! (hd (hd (tl (hd V816))))) (and (cons? (tl (hd (tl (hd V816))))) (and (= () (tl (tl (hd (tl (hd V816)))))) (and (= () (tl (tl (hd V816)))) (= () (tl V816))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V816))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (if (value shen.*installing-kl*) (cons shen.sys-error (cons V817 ())) (cons shen.f_error (cons V817 ()))) (cons Result ())))) ())))) ())) ())) ((and (cons? V816) (and (cons? (hd V816)) (and (= true (hd (hd V816))) (and (cons? (tl (hd V816))) (and (cons? (hd (tl (hd V816)))) (and (= shen.choicepoint! (hd (hd (tl (hd V816))))) (and (cons? (tl (hd (tl (hd V816))))) (and (= () (tl (tl (hd (tl (hd V816)))))) (= () (tl (tl (hd V816)))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V816))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (shen.cond-form (shen.encode-choices (tl V816) V817)) (cons Result ())))) ())))) ())) ())) ((and (cons? V816) (and (cons? (hd V816)) (and (cons? (tl (hd V816))) (and (cons? (hd (tl (hd V816)))) (and (= shen.choicepoint! (hd (hd (tl (hd V816))))) (and (cons? (tl (hd (tl (hd V816))))) (and (= () (tl (tl (hd (tl (hd V816)))))) (= () (tl (tl (hd V816))))))))))) (cons (cons true (cons (cons let (cons Freeze (cons (cons freeze (cons (shen.cond-form (shen.encode-choices (tl V816) V817)) ())) (cons (cons if (cons (hd (hd V816)) (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V816))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (cons thaw (cons Freeze ())) (cons Result ())))) ())))) (cons (cons thaw (cons Freeze ())) ())))) ())))) ())) ())) ((and (cons? V816) (and (cons? (hd V816)) (and (cons? (tl (hd V816))) (= () (tl (tl (hd V816))))))) (cons (hd V816) (shen.encode-choices (tl V816) V817))) (true (shen.sys-error shen.encode-choices))))
170
-
171
- (defun shen.case-form (V822 V823) (cond ((= () V822) (cons V823 ())) ((and (cons? V822) (and (cons? (hd V822)) (and (cons? (hd (hd V822))) (and (= : (hd (hd (hd V822)))) (and (cons? (tl (hd (hd V822)))) (and (= shen.tests (hd (tl (hd (hd V822))))) (and (= () (tl (tl (hd (hd V822))))) (and (cons? (tl (hd V822))) (and (cons? (hd (tl (hd V822)))) (and (= shen.choicepoint! (hd (hd (tl (hd V822))))) (and (cons? (tl (hd (tl (hd V822))))) (and (= () (tl (tl (hd (tl (hd V822)))))) (= () (tl (tl (hd V822)))))))))))))))) (cons (cons true (tl (hd V822))) (shen.case-form (tl V822) V823))) ((and (cons? V822) (and (cons? (hd V822)) (and (cons? (hd (hd V822))) (and (= : (hd (hd (hd V822)))) (and (cons? (tl (hd (hd V822)))) (and (= shen.tests (hd (tl (hd (hd V822))))) (and (= () (tl (tl (hd (hd V822))))) (and (cons? (tl (hd V822))) (= () (tl (tl (hd V822)))))))))))) (cons (cons true (tl (hd V822))) ())) ((and (cons? V822) (and (cons? (hd V822)) (and (cons? (hd (hd V822))) (and (= : (hd (hd (hd V822)))) (and (cons? (tl (hd (hd V822)))) (and (= shen.tests (hd (tl (hd (hd V822))))) (and (cons? (tl (hd V822))) (= () (tl (tl (hd V822))))))))))) (cons (cons (shen.embed-and (tl (tl (hd (hd V822))))) (tl (hd V822))) (shen.case-form (tl V822) V823))) (true (shen.sys-error shen.case-form))))
172
-
173
- (defun shen.embed-and (V824) (cond ((and (cons? V824) (= () (tl V824))) (hd V824)) ((cons? V824) (cons and (cons (hd V824) (cons (shen.embed-and (tl V824)) ())))) (true (shen.sys-error shen.embed-and))))
174
-
175
- (defun shen.err-condition (V825) (cons true (cons (cons shen.f_error (cons V825 ())) ())))
176
-
177
- (defun shen.sys-error (V826) (simple-error (cn "system function " (shen.app V826 ": unexpected argument
178
- " shen.a))))
179
-
180
-
181
-
1
+ "**********************************************************************************
2
+ * The License *
3
+ * *
4
+ * The user is free to produce commercial applications with the software, to *
5
+ * distribute these applications in source or binary form, and to charge monies *
6
+ * for them as he sees fit and in concordance with the laws of the land subject *
7
+ * to the following license. *
8
+ * *
9
+ * 1. The license applies to all the software and all derived software and *
10
+ * must appear on such. *
11
+ * *
12
+ * 2. It is illegal to distribute the software without this license attached *
13
+ * to it and use of the software implies agreement with the license as such. *
14
+ * It is illegal for anyone who is not the copyright holder to tamper with *
15
+ * or change the license. *
16
+ * *
17
+ * 3. Neither the names of Lambda Associates or the copyright holder may be used *
18
+ * to endorse or promote products built using the software without specific *
19
+ * prior written permission from the copyright holder. *
20
+ * *
21
+ * 4. That possession of this license does not confer on the copyright holder *
22
+ * any special contractual obligation towards the user. That in no event *
23
+ * shall the copyright holder be liable for any direct, indirect, incidental, *
24
+ * special, exemplary or consequential damages (including but not limited *
25
+ * to procurement of substitute goods or services, loss of use, data, *
26
+ * interruption), however caused and on any theory of liability, whether in *
27
+ * contract, strict liability or tort (including negligence) arising in any *
28
+ * way out of the use of the software, even if advised of the possibility of *
29
+ * such damage. *
30
+ * *
31
+ * 5. It is permitted for the user to change the software, for the purpose of *
32
+ * improving performance, correcting an error, or porting to a new platform, *
33
+ * and distribute the derived version of Shen provided the resulting program *
34
+ * conforms in all respects to the Shen standard and is issued under that *
35
+ * title. The user must make it clear with his distribution that he/she is *
36
+ * the author of the changes and what these changes are and why. *
37
+ * *
38
+ * 6. Derived versions of this software in whatever form are subject to the same *
39
+ * restrictions. In particular it is not permitted to make derived copies of *
40
+ * this software which do not conform to the Shen standard or appear under a *
41
+ * different title. *
42
+ * *
43
+ * It is permitted to distribute versions of Shen which incorporate libraries, *
44
+ * graphics or other facilities which are not part of the Shen standard. *
45
+ * *
46
+ * For an explication of this license see www.shenlanguage.org/license.htm which *
47
+ * explains this license in full. *
48
+ * *
49
+ *****************************************************************************************
50
+ "(defun shen.shen->kl (V614 V615) (compile (lambda X608 (shen.<define> X608)) (cons V614 V615) (lambda X (shen.shen-syntax-error V614 X))))
51
+
52
+ (defun shen.shen-syntax-error (V616 V617) (simple-error (cn "syntax error in " (shen.app V616 (cn " here:
53
+
54
+ " (shen.app (shen.next-50 50 V617) "
55
+ " shen.a)) shen.a))))
56
+
57
+ (defun shen.<define> (V622) (let Result (let Parse_shen.<name> (shen.<name> V622) (if (not (= (fail) Parse_shen.<name>)) (let Parse_shen.<signature> (shen.<signature> Parse_shen.<name>) (if (not (= (fail) Parse_shen.<signature>)) (let Parse_shen.<rules> (shen.<rules> Parse_shen.<signature>) (if (not (= (fail) Parse_shen.<rules>)) (shen.pair (hd Parse_shen.<rules>) (shen.compile_to_machine_code (shen.hdtl Parse_shen.<name>) (shen.hdtl Parse_shen.<rules>))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<name> (shen.<name> V622) (if (not (= (fail) Parse_shen.<name>)) (let Parse_shen.<rules> (shen.<rules> Parse_shen.<name>) (if (not (= (fail) Parse_shen.<rules>)) (shen.pair (hd Parse_shen.<rules>) (shen.compile_to_machine_code (shen.hdtl Parse_shen.<name>) (shen.hdtl Parse_shen.<rules>))) (fail))) (fail))) (if (= Result (fail)) (fail) Result)) Result)))
58
+
59
+ (defun shen.<name> (V627) (let Result (if (cons? (hd V627)) (let Parse_X (hd (hd V627)) (shen.pair (hd (shen.pair (tl (hd V627)) (shen.hdtl V627))) (if (and (symbol? Parse_X) (not (shen.sysfunc? Parse_X))) Parse_X (simple-error (shen.app Parse_X " is not a legitimate function name.
60
+ " shen.a))))) (fail)) (if (= Result (fail)) (fail) Result)))
61
+
62
+ (defun shen.sysfunc? (V628) (element? V628 (get (intern "shen") shen.external-symbols (value *property-vector*))))
63
+
64
+ (defun shen.<signature> (V633) (let Result (if (and (cons? (hd V633)) (= { (hd (hd V633)))) (let Parse_shen.<signature-help> (shen.<signature-help> (shen.pair (tl (hd V633)) (shen.hdtl V633))) (if (not (= (fail) Parse_shen.<signature-help>)) (if (and (cons? (hd Parse_shen.<signature-help>)) (= } (hd (hd Parse_shen.<signature-help>)))) (shen.pair (hd (shen.pair (tl (hd Parse_shen.<signature-help>)) (shen.hdtl Parse_shen.<signature-help>))) (shen.demodulate (shen.curry-type (shen.hdtl Parse_shen.<signature-help>)))) (fail)) (fail))) (fail)) (if (= Result (fail)) (fail) Result)))
65
+
66
+ (defun shen.curry-type (V634) (cond ((and (cons? V634) (and (cons? (tl V634)) (and (= --> (hd (tl V634))) (and (cons? (tl (tl V634))) (and (cons? (tl (tl (tl V634)))) (= --> (hd (tl (tl (tl V634)))))))))) (shen.curry-type (cons (hd V634) (cons --> (cons (tl (tl V634)) ()))))) ((and (cons? V634) (and (cons? (tl V634)) (and (= * (hd (tl V634))) (and (cons? (tl (tl V634))) (and (cons? (tl (tl (tl V634)))) (= * (hd (tl (tl (tl V634)))))))))) (shen.curry-type (cons (hd V634) (cons * (cons (tl (tl V634)) ()))))) ((cons? V634) (map (lambda X609 (shen.curry-type X609)) V634)) (true V634)))
67
+
68
+ (defun shen.<signature-help> (V639) (let Result (if (cons? (hd V639)) (let Parse_X (hd (hd V639)) (let Parse_shen.<signature-help> (shen.<signature-help> (shen.pair (tl (hd V639)) (shen.hdtl V639))) (if (not (= (fail) Parse_shen.<signature-help>)) (if (not (element? Parse_X (cons { (cons } ())))) (shen.pair (hd Parse_shen.<signature-help>) (cons Parse_X (shen.hdtl Parse_shen.<signature-help>))) (fail)) (fail)))) (fail)) (if (= Result (fail)) (let Result (let Parse_<e> (<e> V639) (if (not (= (fail) Parse_<e>)) (shen.pair (hd Parse_<e>) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result)))
69
+
70
+ (defun shen.<rules> (V644) (let Result (let Parse_shen.<rule> (shen.<rule> V644) (if (not (= (fail) Parse_shen.<rule>)) (let Parse_shen.<rules> (shen.<rules> Parse_shen.<rule>) (if (not (= (fail) Parse_shen.<rules>)) (shen.pair (hd Parse_shen.<rules>) (cons (shen.linearise (shen.hdtl Parse_shen.<rule>)) (shen.hdtl Parse_shen.<rules>))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<rule> (shen.<rule> V644) (if (not (= (fail) Parse_shen.<rule>)) (shen.pair (hd Parse_shen.<rule>) (cons (shen.linearise (shen.hdtl Parse_shen.<rule>)) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result)))
71
+
72
+ (defun shen.<rule> (V649) (let Result (let Parse_shen.<patterns> (shen.<patterns> V649) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= -> (hd (hd Parse_shen.<patterns>)))) (let Parse_shen.<action> (shen.<action> (shen.pair (tl (hd Parse_shen.<patterns>)) (shen.hdtl Parse_shen.<patterns>))) (if (not (= (fail) Parse_shen.<action>)) (if (and (cons? (hd Parse_shen.<action>)) (= where (hd (hd Parse_shen.<action>)))) (let Parse_shen.<guard> (shen.<guard> (shen.pair (tl (hd Parse_shen.<action>)) (shen.hdtl Parse_shen.<action>))) (if (not (= (fail) Parse_shen.<guard>)) (shen.pair (hd Parse_shen.<guard>) (cons (shen.hdtl Parse_shen.<patterns>) (cons (cons where (cons (shen.hdtl Parse_shen.<guard>) (cons (shen.hdtl Parse_shen.<action>) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<patterns> (shen.<patterns> V649) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= -> (hd (hd Parse_shen.<patterns>)))) (let Parse_shen.<action> (shen.<action> (shen.pair (tl (hd Parse_shen.<patterns>)) (shen.hdtl Parse_shen.<patterns>))) (if (not (= (fail) Parse_shen.<action>)) (shen.pair (hd Parse_shen.<action>) (cons (shen.hdtl Parse_shen.<patterns>) (cons (shen.hdtl Parse_shen.<action>) ()))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<patterns> (shen.<patterns> V649) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= <- (hd (hd Parse_shen.<patterns>)))) (let Parse_shen.<action> (shen.<action> (shen.pair (tl (hd Parse_shen.<patterns>)) (shen.hdtl Parse_shen.<patterns>))) (if (not (= (fail) Parse_shen.<action>)) (if (and (cons? (hd Parse_shen.<action>)) (= where (hd (hd Parse_shen.<action>)))) (let Parse_shen.<guard> (shen.<guard> (shen.pair (tl (hd Parse_shen.<action>)) (shen.hdtl Parse_shen.<action>))) (if (not (= (fail) Parse_shen.<guard>)) (shen.pair (hd Parse_shen.<guard>) (cons (shen.hdtl Parse_shen.<patterns>) (cons (cons where (cons (shen.hdtl Parse_shen.<guard>) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.<action>) ())) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen.<patterns> (shen.<patterns> V649) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= <- (hd (hd Parse_shen.<patterns>)))) (let Parse_shen.<action> (shen.<action> (shen.pair (tl (hd Parse_shen.<patterns>)) (shen.hdtl Parse_shen.<patterns>))) (if (not (= (fail) Parse_shen.<action>)) (shen.pair (hd Parse_shen.<action>) (cons (shen.hdtl Parse_shen.<patterns>) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.<action>) ())) ()))) (fail))) (fail)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)))
73
+
74
+ (defun shen.fail_if (V650 V651) (if (V650 V651) (fail) V651))
75
+
76
+ (defun shen.succeeds? (V656) (cond ((= V656 (fail)) false) (true true)))
77
+
78
+ (defun shen.<patterns> (V661) (let Result (let Parse_shen.<pattern> (shen.<pattern> V661) (if (not (= (fail) Parse_shen.<pattern>)) (let Parse_shen.<patterns> (shen.<patterns> Parse_shen.<pattern>) (if (not (= (fail) Parse_shen.<patterns>)) (shen.pair (hd Parse_shen.<patterns>) (cons (shen.hdtl Parse_shen.<pattern>) (shen.hdtl Parse_shen.<patterns>))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_<e> (<e> V661) (if (not (= (fail) Parse_<e>)) (shen.pair (hd Parse_<e>) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result)))
79
+
80
+ (defun shen.<pattern> (V666) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= @p (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (let Parse_shen.<pattern1> (shen.<pattern1> (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd Parse_shen.<pattern2>) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons @p (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= cons (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (let Parse_shen.<pattern1> (shen.<pattern1> (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd Parse_shen.<pattern2>) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons cons (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= @v (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (let Parse_shen.<pattern1> (shen.<pattern1> (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd Parse_shen.<pattern2>) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons @v (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= @s (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (let Parse_shen.<pattern1> (shen.<pattern1> (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd Parse_shen.<pattern2>) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons @s (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V666)) (cons? (hd (hd V666)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (= vector (hd (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (if (and (cons? (hd (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (= 0 (hd (hd (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666)))))))) (shen.pair (hd (shen.pair (tl (hd (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666)))))) (shen.hdtl (shen.pair (tl (hd (shen.pair (hd (hd V666)) (shen.hdtl V666)))) (shen.hdtl (shen.pair (hd (hd V666)) (shen.hdtl V666))))))) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons vector (cons 0 ())))) (fail)) (fail))) (fail)) (if (= Result (fail)) (let Result (if (cons? (hd V666)) (let Parse_X (hd (hd V666)) (if (cons? Parse_X) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (shen.constructor-error Parse_X)) (fail))) (fail)) (if (= Result (fail)) (let Result (let Parse_shen.<simple_pattern> (shen.<simple_pattern> V666) (if (not (= (fail) Parse_shen.<simple_pattern>)) (shen.pair (hd Parse_shen.<simple_pattern>) (shen.hdtl Parse_shen.<simple_pattern>)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)) Result)) Result)) Result)))
81
+
82
+ (defun shen.constructor-error (V667) (simple-error (shen.app V667 " is not a legitimate constructor
83
+ " shen.a)))
84
+
85
+ (defun shen.<simple_pattern> (V672) (let Result (if (cons? (hd V672)) (let Parse_X (hd (hd V672)) (if (= Parse_X _) (shen.pair (hd (shen.pair (tl (hd V672)) (shen.hdtl V672))) (gensym Parse_Y)) (fail))) (fail)) (if (= Result (fail)) (let Result (if (cons? (hd V672)) (let Parse_X (hd (hd V672)) (if (not (element? Parse_X (cons -> (cons <- ())))) (shen.pair (hd (shen.pair (tl (hd V672)) (shen.hdtl V672))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result)) Result)))
86
+
87
+ (defun shen.<pattern1> (V677) (let Result (let Parse_shen.<pattern> (shen.<pattern> V677) (if (not (= (fail) Parse_shen.<pattern>)) (shen.pair (hd Parse_shen.<pattern>) (shen.hdtl Parse_shen.<pattern>)) (fail))) (if (= Result (fail)) (fail) Result)))
88
+
89
+ (defun shen.<pattern2> (V682) (let Result (let Parse_shen.<pattern> (shen.<pattern> V682) (if (not (= (fail) Parse_shen.<pattern>)) (shen.pair (hd Parse_shen.<pattern>) (shen.hdtl Parse_shen.<pattern>)) (fail))) (if (= Result (fail)) (fail) Result)))
90
+
91
+ (defun shen.<action> (V687) (let Result (if (cons? (hd V687)) (let Parse_X (hd (hd V687)) (shen.pair (hd (shen.pair (tl (hd V687)) (shen.hdtl V687))) Parse_X)) (fail)) (if (= Result (fail)) (fail) Result)))
92
+
93
+ (defun shen.<guard> (V692) (let Result (if (cons? (hd V692)) (let Parse_X (hd (hd V692)) (shen.pair (hd (shen.pair (tl (hd V692)) (shen.hdtl V692))) Parse_X)) (fail)) (if (= Result (fail)) (fail) Result)))
94
+
95
+ (defun shen.compile_to_machine_code (V693 V694) (let Lambda+ (shen.compile_to_lambda+ V693 V694) (let KL (shen.compile_to_kl V693 Lambda+) (let Record (shen.record-source V693 KL) KL))))
96
+
97
+ (defun shen.record-source (V697 V698) (cond ((value shen.*installing-kl*) shen.skip) (true (put V697 shen.source V698 (value *property-vector*)))))
98
+
99
+ (defun shen.compile_to_lambda+ (V699 V700) (let Arity (shen.aritycheck V699 V700) (let Free (map (lambda Rule (shen.free_variable_check V699 Rule)) V700) (let Variables (shen.parameters Arity) (let Strip (map (lambda X610 (shen.strip-protect X610)) V700) (let Abstractions (map (lambda X611 (shen.abstract_rule X611)) Strip) (let Applications (map (lambda X (shen.application_build Variables X)) Abstractions) (cons Variables (cons Applications ())))))))))
100
+
101
+ (defun shen.free_variable_check (V701 V702) (cond ((and (cons? V702) (and (cons? (tl V702)) (= () (tl (tl V702))))) (let Bound (shen.extract_vars (hd V702)) (let Free (shen.extract_free_vars Bound (hd (tl V702))) (shen.free_variable_warnings V701 Free)))) (true (shen.sys-error shen.free_variable_check))))
102
+
103
+ (defun shen.extract_vars (V703) (cond ((variable? V703) (cons V703 ())) ((cons? V703) (union (shen.extract_vars (hd V703)) (shen.extract_vars (tl V703)))) (true ())))
104
+
105
+ (defun shen.extract_free_vars (V713 V714) (cond ((and (cons? V714) (and (cons? (tl V714)) (and (= () (tl (tl V714))) (= (hd V714) protect)))) ()) ((and (variable? V714) (not (element? V714 V713))) (cons V714 ())) ((and (cons? V714) (and (= lambda (hd V714)) (and (cons? (tl V714)) (and (cons? (tl (tl V714))) (= () (tl (tl (tl V714)))))))) (shen.extract_free_vars (cons (hd (tl V714)) V713) (hd (tl (tl V714))))) ((and (cons? V714) (and (= let (hd V714)) (and (cons? (tl V714)) (and (cons? (tl (tl V714))) (and (cons? (tl (tl (tl V714)))) (= () (tl (tl (tl (tl V714)))))))))) (union (shen.extract_free_vars V713 (hd (tl (tl V714)))) (shen.extract_free_vars (cons (hd (tl V714)) V713) (hd (tl (tl (tl V714))))))) ((cons? V714) (union (shen.extract_free_vars V713 (hd V714)) (shen.extract_free_vars V713 (tl V714)))) (true ())))
106
+
107
+ (defun shen.free_variable_warnings (V717 V718) (cond ((= () V718) _) (true (simple-error (cn "error: the following variables are free in " (shen.app V717 (cn ": " (shen.app (shen.list_variables V718) "" shen.a)) shen.a))))))
108
+
109
+ (defun shen.list_variables (V719) (cond ((and (cons? V719) (= () (tl V719))) (cn (str (hd V719)) ".")) ((cons? V719) (cn (str (hd V719)) (cn ", " (shen.list_variables (tl V719))))) (true (shen.sys-error shen.list_variables))))
110
+
111
+ (defun shen.strip-protect (V720) (cond ((and (cons? V720) (and (cons? (tl V720)) (and (= () (tl (tl V720))) (= (hd V720) protect)))) (hd (tl V720))) ((cons? V720) (cons (shen.strip-protect (hd V720)) (shen.strip-protect (tl V720)))) (true V720)))
112
+
113
+ (defun shen.linearise (V721) (cond ((and (cons? V721) (and (cons? (tl V721)) (= () (tl (tl V721))))) (shen.linearise_help (shen.flatten (hd V721)) (hd V721) (hd (tl V721)))) (true (shen.sys-error shen.linearise))))
114
+
115
+ (defun shen.flatten (V722) (cond ((= () V722) ()) ((cons? V722) (append (shen.flatten (hd V722)) (shen.flatten (tl V722)))) (true (cons V722 ()))))
116
+
117
+ (defun shen.linearise_help (V723 V724 V725) (cond ((= () V723) (cons V724 (cons V725 ()))) ((cons? V723) (if (and (variable? (hd V723)) (element? (hd V723) (tl V723))) (let Var (gensym (hd V723)) (let NewAction (cons where (cons (cons = (cons (hd V723) (cons Var ()))) (cons V725 ()))) (let NewPatts (shen.linearise_X (hd V723) Var V724) (shen.linearise_help (tl V723) NewPatts NewAction)))) (shen.linearise_help (tl V723) V724 V725))) (true (shen.sys-error shen.linearise_help))))
118
+
119
+ (defun shen.linearise_X (V734 V735 V736) (cond ((= V736 V734) V735) ((cons? V736) (let L (shen.linearise_X V734 V735 (hd V736)) (if (= L (hd V736)) (cons (hd V736) (shen.linearise_X V734 V735 (tl V736))) (cons L (tl V736))))) (true V736)))
120
+
121
+ (defun shen.aritycheck (V738 V739) (cond ((and (cons? V739) (and (cons? (hd V739)) (and (cons? (tl (hd V739))) (and (= () (tl (tl (hd V739)))) (= () (tl V739)))))) (do (shen.aritycheck-action (hd (tl (hd V739)))) (shen.aritycheck-name V738 (arity V738) (length (hd (hd V739)))))) ((and (cons? V739) (and (cons? (hd V739)) (and (cons? (tl (hd V739))) (and (= () (tl (tl (hd V739)))) (and (cons? (tl V739)) (and (cons? (hd (tl V739))) (and (cons? (tl (hd (tl V739)))) (= () (tl (tl (hd (tl V739)))))))))))) (if (= (length (hd (hd V739))) (length (hd (hd (tl V739))))) (do (shen.aritycheck-action (hd (tl (hd V739)))) (shen.aritycheck V738 (tl V739))) (simple-error (cn "arity error in " (shen.app V738 "
122
+ " shen.a))))) (true (shen.sys-error shen.aritycheck))))
123
+
124
+ (defun shen.aritycheck-name (V748 V749 V750) (cond ((= -1 V749) V750) ((= V750 V749) V750) (true (do (shen.prhush (cn "
125
+ warning: changing the arity of " (shen.app V748 " can cause errors.
126
+ " shen.a)) (stoutput)) V750))))
127
+
128
+ (defun shen.aritycheck-action (V756) (cond ((cons? V756) (do (shen.aah (hd V756) (tl V756)) (map (lambda X612 (shen.aritycheck-action X612)) V756))) (true shen.skip)))
129
+
130
+ (defun shen.aah (V757 V758) (let Arity (arity V757) (let Len (length V758) (if (and (> Arity -1) (> Len Arity)) (shen.prhush (cn "warning: " (shen.app V757 (cn " might not like " (shen.app Len (cn " argument" (shen.app (if (> Len 1) "s" "") ".
131
+ " shen.a)) shen.a)) shen.a)) (stoutput)) shen.skip))))
132
+
133
+ (defun shen.abstract_rule (V759) (cond ((and (cons? V759) (and (cons? (tl V759)) (= () (tl (tl V759))))) (shen.abstraction_build (hd V759) (hd (tl V759)))) (true (shen.sys-error shen.abstract_rule))))
134
+
135
+ (defun shen.abstraction_build (V760 V761) (cond ((= () V760) V761) ((cons? V760) (cons /. (cons (hd V760) (cons (shen.abstraction_build (tl V760) V761) ())))) (true (shen.sys-error shen.abstraction_build))))
136
+
137
+ (defun shen.parameters (V762) (cond ((= 0 V762) ()) (true (cons (gensym V) (shen.parameters (- V762 1))))))
138
+
139
+ (defun shen.application_build (V763 V764) (cond ((= () V763) V764) ((cons? V763) (shen.application_build (tl V763) (cons V764 (cons (hd V763) ())))) (true (shen.sys-error shen.application_build))))
140
+
141
+ (defun shen.compile_to_kl (V765 V766) (cond ((and (cons? V766) (and (cons? (tl V766)) (= () (tl (tl V766))))) (let Arity (shen.store-arity V765 (length (hd V766))) (let Reduce (map (lambda X613 (shen.reduce X613)) (hd (tl V766))) (let CondExpression (shen.cond-expression V765 (hd V766) Reduce) (let TypeTable (if (value shen.*optimise*) (shen.typextable (shen.get-type V765) (hd V766)) shen.skip) (let TypedCondExpression (if (value shen.*optimise*) (shen.assign-types (hd V766) TypeTable CondExpression) CondExpression) (let KL (cons defun (cons V765 (cons (hd V766) (cons TypedCondExpression ())))) KL))))))) (true (shen.sys-error shen.compile_to_kl))))
142
+
143
+ (defun shen.get-type (V771) (cond ((cons? V771) shen.skip) (true (let FType (assoc V771 (value shen.*signedfuncs*)) (if (empty? FType) shen.skip (tl FType))))))
144
+
145
+ (defun shen.typextable (V780 V781) (cond ((and (cons? V780) (and (cons? (tl V780)) (and (= --> (hd (tl V780))) (and (cons? (tl (tl V780))) (and (= () (tl (tl (tl V780)))) (cons? V781)))))) (if (variable? (hd V780)) (shen.typextable (hd (tl (tl V780))) (tl V781)) (cons (cons (hd V781) (hd V780)) (shen.typextable (hd (tl (tl V780))) (tl V781))))) (true ())))
146
+
147
+ (defun shen.assign-types (V782 V783 V784) (cond ((and (cons? V784) (and (= let (hd V784)) (and (cons? (tl V784)) (and (cons? (tl (tl V784))) (and (cons? (tl (tl (tl V784)))) (= () (tl (tl (tl (tl V784)))))))))) (cons let (cons (hd (tl V784)) (cons (shen.assign-types V782 V783 (hd (tl (tl V784)))) (cons (shen.assign-types (cons (hd (tl V784)) V782) V783 (hd (tl (tl (tl V784))))) ()))))) ((and (cons? V784) (and (= lambda (hd V784)) (and (cons? (tl V784)) (and (cons? (tl (tl V784))) (= () (tl (tl (tl V784)))))))) (cons lambda (cons (hd (tl V784)) (cons (shen.assign-types (cons (hd (tl V784)) V782) V783 (hd (tl (tl V784)))) ())))) ((and (cons? V784) (= cond (hd V784))) (cons cond (map (lambda Y (cons (shen.assign-types V782 V783 (hd Y)) (cons (shen.assign-types V782 V783 (hd (tl Y))) ()))) (tl V784)))) ((cons? V784) (let NewTable (shen.typextable (shen.get-type (hd V784)) (tl V784)) (cons (hd V784) (map (lambda Y (shen.assign-types V782 (append V783 NewTable) Y)) (tl V784))))) (true (let AtomType (assoc V784 V783) (if (cons? AtomType) (cons type (cons V784 (cons (tl AtomType) ()))) (if (element? V784 V782) V784 (shen.atom-type V784)))))))
148
+
149
+ (defun shen.atom-type (V785) (if (string? V785) (cons type (cons V785 (cons string ()))) (if (number? V785) (cons type (cons V785 (cons number ()))) (if (boolean? V785) (cons type (cons V785 (cons boolean ()))) (if (symbol? V785) (cons type (cons V785 (cons symbol ()))) V785)))))
150
+
151
+ (defun shen.store-arity (V788 V789) (cond ((value shen.*installing-kl*) shen.skip) (true (put V788 arity V789 (value *property-vector*)))))
152
+
153
+ (defun shen.reduce (V790) (do (set shen.*teststack* ()) (let Result (shen.reduce_help V790) (cons (cons : (cons shen.tests (reverse (value shen.*teststack*)))) (cons Result ())))))
154
+
155
+ (defun shen.reduce_help (V791) (cond ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (hd (tl (hd V791)))) (and (= cons (hd (hd (tl (hd V791))))) (and (cons? (tl (hd (tl (hd V791))))) (and (cons? (tl (tl (hd (tl (hd V791)))))) (and (= () (tl (tl (tl (hd (tl (hd V791))))))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791))))))))))))))) (do (shen.add_test (cons cons? (tl V791))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V791))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V791)))))) (cons (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hd (tl V791)) ())) (cons (cons tl (tl V791)) ())) (shen.reduce_help Application))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (hd (tl (hd V791)))) (and (= @p (hd (hd (tl (hd V791))))) (and (cons? (tl (hd (tl (hd V791))))) (and (cons? (tl (tl (hd (tl (hd V791)))))) (and (= () (tl (tl (tl (hd (tl (hd V791))))))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791))))))))))))))) (do (shen.add_test (cons tuple? (tl V791))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V791))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V791)))))) (cons (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons fst (tl V791)) ())) (cons (cons snd (tl V791)) ())) (shen.reduce_help Application))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (hd (tl (hd V791)))) (and (= @v (hd (hd (tl (hd V791))))) (and (cons? (tl (hd (tl (hd V791))))) (and (cons? (tl (tl (hd (tl (hd V791)))))) (and (= () (tl (tl (tl (hd (tl (hd V791))))))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791))))))))))))))) (do (shen.add_test (cons shen.+vector? (tl V791))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V791))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V791)))))) (cons (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hdv (tl V791)) ())) (cons (cons tlv (tl V791)) ())) (shen.reduce_help Application))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (hd (tl (hd V791)))) (and (= @s (hd (hd (tl (hd V791))))) (and (cons? (tl (hd (tl (hd V791))))) (and (cons? (tl (tl (hd (tl (hd V791)))))) (and (= () (tl (tl (tl (hd (tl (hd V791))))))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791))))))))))))))) (do (shen.add_test (cons shen.+string? (tl V791))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V791))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V791)))))) (cons (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons pos (cons (hd (tl V791)) (cons 0 ()))) ())) (cons (cons tlstr (tl V791)) ())) (shen.reduce_help Application))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (and (= () (tl (tl V791))) (not (variable? (hd (tl (hd V791))))))))))))) (do (shen.add_test (cons = (cons (hd (tl (hd V791))) (tl V791)))) (shen.reduce_help (hd (tl (tl (hd V791))))))) ((and (cons? V791) (and (cons? (hd V791)) (and (= /. (hd (hd V791))) (and (cons? (tl (hd V791))) (and (cons? (tl (tl (hd V791)))) (and (= () (tl (tl (tl (hd V791))))) (and (cons? (tl V791)) (= () (tl (tl V791)))))))))) (shen.reduce_help (shen.ebr (hd (tl V791)) (hd (tl (hd V791))) (hd (tl (tl (hd V791))))))) ((and (cons? V791) (and (= where (hd V791)) (and (cons? (tl V791)) (and (cons? (tl (tl V791))) (= () (tl (tl (tl V791)))))))) (do (shen.add_test (hd (tl V791))) (shen.reduce_help (hd (tl (tl V791)))))) ((and (cons? V791) (and (cons? (tl V791)) (= () (tl (tl V791))))) (let Z (shen.reduce_help (hd V791)) (if (= (hd V791) Z) V791 (shen.reduce_help (cons Z (tl V791)))))) (true V791)))
156
+
157
+ (defun shen.+string? (V792) (cond ((= "" V792) false) (true (string? V792))))
158
+
159
+ (defun shen.+vector (V793) (cond ((= V793 (vector 0)) false) (true (vector? V793))))
160
+
161
+ (defun shen.ebr (V802 V803 V804) (cond ((= V804 V803) V802) ((and (cons? V804) (and (= /. (hd V804)) (and (cons? (tl V804)) (and (cons? (tl (tl V804))) (and (= () (tl (tl (tl V804)))) (> (occurrences V803 (hd (tl V804))) 0)))))) V804) ((and (cons? V804) (and (= let (hd V804)) (and (cons? (tl V804)) (and (cons? (tl (tl V804))) (and (cons? (tl (tl (tl V804)))) (and (= () (tl (tl (tl (tl V804))))) (= (hd (tl V804)) V803))))))) (cons let (cons (hd (tl V804)) (cons (shen.ebr V802 (hd (tl V804)) (hd (tl (tl V804)))) (tl (tl (tl V804))))))) ((cons? V804) (cons (shen.ebr V802 V803 (hd V804)) (shen.ebr V802 V803 (tl V804)))) (true V804)))
162
+
163
+ (defun shen.add_test (V807) (set shen.*teststack* (cons V807 (value shen.*teststack*))))
164
+
165
+ (defun shen.cond-expression (V808 V809 V810) (let Err (shen.err-condition V808) (let Cases (shen.case-form V810 Err) (let EncodeChoices (shen.encode-choices Cases V808) (shen.cond-form EncodeChoices)))))
166
+
167
+ (defun shen.cond-form (V813) (cond ((and (cons? V813) (and (cons? (hd V813)) (and (= true (hd (hd V813))) (and (cons? (tl (hd V813))) (= () (tl (tl (hd V813)))))))) (hd (tl (hd V813)))) (true (cons cond V813))))
168
+
169
+ (defun shen.encode-choices (V816 V817) (cond ((= () V816) ()) ((and (cons? V816) (and (cons? (hd V816)) (and (= true (hd (hd V816))) (and (cons? (tl (hd V816))) (and (cons? (hd (tl (hd V816)))) (and (= shen.choicepoint! (hd (hd (tl (hd V816))))) (and (cons? (tl (hd (tl (hd V816))))) (and (= () (tl (tl (hd (tl (hd V816)))))) (and (= () (tl (tl (hd V816)))) (= () (tl V816))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V816))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (if (value shen.*installing-kl*) (cons shen.sys-error (cons V817 ())) (cons shen.f_error (cons V817 ()))) (cons Result ())))) ())))) ())) ())) ((and (cons? V816) (and (cons? (hd V816)) (and (= true (hd (hd V816))) (and (cons? (tl (hd V816))) (and (cons? (hd (tl (hd V816)))) (and (= shen.choicepoint! (hd (hd (tl (hd V816))))) (and (cons? (tl (hd (tl (hd V816))))) (and (= () (tl (tl (hd (tl (hd V816)))))) (= () (tl (tl (hd V816)))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V816))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (shen.cond-form (shen.encode-choices (tl V816) V817)) (cons Result ())))) ())))) ())) ())) ((and (cons? V816) (and (cons? (hd V816)) (and (cons? (tl (hd V816))) (and (cons? (hd (tl (hd V816)))) (and (= shen.choicepoint! (hd (hd (tl (hd V816))))) (and (cons? (tl (hd (tl (hd V816))))) (and (= () (tl (tl (hd (tl (hd V816)))))) (= () (tl (tl (hd V816))))))))))) (cons (cons true (cons (cons let (cons Freeze (cons (cons freeze (cons (shen.cond-form (shen.encode-choices (tl V816) V817)) ())) (cons (cons if (cons (hd (hd V816)) (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V816))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (cons thaw (cons Freeze ())) (cons Result ())))) ())))) (cons (cons thaw (cons Freeze ())) ())))) ())))) ())) ())) ((and (cons? V816) (and (cons? (hd V816)) (and (cons? (tl (hd V816))) (= () (tl (tl (hd V816))))))) (cons (hd V816) (shen.encode-choices (tl V816) V817))) (true (shen.sys-error shen.encode-choices))))
170
+
171
+ (defun shen.case-form (V822 V823) (cond ((= () V822) (cons V823 ())) ((and (cons? V822) (and (cons? (hd V822)) (and (cons? (hd (hd V822))) (and (= : (hd (hd (hd V822)))) (and (cons? (tl (hd (hd V822)))) (and (= shen.tests (hd (tl (hd (hd V822))))) (and (= () (tl (tl (hd (hd V822))))) (and (cons? (tl (hd V822))) (and (cons? (hd (tl (hd V822)))) (and (= shen.choicepoint! (hd (hd (tl (hd V822))))) (and (cons? (tl (hd (tl (hd V822))))) (and (= () (tl (tl (hd (tl (hd V822)))))) (= () (tl (tl (hd V822)))))))))))))))) (cons (cons true (tl (hd V822))) (shen.case-form (tl V822) V823))) ((and (cons? V822) (and (cons? (hd V822)) (and (cons? (hd (hd V822))) (and (= : (hd (hd (hd V822)))) (and (cons? (tl (hd (hd V822)))) (and (= shen.tests (hd (tl (hd (hd V822))))) (and (= () (tl (tl (hd (hd V822))))) (and (cons? (tl (hd V822))) (= () (tl (tl (hd V822)))))))))))) (cons (cons true (tl (hd V822))) ())) ((and (cons? V822) (and (cons? (hd V822)) (and (cons? (hd (hd V822))) (and (= : (hd (hd (hd V822)))) (and (cons? (tl (hd (hd V822)))) (and (= shen.tests (hd (tl (hd (hd V822))))) (and (cons? (tl (hd V822))) (= () (tl (tl (hd V822))))))))))) (cons (cons (shen.embed-and (tl (tl (hd (hd V822))))) (tl (hd V822))) (shen.case-form (tl V822) V823))) (true (shen.sys-error shen.case-form))))
172
+
173
+ (defun shen.embed-and (V824) (cond ((and (cons? V824) (= () (tl V824))) (hd V824)) ((cons? V824) (cons and (cons (hd V824) (cons (shen.embed-and (tl V824)) ())))) (true (shen.sys-error shen.embed-and))))
174
+
175
+ (defun shen.err-condition (V825) (cons true (cons (cons shen.f_error (cons V825 ())) ())))
176
+
177
+ (defun shen.sys-error (V826) (simple-error (cn "system function " (shen.app V826 ": unexpected argument
178
+ " shen.a))))
179
+
180
+
181
+
data/shen/release/k_lambda/declarations.kl CHANGED
@@ -1,131 +1,131 @@
1
- "**********************************************************************************
2
- * The License *
3
- * *
4
- * The user is free to produce commercial applications with the software, to *
5
- * distribute these applications in source or binary form, and to charge monies *
6
- * for them as he sees fit and in concordance with the laws of the land subject *
7
- * to the following license. *
8
- * *
9
- * 1. The license applies to all the software and all derived software and *
10
- * must appear on such. *
11
- * *
12
- * 2. It is illegal to distribute the software without this license attached *
13
- * to it and use of the software implies agreement with the license as such. *
14
- * It is illegal for anyone who is not the copyright holder to tamper with *
15
- * or change the license. *
16
- * *
17
- * 3. Neither the names of Lambda Associates or the copyright holder may be used *
18
- * to endorse or promote products built using the software without specific *
19
- * prior written permission from the copyright holder. *
20
- * *
21
- * 4. That possession of this license does not confer on the copyright holder *
22
- * any special contractual obligation towards the user. That in no event *
23
- * shall the copyright holder be liable for any direct, indirect, incidental, *
24
- * special, exemplary or consequential damages (including but not limited *
25
- * to procurement of substitute goods or services, loss of use, data, *
26
- * interruption), however caused and on any theory of liability, whether in *
27
- * contract, strict liability or tort (including negligence) arising in any *
28
- * way out of the use of the software, even if advised of the possibility of *
29
- * such damage. *
30
- * *
31
- * 5. It is permitted for the user to change the software, for the purpose of *
32
- * improving performance, correcting an error, or porting to a new platform, *
33
- * and distribute the derived version of Shen provided the resulting program *
34
- * conforms in all respects to the Shen standard and is issued under that *
35
- * title. The user must make it clear with his distribution that he/she is *
36
- * the author of the changes and what these changes are and why. *
37
- * *
38
- * 6. Derived versions of this software in whatever form are subject to the same *
39
- * restrictions. In particular it is not permitted to make derived copies of *
40
- * this software which do not conform to the Shen standard or appear under a *
41
- * different title. *
42
- * *
43
- * It is permitted to distribute versions of Shen which incorporate libraries, *
44
- * graphics or other facilities which are not part of the Shen standard. *
45
- * *
46
- * For an explication of this license see www.shenlanguage.org/license.htm which *
47
- * explains this license in full. *
48
- * *
49
- *****************************************************************************************
50
- "(set shen.*installing-kl* false)
51
-
52
- (set shen.*history* ())
53
-
54
- (set shen.*tc* false)
55
-
56
- (set *property-vector* (vector 20000))
57
-
58
- (set shen.*process-counter* 0)
59
-
60
- (set shen.*varcounter* (vector 1000))
61
-
62
- (set shen.*prologvectors* (vector 1000))
63
-
64
- (set shen.*reader-macros* ())
65
-
66
- (set *home-directory* ())
67
-
68
- (set shen.*gensym* 0)
69
-
70
- (set shen.*tracking* ())
71
-
72
- (set *home-directory* "")
73
-
74
- (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 ())))))))))))))))))))))))))))
75
-
76
- (set shen.*special* (cons @p (cons @s (cons @v (cons cons (cons lambda (cons let (cons where (cons set (cons open ()))))))))))
77
-
78
- (set shen.*extraspecial* (cons define (cons shen.process-datatype (cons input+ (cons defcc (cons read+ (cons defmacro ())))))))
79
-
80
- (set shen.*spy* false)
81
-
82
- (set shen.*datatypes* ())
83
-
84
- (set shen.*alldatatypes* ())
85
-
86
- (set shen.*shen-type-theory-enabled?* true)
87
-
88
- (set shen.*synonyms* ())
89
-
90
- (set shen.*system* ())
91
-
92
- (set shen.*signedfuncs* ())
93
-
94
- (set shen.*maxcomplexity* 128)
95
-
96
- (set shen.*occurs* true)
97
-
98
- (set shen.*maxinferences* 1000000)
99
-
100
- (set *maximum-print-sequence-size* 20)
101
-
102
- (set shen.*catch* 0)
103
-
104
- (set shen.*call* 0)
105
-
106
- (set shen.*infs* 0)
107
-
108
- (set *hush* false)
109
-
110
- (set shen.*optimise* false)
111
-
112
- (set *version* "version 16")
113
-
114
- (defun shen.initialise_arity_table (V827) (cond ((= () V827) ()) ((and (cons? V827) (cons? (tl V827))) (let DecArity (put (hd V827) arity (hd (tl V827)) (value *property-vector*)) (shen.initialise_arity_table (tl (tl V827))))) (true (shen.sys-error shen.initialise_arity_table))))
115
-
116
- (defun arity (V828) (trap-error (get V828 arity (value *property-vector*)) (lambda E -1)))
117
-
118
- (shen.initialise_arity_table (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 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 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 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 release (cons 0 (cons remove (cons 2 (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 shen.strong-warning (cons 1 (cons subst (cons 3 (cons sum (cons 1 (cons symbol? (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 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 warn (cons 1 (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 <e> (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 (cons where (cons 2 ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
119
-
120
- (defun systemf (V829) (let Shen (intern "shen") (let External (get Shen shen.external-symbols (value *property-vector*)) (put Shen shen.external-symbols (adjoin V829 External) (value *property-vector*)))))
121
-
122
- (defun adjoin (V830 V831) (if (element? V830 V831) V831 (cons V830 V831)))
123
-
124
- (put (intern "shen") shen.external-symbols (cons ! (cons } (cons { (cons --> (cons <-- (cons && (cons : (cons ; (cons :- (cons := (cons _ (cons *language* (cons *implementation* (cons *stinput* (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 <e> (cons == (cons = (cons >= (cons > (cons /. (cons =! (cons $ (cons - (cons / (cons * (cons + (cons <= (cons < (cons >> (cons (vector 0) (cons ==> (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 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 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 read-file (cons read-file-as-bytelist (cons read-file-as-string (cons read-byte (cons read-from-string (cons quit (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 macro (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 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*))
125
-
126
- (defun specialise (V832) (do (set shen.*special* (cons V832 (value shen.*special*))) V832))
127
-
128
- (defun unspecialise (V833) (do (set shen.*special* (remove V833 (value shen.*special*))) V833))
129
-
130
-
131
-
1
+ "**********************************************************************************
2
+ * The License *
3
+ * *
4
+ * The user is free to produce commercial applications with the software, to *
5
+ * distribute these applications in source or binary form, and to charge monies *
6
+ * for them as he sees fit and in concordance with the laws of the land subject *
7
+ * to the following license. *
8
+ * *
9
+ * 1. The license applies to all the software and all derived software and *
10
+ * must appear on such. *
11
+ * *
12
+ * 2. It is illegal to distribute the software without this license attached *
13
+ * to it and use of the software implies agreement with the license as such. *
14
+ * It is illegal for anyone who is not the copyright holder to tamper with *
15
+ * or change the license. *
16
+ * *
17
+ * 3. Neither the names of Lambda Associates or the copyright holder may be used *
18
+ * to endorse or promote products built using the software without specific *
19
+ * prior written permission from the copyright holder. *
20
+ * *
21
+ * 4. That possession of this license does not confer on the copyright holder *
22
+ * any special contractual obligation towards the user. That in no event *
23
+ * shall the copyright holder be liable for any direct, indirect, incidental, *
24
+ * special, exemplary or consequential damages (including but not limited *
25
+ * to procurement of substitute goods or services, loss of use, data, *
26
+ * interruption), however caused and on any theory of liability, whether in *
27
+ * contract, strict liability or tort (including negligence) arising in any *
28
+ * way out of the use of the software, even if advised of the possibility of *
29
+ * such damage. *
30
+ * *
31
+ * 5. It is permitted for the user to change the software, for the purpose of *
32
+ * improving performance, correcting an error, or porting to a new platform, *
33
+ * and distribute the derived version of Shen provided the resulting program *
34
+ * conforms in all respects to the Shen standard and is issued under that *
35
+ * title. The user must make it clear with his distribution that he/she is *
36
+ * the author of the changes and what these changes are and why. *
37
+ * *
38
+ * 6. Derived versions of this software in whatever form are subject to the same *
39
+ * restrictions. In particular it is not permitted to make derived copies of *
40
+ * this software which do not conform to the Shen standard or appear under a *
41
+ * different title. *
42
+ * *
43
+ * It is permitted to distribute versions of Shen which incorporate libraries, *
44
+ * graphics or other facilities which are not part of the Shen standard. *
45
+ * *
46
+ * For an explication of this license see www.shenlanguage.org/license.htm which *
47
+ * explains this license in full. *
48
+ * *
49
+ *****************************************************************************************
50
+ "(set shen.*installing-kl* false)
51
+
52
+ (set shen.*history* ())
53
+
54
+ (set shen.*tc* false)
55
+
56
+ (set *property-vector* (vector 20000))
57
+
58
+ (set shen.*process-counter* 0)
59
+
60
+ (set shen.*varcounter* (vector 1000))
61
+
62
+ (set shen.*prologvectors* (vector 1000))
63
+
64
+ (set shen.*reader-macros* ())
65
+
66
+ (set *home-directory* ())
67
+
68
+ (set shen.*gensym* 0)
69
+
70
+ (set shen.*tracking* ())
71
+
72
+ (set *home-directory* "")
73
+
74
+ (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 ())))))))))))))))))))))))))))
75
+
76
+ (set shen.*special* (cons @p (cons @s (cons @v (cons cons (cons lambda (cons let (cons where (cons set (cons open ()))))))))))
77
+
78
+ (set shen.*extraspecial* (cons define (cons shen.process-datatype (cons input+ (cons defcc (cons read+ (cons defmacro ())))))))
79
+
80
+ (set shen.*spy* false)
81
+
82
+ (set shen.*datatypes* ())
83
+
84
+ (set shen.*alldatatypes* ())
85
+
86
+ (set shen.*shen-type-theory-enabled?* true)
87
+
88
+ (set shen.*synonyms* ())
89
+
90
+ (set shen.*system* ())
91
+
92
+ (set shen.*signedfuncs* ())
93
+
94
+ (set shen.*maxcomplexity* 128)
95
+
96
+ (set shen.*occurs* true)
97
+
98
+ (set shen.*maxinferences* 1000000)
99
+
100
+ (set *maximum-print-sequence-size* 20)
101
+
102
+ (set shen.*catch* 0)
103
+
104
+ (set shen.*call* 0)
105
+
106
+ (set shen.*infs* 0)
107
+
108
+ (set *hush* false)
109
+
110
+ (set shen.*optimise* false)
111
+
112
+ (set *version* "version 16")
113
+
114
+ (defun shen.initialise_arity_table (V827) (cond ((= () V827) ()) ((and (cons? V827) (cons? (tl V827))) (let DecArity (put (hd V827) arity (hd (tl V827)) (value *property-vector*)) (shen.initialise_arity_table (tl (tl V827))))) (true (shen.sys-error shen.initialise_arity_table))))
115
+
116
+ (defun arity (V828) (trap-error (get V828 arity (value *property-vector*)) (lambda E -1)))
117
+
118
+ (shen.initialise_arity_table (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 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 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 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 release (cons 0 (cons remove (cons 2 (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 shen.strong-warning (cons 1 (cons subst (cons 3 (cons sum (cons 1 (cons symbol? (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 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 warn (cons 1 (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 <e> (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 (cons where (cons 2 ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
119
+
120
+ (defun systemf (V829) (let Shen (intern "shen") (let External (get Shen shen.external-symbols (value *property-vector*)) (put Shen shen.external-symbols (adjoin V829 External) (value *property-vector*)))))
121
+
122
+ (defun adjoin (V830 V831) (if (element? V830 V831) V831 (cons V830 V831)))
123
+
124
+ (put (intern "shen") shen.external-symbols (cons ! (cons } (cons { (cons --> (cons <-- (cons && (cons : (cons ; (cons :- (cons := (cons _ (cons *language* (cons *implementation* (cons *stinput* (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 <e> (cons == (cons = (cons >= (cons > (cons /. (cons =! (cons $ (cons - (cons / (cons * (cons + (cons <= (cons < (cons >> (cons (vector 0) (cons ==> (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 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 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 read-file (cons read-file-as-bytelist (cons read-file-as-string (cons read-byte (cons read-from-string (cons quit (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 macro (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 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*))
125
+
126
+ (defun specialise (V832) (do (set shen.*special* (cons V832 (value shen.*special*))) V832))
127
+
128
+ (defun unspecialise (V833) (do (set shen.*special* (remove V833 (value shen.*special*))) V833))
129
+
130
+
131
+