"Copyright (c) 2015, Mark Tarver

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright
   notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
   notice, this list of conditions and the following disclaimer in the
   documentation and/or other materials provided with the distribution.
3. The name of Mark Tarver may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY
EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."

(defun shen.shen->kl (V1191 V1192) (compile (lambda X (shen.<define> X)) (cons V1191 V1192) (lambda X (shen.shen-syntax-error V1191 X))))

(defun shen.shen-syntax-error (V1199 V1200) (cond ((cons? V1200) (simple-error (cn "syntax error in " (shen.app V1199 (cn " here:

 " (shen.app (shen.next-50 50 (hd V1200)) "
" shen.a)) shen.a)))) (true (simple-error (cn "syntax error in " (shen.app V1199 "
" shen.a))))))

(defun shen.<define> (V1202) (let YaccParse (let Parse_shen.<name> (shen.<name> V1202) (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 (= YaccParse (fail)) (let Parse_shen.<name> (shen.<name> V1202) (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))) YaccParse)))

(defun shen.<name> (V1204) (if (cons? (hd V1204)) (let Parse_X (shen.hdhd V1204) (shen.pair (hd (shen.pair (shen.tlhd V1204) (shen.hdtl V1204))) (if (and (symbol? Parse_X) (not (shen.sysfunc? Parse_X))) Parse_X (simple-error (shen.app Parse_X " is not a legitimate function name.
" shen.a))))) (fail)))

(defun shen.sysfunc? (V1206) (element? V1206 (get (intern "shen") shen.external-symbols (value *property-vector*))))

(defun shen.<signature> (V1210) (if (and (cons? (hd V1210)) (= { (shen.hdhd V1210))) (let NewStream1207 (shen.pair (shen.tlhd V1210) (shen.hdtl V1210)) (let Parse_shen.<signature-help> (shen.<signature-help> NewStream1207) (if (not (= (fail) Parse_shen.<signature-help>)) (if (and (cons? (hd Parse_shen.<signature-help>)) (= } (shen.hdhd Parse_shen.<signature-help>))) (let NewStream1208 (shen.pair (shen.tlhd Parse_shen.<signature-help>) (shen.hdtl Parse_shen.<signature-help>)) (shen.pair (hd NewStream1208) (shen.demodulate (shen.curry-type (shen.hdtl Parse_shen.<signature-help>))))) (fail)) (fail)))) (fail)))

(defun shen.curry-type (V1212) (shen.active-cons (shen.curry-type-h V1212)))

(defun shen.active-cons (V1214) (cond ((and (cons? V1214) (and (cons? (tl V1214)) (and (cons? (tl (tl V1214))) (and (= () (tl (tl (tl V1214)))) (= (hd (tl V1214)) bar!))))) (cons (shen.active-cons (hd V1214)) (shen.active-cons (hd (tl (tl V1214)))))) ((cons? V1214) (cons (shen.active-cons (hd V1214)) (shen.active-cons (tl V1214)))) (true V1214)))

(defun shen.curry-type-h (V1216) (cond ((and (cons? V1216) (and (cons? (tl V1216)) (and (= --> (hd (tl V1216))) (and (cons? (tl (tl V1216))) (and (cons? (tl (tl (tl V1216)))) (= --> (hd (tl (tl (tl V1216)))))))))) (shen.curry-type-h (cons (hd V1216) (cons --> (cons (tl (tl V1216)) ()))))) ((and (cons? V1216) (and (cons? (tl V1216)) (and (= * (hd (tl V1216))) (and (cons? (tl (tl V1216))) (and (cons? (tl (tl (tl V1216)))) (= * (hd (tl (tl (tl V1216)))))))))) (shen.curry-type-h (cons (hd V1216) (cons * (cons (tl (tl V1216)) ()))))) ((cons? V1216) (map (lambda Z (shen.curry-type-h Z)) V1216)) (true V1216)))

(defun shen.<signature-help> (V1218) (let YaccParse (if (cons? (hd V1218)) (let Parse_X (shen.hdhd V1218) (let Parse_shen.<signature-help> (shen.<signature-help> (shen.pair (shen.tlhd V1218) (shen.hdtl V1218))) (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 (= YaccParse (fail)) (let Parse_<e> (<e> V1218) (if (not (= (fail) Parse_<e>)) (shen.pair (hd Parse_<e>) ()) (fail))) YaccParse)))

(defun shen.<rules> (V1220) (let YaccParse (let Parse_shen.<rule> (shen.<rule> V1220) (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 (= YaccParse (fail)) (let Parse_shen.<rule> (shen.<rule> V1220) (if (not (= (fail) Parse_shen.<rule>)) (shen.pair (hd Parse_shen.<rule>) (cons (shen.linearise (shen.hdtl Parse_shen.<rule>)) ())) (fail))) YaccParse)))

(defun shen.<rule> (V1228) (let YaccParse (let Parse_shen.<patterns> (shen.<patterns> V1228) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= -> (shen.hdhd Parse_shen.<patterns>))) (let NewStream1221 (shen.pair (shen.tlhd Parse_shen.<patterns>) (shen.hdtl Parse_shen.<patterns>)) (let Parse_shen.<action> (shen.<action> NewStream1221) (if (not (= (fail) Parse_shen.<action>)) (if (and (cons? (hd Parse_shen.<action>)) (= where (shen.hdhd Parse_shen.<action>))) (let NewStream1222 (shen.pair (shen.tlhd Parse_shen.<action>) (shen.hdtl Parse_shen.<action>)) (let Parse_shen.<guard> (shen.<guard> NewStream1222) (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 (= YaccParse (fail)) (let YaccParse (let Parse_shen.<patterns> (shen.<patterns> V1228) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= -> (shen.hdhd Parse_shen.<patterns>))) (let NewStream1223 (shen.pair (shen.tlhd Parse_shen.<patterns>) (shen.hdtl Parse_shen.<patterns>)) (let Parse_shen.<action> (shen.<action> NewStream1223) (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 (= YaccParse (fail)) (let YaccParse (let Parse_shen.<patterns> (shen.<patterns> V1228) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= <- (shen.hdhd Parse_shen.<patterns>))) (let NewStream1224 (shen.pair (shen.tlhd Parse_shen.<patterns>) (shen.hdtl Parse_shen.<patterns>)) (let Parse_shen.<action> (shen.<action> NewStream1224) (if (not (= (fail) Parse_shen.<action>)) (if (and (cons? (hd Parse_shen.<action>)) (= where (shen.hdhd Parse_shen.<action>))) (let NewStream1225 (shen.pair (shen.tlhd Parse_shen.<action>) (shen.hdtl Parse_shen.<action>)) (let Parse_shen.<guard> (shen.<guard> NewStream1225) (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 (= YaccParse (fail)) (let Parse_shen.<patterns> (shen.<patterns> V1228) (if (not (= (fail) Parse_shen.<patterns>)) (if (and (cons? (hd Parse_shen.<patterns>)) (= <- (shen.hdhd Parse_shen.<patterns>))) (let NewStream1226 (shen.pair (shen.tlhd Parse_shen.<patterns>) (shen.hdtl Parse_shen.<patterns>)) (let Parse_shen.<action> (shen.<action> NewStream1226) (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))) YaccParse)) YaccParse)) YaccParse)))

(defun shen.fail_if (V1231 V1232) (if (V1231 V1232) (fail) V1232))

(defun shen.succeeds? (V1238) (cond ((= V1238 (fail)) false) (true true)))

(defun shen.<patterns> (V1240) (let YaccParse (let Parse_shen.<pattern> (shen.<pattern> V1240) (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 (= YaccParse (fail)) (let Parse_<e> (<e> V1240) (if (not (= (fail) Parse_<e>)) (shen.pair (hd Parse_<e>) ()) (fail))) YaccParse)))

(defun shen.<pattern> (V1253) (let YaccParse (if (and (cons? (hd V1253)) (cons? (shen.hdhd V1253))) (if (and (cons? (hd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (= @p (shen.hdhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))))) (let NewStream1242 (shen.pair (shen.tlhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))) (shen.hdtl (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (let Parse_shen.<pattern1> (shen.<pattern1> NewStream1242) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd (shen.pair (shen.tlhd V1253) (shen.hdtl V1253))) (cons @p (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ())))) (fail))) (fail)))) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (and (cons? (hd V1253)) (cons? (shen.hdhd V1253))) (if (and (cons? (hd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (= cons (shen.hdhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))))) (let NewStream1244 (shen.pair (shen.tlhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))) (shen.hdtl (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (let Parse_shen.<pattern1> (shen.<pattern1> NewStream1244) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd (shen.pair (shen.tlhd V1253) (shen.hdtl V1253))) (cons cons (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ())))) (fail))) (fail)))) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (and (cons? (hd V1253)) (cons? (shen.hdhd V1253))) (if (and (cons? (hd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (= @v (shen.hdhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))))) (let NewStream1246 (shen.pair (shen.tlhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))) (shen.hdtl (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (let Parse_shen.<pattern1> (shen.<pattern1> NewStream1246) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd (shen.pair (shen.tlhd V1253) (shen.hdtl V1253))) (cons @v (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ())))) (fail))) (fail)))) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (and (cons? (hd V1253)) (cons? (shen.hdhd V1253))) (if (and (cons? (hd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (= @s (shen.hdhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))))) (let NewStream1248 (shen.pair (shen.tlhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))) (shen.hdtl (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (let Parse_shen.<pattern1> (shen.<pattern1> NewStream1248) (if (not (= (fail) Parse_shen.<pattern1>)) (let Parse_shen.<pattern2> (shen.<pattern2> Parse_shen.<pattern1>) (if (not (= (fail) Parse_shen.<pattern2>)) (shen.pair (hd (shen.pair (shen.tlhd V1253) (shen.hdtl V1253))) (cons @s (cons (shen.hdtl Parse_shen.<pattern1>) (cons (shen.hdtl Parse_shen.<pattern2>) ())))) (fail))) (fail)))) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (and (cons? (hd V1253)) (cons? (shen.hdhd V1253))) (if (and (cons? (hd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (= vector (shen.hdhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))))) (let NewStream1250 (shen.pair (shen.tlhd (shen.pair (shen.hdhd V1253) (shen.hdtl V1253))) (shen.hdtl (shen.pair (shen.hdhd V1253) (shen.hdtl V1253)))) (if (and (cons? (hd NewStream1250)) (= 0 (shen.hdhd NewStream1250))) (let NewStream1251 (shen.pair (shen.tlhd NewStream1250) (shen.hdtl NewStream1250)) (shen.pair (hd (shen.pair (shen.tlhd V1253) (shen.hdtl V1253))) (cons vector (cons 0 ())))) (fail))) (fail)) (fail)) (if (= YaccParse (fail)) (let YaccParse (if (cons? (hd V1253)) (let Parse_X (shen.hdhd V1253) (if (cons? Parse_X) (shen.pair (hd (shen.pair (shen.tlhd V1253) (shen.hdtl V1253))) (shen.constructor-error Parse_X)) (fail))) (fail)) (if (= YaccParse (fail)) (let Parse_shen.<simple_pattern> (shen.<simple_pattern> V1253) (if (not (= (fail) Parse_shen.<simple_pattern>)) (shen.pair (hd Parse_shen.<simple_pattern>) (shen.hdtl Parse_shen.<simple_pattern>)) (fail))) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)) YaccParse)))

(defun shen.constructor-error (V1255) (simple-error (shen.app V1255 " is not a legitimate constructor
" shen.a)))

(defun shen.<simple_pattern> (V1257) (let YaccParse (if (cons? (hd V1257)) (let Parse_X (shen.hdhd V1257) (if (= Parse_X _) (shen.pair (hd (shen.pair (shen.tlhd V1257) (shen.hdtl V1257))) (gensym Parse_Y)) (fail))) (fail)) (if (= YaccParse (fail)) (if (cons? (hd V1257)) (let Parse_X (shen.hdhd V1257) (if (not (element? Parse_X (cons -> (cons <- ())))) (shen.pair (hd (shen.pair (shen.tlhd V1257) (shen.hdtl V1257))) Parse_X) (fail))) (fail)) YaccParse)))

(defun shen.<pattern1> (V1259) (let Parse_shen.<pattern> (shen.<pattern> V1259) (if (not (= (fail) Parse_shen.<pattern>)) (shen.pair (hd Parse_shen.<pattern>) (shen.hdtl Parse_shen.<pattern>)) (fail))))

(defun shen.<pattern2> (V1261) (let Parse_shen.<pattern> (shen.<pattern> V1261) (if (not (= (fail) Parse_shen.<pattern>)) (shen.pair (hd Parse_shen.<pattern>) (shen.hdtl Parse_shen.<pattern>)) (fail))))

(defun shen.<action> (V1263) (if (cons? (hd V1263)) (let Parse_X (shen.hdhd V1263) (shen.pair (hd (shen.pair (shen.tlhd V1263) (shen.hdtl V1263))) Parse_X)) (fail)))

(defun shen.<guard> (V1265) (if (cons? (hd V1265)) (let Parse_X (shen.hdhd V1265) (shen.pair (hd (shen.pair (shen.tlhd V1265) (shen.hdtl V1265))) Parse_X)) (fail)))

(defun shen.compile_to_machine_code (V1268 V1269) (let Lambda+ (shen.compile_to_lambda+ V1268 V1269) (let KL (shen.compile_to_kl V1268 Lambda+) (let Record (shen.record-source V1268 KL) KL))))

(defun shen.record-source (V1274 V1275) (cond ((value shen.*installing-kl*) shen.skip) (true (put V1274 shen.source V1275 (value *property-vector*)))))

(defun shen.compile_to_lambda+ (V1278 V1279) (let Arity (shen.aritycheck V1278 V1279) (let UpDateSymbolTable (shen.update-symbol-table V1278 Arity) (let Free (shen.for-each (lambda Rule (shen.free_variable_check V1278 Rule)) V1279) (let Variables (shen.parameters Arity) (let Strip (map (lambda X (shen.strip-protect X)) V1279) (let Abstractions (map (lambda X (shen.abstract_rule X)) Strip) (let Applications (map (lambda X (shen.application_build Variables X)) Abstractions) (cons Variables (cons Applications ()))))))))))

(defun shen.update-symbol-table (V1282 V1283) (cond ((= 0 V1283) shen.skip) (true (put V1282 shen.lambda-form (eval-kl (shen.lambda-form V1282 V1283)) (value *property-vector*)))))

(defun shen.free_variable_check (V1286 V1287) (cond ((and (cons? V1287) (and (cons? (tl V1287)) (= () (tl (tl V1287))))) (let Bound (shen.extract_vars (hd V1287)) (let Free (shen.extract_free_vars Bound (hd (tl V1287))) (shen.free_variable_warnings V1286 Free)))) (true (shen.f_error shen.free_variable_check))))

(defun shen.extract_vars (V1289) (cond ((variable? V1289) (cons V1289 ())) ((cons? V1289) (union (shen.extract_vars (hd V1289)) (shen.extract_vars (tl V1289)))) (true ())))

(defun shen.extract_free_vars (V1301 V1302) (cond ((and (cons? V1302) (and (cons? (tl V1302)) (and (= () (tl (tl V1302))) (= (hd V1302) protect)))) ()) ((and (variable? V1302) (not (element? V1302 V1301))) (cons V1302 ())) ((and (cons? V1302) (and (= lambda (hd V1302)) (and (cons? (tl V1302)) (and (cons? (tl (tl V1302))) (= () (tl (tl (tl V1302)))))))) (shen.extract_free_vars (cons (hd (tl V1302)) V1301) (hd (tl (tl V1302))))) ((and (cons? V1302) (and (= let (hd V1302)) (and (cons? (tl V1302)) (and (cons? (tl (tl V1302))) (and (cons? (tl (tl (tl V1302)))) (= () (tl (tl (tl (tl V1302)))))))))) (union (shen.extract_free_vars V1301 (hd (tl (tl V1302)))) (shen.extract_free_vars (cons (hd (tl V1302)) V1301) (hd (tl (tl (tl V1302))))))) ((cons? V1302) (union (shen.extract_free_vars V1301 (hd V1302)) (shen.extract_free_vars V1301 (tl V1302)))) (true ())))

(defun shen.free_variable_warnings (V1307 V1308) (cond ((= () V1308) _) (true (simple-error (cn "error: the following variables are free in " (shen.app V1307 (cn ": " (shen.app (shen.list_variables V1308) "" shen.a)) shen.a))))))

(defun shen.list_variables (V1310) (cond ((and (cons? V1310) (= () (tl V1310))) (cn (str (hd V1310)) ".")) ((cons? V1310) (cn (str (hd V1310)) (cn ", " (shen.list_variables (tl V1310))))) (true (shen.f_error shen.list_variables))))

(defun shen.strip-protect (V1312) (cond ((and (cons? V1312) (and (cons? (tl V1312)) (and (= () (tl (tl V1312))) (= (hd V1312) protect)))) (shen.strip-protect (hd (tl V1312)))) ((cons? V1312) (map (lambda Z (shen.strip-protect Z)) V1312)) (true V1312)))

(defun shen.linearise (V1314) (cond ((and (cons? V1314) (and (cons? (tl V1314)) (= () (tl (tl V1314))))) (shen.linearise_help (shen.flatten (hd V1314)) (hd V1314) (hd (tl V1314)))) (true (shen.f_error shen.linearise))))

(defun shen.flatten (V1316) (cond ((= () V1316) ()) ((cons? V1316) (append (shen.flatten (hd V1316)) (shen.flatten (tl V1316)))) (true (cons V1316 ()))))

(defun shen.linearise_help (V1320 V1321 V1322) (cond ((= () V1320) (cons V1321 (cons V1322 ()))) ((cons? V1320) (if (and (variable? (hd V1320)) (element? (hd V1320) (tl V1320))) (let Var (gensym (hd V1320)) (let NewAction (cons where (cons (cons = (cons (hd V1320) (cons Var ()))) (cons V1322 ()))) (let NewPatts (shen.linearise_X (hd V1320) Var V1321) (shen.linearise_help (tl V1320) NewPatts NewAction)))) (shen.linearise_help (tl V1320) V1321 V1322))) (true (shen.f_error shen.linearise_help))))

(defun shen.linearise_X (V1335 V1336 V1337) (cond ((= V1337 V1335) V1336) ((cons? V1337) (let L (shen.linearise_X V1335 V1336 (hd V1337)) (if (= L (hd V1337)) (cons (hd V1337) (shen.linearise_X V1335 V1336 (tl V1337))) (cons L (tl V1337))))) (true V1337)))

(defun shen.aritycheck (V1340 V1341) (cond ((and (cons? V1341) (and (cons? (hd V1341)) (and (cons? (tl (hd V1341))) (and (= () (tl (tl (hd V1341)))) (= () (tl V1341)))))) (do (shen.aritycheck-action (hd (tl (hd V1341)))) (shen.aritycheck-name V1340 (arity V1340) (length (hd (hd V1341)))))) ((and (cons? V1341) (and (cons? (hd V1341)) (and (cons? (tl (hd V1341))) (and (= () (tl (tl (hd V1341)))) (and (cons? (tl V1341)) (and (cons? (hd (tl V1341))) (and (cons? (tl (hd (tl V1341)))) (= () (tl (tl (hd (tl V1341)))))))))))) (if (= (length (hd (hd V1341))) (length (hd (hd (tl V1341))))) (do (shen.aritycheck-action (hd (tl (hd V1341)))) (shen.aritycheck V1340 (tl V1341))) (simple-error (cn "arity error in " (shen.app V1340 "
" shen.a))))) (true (shen.f_error shen.aritycheck))))

(defun shen.aritycheck-name (V1354 V1355 V1356) (cond ((= -1 V1355) V1356) ((= V1356 V1355) V1356) (true (do (shen.prhush (cn "
warning: changing the arity of " (shen.app V1354 " can cause errors.
" shen.a)) (stoutput)) V1356))))

(defun shen.aritycheck-action (V1362) (cond ((cons? V1362) (do (shen.aah (hd V1362) (tl V1362)) (shen.for-each (lambda Y (shen.aritycheck-action Y)) V1362))) (true shen.skip)))

(defun shen.aah (V1365 V1366) (let Arity (arity V1365) (let Len (length V1366) (if (and (> Arity -1) (> Len Arity)) (shen.prhush (cn "warning: " (shen.app V1365 (cn " might not like " (shen.app Len (cn " argument" (shen.app (if (> Len 1) "s" "") ".
" shen.a)) shen.a)) shen.a)) (stoutput)) shen.skip))))

(defun shen.abstract_rule (V1368) (cond ((and (cons? V1368) (and (cons? (tl V1368)) (= () (tl (tl V1368))))) (shen.abstraction_build (hd V1368) (hd (tl V1368)))) (true (shen.f_error shen.abstract_rule))))

(defun shen.abstraction_build (V1371 V1372) (cond ((= () V1371) V1372) ((cons? V1371) (cons /. (cons (hd V1371) (cons (shen.abstraction_build (tl V1371) V1372) ())))) (true (shen.f_error shen.abstraction_build))))

(defun shen.parameters (V1374) (cond ((= 0 V1374) ()) (true (cons (gensym V) (shen.parameters (- V1374 1))))))

(defun shen.application_build (V1377 V1378) (cond ((= () V1377) V1378) ((cons? V1377) (shen.application_build (tl V1377) (cons V1378 (cons (hd V1377) ())))) (true (shen.f_error shen.application_build))))

(defun shen.compile_to_kl (V1381 V1382) (cond ((and (cons? V1382) (and (cons? (tl V1382)) (= () (tl (tl V1382))))) (let Arity (shen.store-arity V1381 (length (hd V1382))) (let Reduce (map (lambda X (shen.reduce X)) (hd (tl V1382))) (let CondExpression (shen.cond-expression V1381 (hd V1382) Reduce) (let TypeTable (if (value shen.*optimise*) (shen.typextable (shen.get-type V1381) (hd V1382)) shen.skip) (let TypedCondExpression (if (value shen.*optimise*) (shen.assign-types (hd V1382) TypeTable CondExpression) CondExpression) (cons defun (cons V1381 (cons (hd V1382) (cons TypedCondExpression ())))))))))) (true (shen.f_error shen.compile_to_kl))))

(defun shen.get-type (V1388) (cond ((cons? V1388) shen.skip) (true (let FType (assoc V1388 (value shen.*signedfuncs*)) (if (empty? FType) shen.skip (tl FType))))))

(defun shen.typextable (V1399 V1400) (cond ((and (cons? V1399) (and (cons? (tl V1399)) (and (= --> (hd (tl V1399))) (and (cons? (tl (tl V1399))) (and (= () (tl (tl (tl V1399)))) (cons? V1400)))))) (if (variable? (hd V1399)) (shen.typextable (hd (tl (tl V1399))) (tl V1400)) (cons (cons (hd V1400) (hd V1399)) (shen.typextable (hd (tl (tl V1399))) (tl V1400))))) (true ())))

(defun shen.assign-types (V1404 V1405 V1406) (cond ((and (cons? V1406) (and (= let (hd V1406)) (and (cons? (tl V1406)) (and (cons? (tl (tl V1406))) (and (cons? (tl (tl (tl V1406)))) (= () (tl (tl (tl (tl V1406)))))))))) (cons let (cons (hd (tl V1406)) (cons (shen.assign-types V1404 V1405 (hd (tl (tl V1406)))) (cons (shen.assign-types (cons (hd (tl V1406)) V1404) V1405 (hd (tl (tl (tl V1406))))) ()))))) ((and (cons? V1406) (and (= lambda (hd V1406)) (and (cons? (tl V1406)) (and (cons? (tl (tl V1406))) (= () (tl (tl (tl V1406)))))))) (cons lambda (cons (hd (tl V1406)) (cons (shen.assign-types (cons (hd (tl V1406)) V1404) V1405 (hd (tl (tl V1406)))) ())))) ((and (cons? V1406) (= cond (hd V1406))) (cons cond (map (lambda Y (cons (shen.assign-types V1404 V1405 (hd Y)) (cons (shen.assign-types V1404 V1405 (hd (tl Y))) ()))) (tl V1406)))) ((cons? V1406) (let NewTable (shen.typextable (shen.get-type (hd V1406)) (tl V1406)) (cons (hd V1406) (map (lambda Y (shen.assign-types V1404 (append V1405 NewTable) Y)) (tl V1406))))) (true (let AtomType (assoc V1406 V1405) (if (cons? AtomType) (cons type (cons V1406 (cons (tl AtomType) ()))) (if (element? V1406 V1404) V1406 (shen.atom-type V1406)))))))

(defun shen.atom-type (V1408) (if (string? V1408) (cons type (cons V1408 (cons string ()))) (if (number? V1408) (cons type (cons V1408 (cons number ()))) (if (boolean? V1408) (cons type (cons V1408 (cons boolean ()))) (if (symbol? V1408) (cons type (cons V1408 (cons symbol ()))) V1408)))))

(defun shen.store-arity (V1413 V1414) (cond ((value shen.*installing-kl*) shen.skip) (true (put V1413 arity V1414 (value *property-vector*)))))

(defun shen.reduce (V1416) (do (set shen.*teststack* ()) (let Result (shen.reduce_help V1416) (cons (cons : (cons shen.tests (reverse (value shen.*teststack*)))) (cons Result ())))))

(defun shen.reduce_help (V1418) (cond ((and (cons? V1418) (and (cons? (hd V1418)) (and (= /. (hd (hd V1418))) (and (cons? (tl (hd V1418))) (and (cons? (hd (tl (hd V1418)))) (and (= cons (hd (hd (tl (hd V1418))))) (and (cons? (tl (hd (tl (hd V1418))))) (and (cons? (tl (tl (hd (tl (hd V1418)))))) (and (= () (tl (tl (tl (hd (tl (hd V1418))))))) (and (cons? (tl (tl (hd V1418)))) (and (= () (tl (tl (tl (hd V1418))))) (and (cons? (tl V1418)) (= () (tl (tl V1418))))))))))))))) (do (shen.add_test (cons cons? (tl V1418))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V1418))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V1418)))))) (cons (shen.ebr (hd (tl V1418)) (hd (tl (hd V1418))) (hd (tl (tl (hd V1418))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hd (tl V1418)) ())) (cons (cons tl (tl V1418)) ())) (shen.reduce_help Application))))) ((and (cons? V1418) (and (cons? (hd V1418)) (and (= /. (hd (hd V1418))) (and (cons? (tl (hd V1418))) (and (cons? (hd (tl (hd V1418)))) (and (= @p (hd (hd (tl (hd V1418))))) (and (cons? (tl (hd (tl (hd V1418))))) (and (cons? (tl (tl (hd (tl (hd V1418)))))) (and (= () (tl (tl (tl (hd (tl (hd V1418))))))) (and (cons? (tl (tl (hd V1418)))) (and (= () (tl (tl (tl (hd V1418))))) (and (cons? (tl V1418)) (= () (tl (tl V1418))))))))))))))) (do (shen.add_test (cons tuple? (tl V1418))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V1418))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V1418)))))) (cons (shen.ebr (hd (tl V1418)) (hd (tl (hd V1418))) (hd (tl (tl (hd V1418))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons fst (tl V1418)) ())) (cons (cons snd (tl V1418)) ())) (shen.reduce_help Application))))) ((and (cons? V1418) (and (cons? (hd V1418)) (and (= /. (hd (hd V1418))) (and (cons? (tl (hd V1418))) (and (cons? (hd (tl (hd V1418)))) (and (= @v (hd (hd (tl (hd V1418))))) (and (cons? (tl (hd (tl (hd V1418))))) (and (cons? (tl (tl (hd (tl (hd V1418)))))) (and (= () (tl (tl (tl (hd (tl (hd V1418))))))) (and (cons? (tl (tl (hd V1418)))) (and (= () (tl (tl (tl (hd V1418))))) (and (cons? (tl V1418)) (= () (tl (tl V1418))))))))))))))) (do (shen.add_test (cons shen.+vector? (tl V1418))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V1418))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V1418)))))) (cons (shen.ebr (hd (tl V1418)) (hd (tl (hd V1418))) (hd (tl (tl (hd V1418))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hdv (tl V1418)) ())) (cons (cons tlv (tl V1418)) ())) (shen.reduce_help Application))))) ((and (cons? V1418) (and (cons? (hd V1418)) (and (= /. (hd (hd V1418))) (and (cons? (tl (hd V1418))) (and (cons? (hd (tl (hd V1418)))) (and (= @s (hd (hd (tl (hd V1418))))) (and (cons? (tl (hd (tl (hd V1418))))) (and (cons? (tl (tl (hd (tl (hd V1418)))))) (and (= () (tl (tl (tl (hd (tl (hd V1418))))))) (and (cons? (tl (tl (hd V1418)))) (and (= () (tl (tl (tl (hd V1418))))) (and (cons? (tl V1418)) (= () (tl (tl V1418))))))))))))))) (do (shen.add_test (cons shen.+string? (tl V1418))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V1418))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V1418)))))) (cons (shen.ebr (hd (tl V1418)) (hd (tl (hd V1418))) (hd (tl (tl (hd V1418))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons pos (cons (hd (tl V1418)) (cons 0 ()))) ())) (cons (cons tlstr (tl V1418)) ())) (shen.reduce_help Application))))) ((and (cons? V1418) (and (cons? (hd V1418)) (and (= /. (hd (hd V1418))) (and (cons? (tl (hd V1418))) (and (cons? (tl (tl (hd V1418)))) (and (= () (tl (tl (tl (hd V1418))))) (and (cons? (tl V1418)) (and (= () (tl (tl V1418))) (not (variable? (hd (tl (hd V1418))))))))))))) (do (shen.add_test (cons = (cons (hd (tl (hd V1418))) (tl V1418)))) (shen.reduce_help (hd (tl (tl (hd V1418))))))) ((and (cons? V1418) (and (cons? (hd V1418)) (and (= /. (hd (hd V1418))) (and (cons? (tl (hd V1418))) (and (cons? (tl (tl (hd V1418)))) (and (= () (tl (tl (tl (hd V1418))))) (and (cons? (tl V1418)) (= () (tl (tl V1418)))))))))) (shen.reduce_help (shen.ebr (hd (tl V1418)) (hd (tl (hd V1418))) (hd (tl (tl (hd V1418))))))) ((and (cons? V1418) (and (= where (hd V1418)) (and (cons? (tl V1418)) (and (cons? (tl (tl V1418))) (= () (tl (tl (tl V1418)))))))) (do (shen.add_test (hd (tl V1418))) (shen.reduce_help (hd (tl (tl V1418)))))) ((and (cons? V1418) (and (cons? (tl V1418)) (= () (tl (tl V1418))))) (let Z (shen.reduce_help (hd V1418)) (if (= (hd V1418) Z) V1418 (shen.reduce_help (cons Z (tl V1418)))))) (true V1418)))

(defun shen.+string? (V1420) (cond ((= "" V1420) false) (true (string? V1420))))

(defun shen.+vector? (V1422) (and (absvector? V1422) (> (<-address V1422 0) 0)))

(defun shen.ebr (V1436 V1437 V1438) (cond ((= V1438 V1437) V1436) ((and (cons? V1438) (and (= /. (hd V1438)) (and (cons? (tl V1438)) (and (cons? (tl (tl V1438))) (and (= () (tl (tl (tl V1438)))) (> (occurrences V1437 (hd (tl V1438))) 0)))))) V1438) ((and (cons? V1438) (and (= lambda (hd V1438)) (and (cons? (tl V1438)) (and (cons? (tl (tl V1438))) (and (= () (tl (tl (tl V1438)))) (> (occurrences V1437 (hd (tl V1438))) 0)))))) V1438) ((and (cons? V1438) (and (= let (hd V1438)) (and (cons? (tl V1438)) (and (cons? (tl (tl V1438))) (and (cons? (tl (tl (tl V1438)))) (and (= () (tl (tl (tl (tl V1438))))) (= (hd (tl V1438)) V1437))))))) (cons let (cons (hd (tl V1438)) (cons (shen.ebr V1436 (hd (tl V1438)) (hd (tl (tl V1438)))) (tl (tl (tl V1438))))))) ((cons? V1438) (cons (shen.ebr V1436 V1437 (hd V1438)) (shen.ebr V1436 V1437 (tl V1438)))) (true V1438)))

(defun shen.add_test (V1440) (set shen.*teststack* (cons V1440 (value shen.*teststack*))))

(defun shen.cond-expression (V1444 V1445 V1446) (let Err (shen.err-condition V1444) (let Cases (shen.case-form V1446 Err) (let EncodeChoices (shen.encode-choices Cases V1444) (shen.cond-form EncodeChoices)))))

(defun shen.cond-form (V1450) (cond ((and (cons? V1450) (and (cons? (hd V1450)) (and (= true (hd (hd V1450))) (and (cons? (tl (hd V1450))) (= () (tl (tl (hd V1450)))))))) (hd (tl (hd V1450)))) (true (cons cond V1450))))

(defun shen.encode-choices (V1455 V1456) (cond ((= () V1455) ()) ((and (cons? V1455) (and (cons? (hd V1455)) (and (= true (hd (hd V1455))) (and (cons? (tl (hd V1455))) (and (cons? (hd (tl (hd V1455)))) (and (= shen.choicepoint! (hd (hd (tl (hd V1455))))) (and (cons? (tl (hd (tl (hd V1455))))) (and (= () (tl (tl (hd (tl (hd V1455)))))) (and (= () (tl (tl (hd V1455)))) (= () (tl V1455))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V1455))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (if (value shen.*installing-kl*) (cons shen.sys-error (cons V1456 ())) (cons shen.f_error (cons V1456 ()))) (cons Result ())))) ())))) ())) ())) ((and (cons? V1455) (and (cons? (hd V1455)) (and (= true (hd (hd V1455))) (and (cons? (tl (hd V1455))) (and (cons? (hd (tl (hd V1455)))) (and (= shen.choicepoint! (hd (hd (tl (hd V1455))))) (and (cons? (tl (hd (tl (hd V1455))))) (and (= () (tl (tl (hd (tl (hd V1455)))))) (= () (tl (tl (hd V1455)))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V1455))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (shen.cond-form (shen.encode-choices (tl V1455) V1456)) (cons Result ())))) ())))) ())) ())) ((and (cons? V1455) (and (cons? (hd V1455)) (and (cons? (tl (hd V1455))) (and (cons? (hd (tl (hd V1455)))) (and (= shen.choicepoint! (hd (hd (tl (hd V1455))))) (and (cons? (tl (hd (tl (hd V1455))))) (and (= () (tl (tl (hd (tl (hd V1455)))))) (= () (tl (tl (hd V1455))))))))))) (cons (cons true (cons (cons let (cons Freeze (cons (cons freeze (cons (shen.cond-form (shen.encode-choices (tl V1455) V1456)) ())) (cons (cons if (cons (hd (hd V1455)) (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V1455))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (cons thaw (cons Freeze ())) (cons Result ())))) ())))) (cons (cons thaw (cons Freeze ())) ())))) ())))) ())) ())) ((and (cons? V1455) (and (cons? (hd V1455)) (and (cons? (tl (hd V1455))) (= () (tl (tl (hd V1455))))))) (cons (hd V1455) (shen.encode-choices (tl V1455) V1456))) (true (shen.f_error shen.encode-choices))))

(defun shen.case-form (V1463 V1464) (cond ((= () V1463) (cons V1464 ())) ((and (cons? V1463) (and (cons? (hd V1463)) (and (cons? (hd (hd V1463))) (and (= : (hd (hd (hd V1463)))) (and (cons? (tl (hd (hd V1463)))) (and (= shen.tests (hd (tl (hd (hd V1463))))) (and (= () (tl (tl (hd (hd V1463))))) (and (cons? (tl (hd V1463))) (and (cons? (hd (tl (hd V1463)))) (and (= shen.choicepoint! (hd (hd (tl (hd V1463))))) (and (cons? (tl (hd (tl (hd V1463))))) (and (= () (tl (tl (hd (tl (hd V1463)))))) (= () (tl (tl (hd V1463)))))))))))))))) (cons (cons true (tl (hd V1463))) (shen.case-form (tl V1463) V1464))) ((and (cons? V1463) (and (cons? (hd V1463)) (and (cons? (hd (hd V1463))) (and (= : (hd (hd (hd V1463)))) (and (cons? (tl (hd (hd V1463)))) (and (= shen.tests (hd (tl (hd (hd V1463))))) (and (= () (tl (tl (hd (hd V1463))))) (and (cons? (tl (hd V1463))) (= () (tl (tl (hd V1463)))))))))))) (cons (cons true (tl (hd V1463))) ())) ((and (cons? V1463) (and (cons? (hd V1463)) (and (cons? (hd (hd V1463))) (and (= : (hd (hd (hd V1463)))) (and (cons? (tl (hd (hd V1463)))) (and (= shen.tests (hd (tl (hd (hd V1463))))) (and (cons? (tl (hd V1463))) (= () (tl (tl (hd V1463))))))))))) (cons (cons (shen.embed-and (tl (tl (hd (hd V1463))))) (tl (hd V1463))) (shen.case-form (tl V1463) V1464))) (true (shen.f_error shen.case-form))))

(defun shen.embed-and (V1466) (cond ((and (cons? V1466) (= () (tl V1466))) (hd V1466)) ((cons? V1466) (cons and (cons (hd V1466) (cons (shen.embed-and (tl V1466)) ())))) (true (shen.f_error shen.embed-and))))

(defun shen.err-condition (V1468) (cons true (cons (cons shen.f_error (cons V1468 ())) ())))

(defun shen.sys-error (V1470) (simple-error (cn "system function " (shen.app V1470 ": unexpected argument
" shen.a))))