"Copyright (c) 2015, Mark Tarver\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n1. Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n2. Redistributions in binary form must reproduce the above copyright\n notice, this list of conditions and the following disclaimer in the\n documentation and/or other materials provided with the distribution.\n3. The name of Mark Tarver may not be used to endorse or promote products\n derived from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY\nEXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\nWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY\nDIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\n(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\nLOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\nON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\nSOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." (begin (register-function-arity (quote macroexpand) 1) (define (kl:macroexpand V1545) (let ((Y (kl:shen.compose (kl:value (quote *macros*)) V1545))) (if (kl:= V1545 Y) V1545 (kl:shen.walk (lambda (Z) (kl:macroexpand Z)) Y)))) (quote macroexpand)) (begin (register-function-arity (quote shen.error-macro) 1) (define (kl:shen.error-macro V1547) (cond ((and (pair? V1547) (and (eq? (quote error) (car V1547)) (pair? (cdr V1547)))) (cons (quote simple-error) (cons (kl:shen.mkstr (car (cdr V1547)) (cdr (cdr V1547))) (quote ())))) (#t V1547))) (quote shen.error-macro)) (begin (register-function-arity (quote shen.output-macro) 1) (define (kl:shen.output-macro V1549) (cond ((and (pair? V1549) (and (eq? (quote output) (car V1549)) (pair? (cdr V1549)))) (cons (quote shen.prhush) (cons (kl:shen.mkstr (car (cdr V1549)) (cdr (cdr V1549))) (cons (cons (quote stoutput) (quote ())) (quote ()))))) ((and (pair? V1549) (and (eq? (quote pr) (car V1549)) (and (pair? (cdr V1549)) (null? (cdr (cdr V1549)))))) (cons (quote pr) (cons (car (cdr V1549)) (cons (cons (quote stoutput) (quote ())) (quote ()))))) (#t V1549))) (quote shen.output-macro)) (begin (register-function-arity (quote shen.make-string-macro) 1) (define (kl:shen.make-string-macro V1551) (cond ((and (pair? V1551) (and (eq? (quote make-string) (car V1551)) (pair? (cdr V1551)))) (kl:shen.mkstr (car (cdr V1551)) (cdr (cdr V1551)))) (#t V1551))) (quote shen.make-string-macro)) (begin (register-function-arity (quote shen.input-macro) 1) (define (kl:shen.input-macro V1553) (cond ((and (pair? V1553) (and (eq? (quote lineread) (car V1553)) (null? (cdr V1553)))) (cons (quote lineread) (cons (cons (quote stinput) (quote ())) (quote ())))) ((and (pair? V1553) (and (eq? (quote input) (car V1553)) (null? (cdr V1553)))) (cons (quote input) (cons (cons (quote stinput) (quote ())) (quote ())))) ((and (pair? V1553) (and (eq? (quote read) (car V1553)) (null? (cdr V1553)))) (cons (quote read) (cons (cons (quote stinput) (quote ())) (quote ())))) ((and (pair? V1553) (and (eq? (quote input+) (car V1553)) (and (pair? (cdr V1553)) (null? (cdr (cdr V1553)))))) (cons (quote input+) (cons (car (cdr V1553)) (cons (cons (quote stinput) (quote ())) (quote ()))))) ((and (pair? V1553) (and (eq? (quote read-byte) (car V1553)) (null? (cdr V1553)))) (cons (quote read-byte) (cons (cons (quote stinput) (quote ())) (quote ())))) (#t V1553))) (quote shen.input-macro)) (begin (register-function-arity (quote shen.compose) 2) (define (kl:shen.compose V1556 V1557) (cond ((null? V1556) V1557) ((pair? V1556) (kl:shen.compose (cdr V1556) ((car V1556) V1557))) (#t (kl:shen.f_error (quote shen.compose))))) (quote shen.compose)) (begin (register-function-arity (quote shen.compile-macro) 1) (define (kl:shen.compile-macro V1559) (cond ((and (pair? V1559) (and (eq? (quote compile) (car V1559)) (and (pair? (cdr V1559)) (and (pair? (cdr (cdr V1559))) (null? (cdr (cdr (cdr V1559)))))))) (cons (quote compile) (cons (car (cdr V1559)) (cons (car (cdr (cdr V1559))) (cons (cons (quote lambda) (cons (quote E) (cons (cons (quote if) (cons (cons (quote cons?) (cons (quote E) (quote ()))) (cons (cons (quote error) (cons "parse error here: ~S~%" (cons (quote E) (quote ())))) (cons (cons (quote error) (cons "parse error~%" (quote ()))) (quote ()))))) (quote ())))) (quote ())))))) (#t V1559))) (quote shen.compile-macro)) (begin (register-function-arity (quote shen.prolog-macro) 1) (define (kl:shen.prolog-macro V1561) (cond ((and (pair? V1561) (eq? (quote prolog?) (car V1561))) (cons (quote let) (cons (quote NPP) (cons (cons (quote shen.start-new-prolog-process) (quote ())) (cons (let ((Calls (kl:shen.bld-prolog-call (quote NPP) (cdr V1561)))) (let ((Vs (kl:shen.extract_vars (cdr V1561)))) (let ((External (kl:shen.externally-bound (cdr V1561)))) (let ((PrologVs (kl:difference Vs External))) (kl:shen.locally-bind-prolog-vs (quote NPP) PrologVs Calls))))) (quote ())))))) (#t V1561))) (quote shen.prolog-macro)) (begin (register-function-arity (quote shen.externally-bound) 1) (define (kl:shen.externally-bound V1567) (cond ((and (pair? V1567) (and (eq? (quote receive) (car V1567)) (and (pair? (cdr V1567)) (null? (cdr (cdr V1567)))))) (cdr V1567)) ((pair? V1567) (kl:union (kl:shen.externally-bound (car V1567)) (kl:shen.externally-bound (cdr V1567)))) (#t (quote ())))) (quote shen.externally-bound)) (begin (register-function-arity (quote shen.locally-bind-prolog-vs) 3) (define (kl:shen.locally-bind-prolog-vs V1585 V1586 V1587) (cond ((null? V1586) V1587) ((pair? V1586) (cons (quote let) (cons (car V1586) (cons (cons (quote shen.newpv) (cons V1585 (quote ()))) (cons (kl:shen.locally-bind-prolog-vs V1585 (cdr V1586) V1587) (quote ())))))) (#t (simple-error "implementation error inp locally-bind-prolog-vs")))) (quote shen.locally-bind-prolog-vs)) (begin (register-function-arity (quote shen.bld-prolog-call) 2) (define (kl:shen.bld-prolog-call V1600 V1601) (cond ((null? V1601) #t) ((and (pair? V1601) (eq? (quote !) (car V1601))) (cons (quote cut) (cons #f (cons V1600 (cons (cons (quote freeze) (cons (kl:shen.bld-prolog-call V1600 (cdr V1601)) (quote ()))) (quote ())))))) ((and (pair? V1601) (and (pair? (car V1601)) (and (eq? (quote when) (car (car V1601))) (and (pair? (cdr (car V1601))) (null? (cdr (cdr (car V1601)))))))) (cons (quote fwhen) (cons (kl:shen.insert-deref (car (cdr (car V1601))) V1600) (cons V1600 (cons (cons (quote freeze) (cons (kl:shen.bld-prolog-call V1600 (cdr V1601)) (quote ()))) (quote ())))))) ((and (pair? V1601) (and (pair? (car V1601)) (and (eq? (quote is) (car (car V1601))) (and (pair? (cdr (car V1601))) (and (pair? (cdr (cdr (car V1601)))) (null? (cdr (cdr (cdr (car V1601)))))))))) (cons (quote bind) (cons (car (cdr (car V1601))) (cons (kl:shen.insert-deref (car (cdr (cdr (car V1601)))) V1600) (cons V1600 (cons (cons (quote freeze) (cons (kl:shen.bld-prolog-call V1600 (cdr V1601)) (quote ()))) (quote ()))))))) ((and (pair? V1601) (and (pair? (car V1601)) (and (eq? (quote receive) (car (car V1601))) (and (pair? (cdr (car V1601))) (null? (cdr (cdr (car V1601)))))))) (kl:shen.bld-prolog-call V1600 (cdr V1601))) ((and (pair? V1601) (and (pair? (car V1601)) (and (eq? (quote bind) (car (car V1601))) (and (pair? (cdr (car V1601))) (and (pair? (cdr (cdr (car V1601)))) (null? (cdr (cdr (cdr (car V1601)))))))))) (cons (quote bind) (cons (car (cdr (car V1601))) (cons (kl:shen.insert-lazyderef (car (cdr (cdr (car V1601)))) V1600) (cons V1600 (cons (cons (quote freeze) (cons (kl:shen.bld-prolog-call V1600 (cdr V1601)) (quote ()))) (quote ()))))))) ((and (pair? V1601) (and (pair? (car V1601)) (and (eq? (quote fwhen) (car (car V1601))) (and (pair? (cdr (car V1601))) (null? (cdr (cdr (car V1601)))))))) (cons (quote fwhen) (cons (kl:shen.insert-lazyderef (car (cdr (car V1601))) V1600) (cons V1600 (cons (cons (quote freeze) (cons (kl:shen.bld-prolog-call V1600 (cdr V1601)) (quote ()))) (quote ())))))) ((pair? V1601) (kl:append (car V1601) (cons V1600 (cons (cons (quote freeze) (cons (kl:shen.bld-prolog-call V1600 (cdr V1601)) (quote ()))) (quote ()))))) (#t (simple-error "implementation error in bld-prolog-call")))) (quote shen.bld-prolog-call)) (begin (register-function-arity (quote shen.defprolog-macro) 1) (define (kl:shen.defprolog-macro V1603) (cond ((and (pair? V1603) (and (eq? (quote defprolog) (car V1603)) (pair? (cdr V1603)))) (kl:compile (lambda (Y) (kl:shen. Y)) (cdr V1603) (lambda (Y) (kl:shen.prolog-error (car (cdr V1603)) Y)))) (#t V1603))) (quote shen.defprolog-macro)) (begin (register-function-arity (quote shen.datatype-macro) 1) (define (kl:shen.datatype-macro V1605) (cond ((and (pair? V1605) (and (eq? (quote datatype) (car V1605)) (pair? (cdr V1605)))) (cons (quote shen.process-datatype) (cons (kl:shen.intern-type (car (cdr V1605))) (cons (cons (quote compile) (cons (cons (quote lambda) (cons (quote X) (cons (cons (quote shen.) (cons (quote X) (quote ()))) (quote ())))) (cons (kl:shen.rcons_form (cdr (cdr V1605))) (cons (cons (quote function) (cons (quote shen.datatype-error) (quote ()))) (quote ()))))) (quote ()))))) (#t V1605))) (quote shen.datatype-macro)) (begin (register-function-arity (quote shen.intern-type) 1) (define (kl:shen.intern-type V1607) (kl:intern (string-append "type#" (kl:str V1607)))) (quote shen.intern-type)) (begin (register-function-arity (quote shen._scheme_at_s-macro) 1) (define (kl:shen._scheme_at_s-macro V1609) (cond ((and (pair? V1609) (and (eq? (quote _scheme_at_s) (car V1609)) (and (pair? (cdr V1609)) (and (pair? (cdr (cdr V1609))) (pair? (cdr (cdr (cdr V1609)))))))) (cons (quote _scheme_at_s) (cons (car (cdr V1609)) (cons (kl:shen._scheme_at_s-macro (cons (quote _scheme_at_s) (cdr (cdr V1609)))) (quote ()))))) ((and (pair? V1609) (and (eq? (quote _scheme_at_s) (car V1609)) (and (pair? (cdr V1609)) (and (pair? (cdr (cdr V1609))) (and (null? (cdr (cdr (cdr V1609)))) (string? (car (cdr V1609)))))))) (let ((E (kl:explode (car (cdr V1609))))) (if (> (kl:length E) 1) (kl:shen._scheme_at_s-macro (cons (quote _scheme_at_s) (kl:append E (cdr (cdr V1609))))) V1609))) (#t V1609))) (quote shen._scheme_at_s-macro)) (begin (register-function-arity (quote shen.synonyms-macro) 1) (define (kl:shen.synonyms-macro V1611) (cond ((and (pair? V1611) (eq? (quote synonyms) (car V1611))) (cons (quote shen.synonyms-help) (cons (kl:shen.rcons_form (kl:shen.curry-synonyms (cdr V1611))) (quote ())))) (#t V1611))) (quote shen.synonyms-macro)) (begin (register-function-arity (quote shen.curry-synonyms) 1) (define (kl:shen.curry-synonyms V1613) (kl:map (lambda (X) (kl:shen.curry-type X)) V1613)) (quote shen.curry-synonyms)) (begin (register-function-arity (quote shen.nl-macro) 1) (define (kl:shen.nl-macro V1615) (cond ((and (pair? V1615) (and (eq? (quote nl) (car V1615)) (null? (cdr V1615)))) (cons (quote nl) (cons 1 (quote ())))) (#t V1615))) (quote shen.nl-macro)) (begin (register-function-arity (quote shen.assoc-macro) 1) (define (kl:shen.assoc-macro V1617) (cond ((and (pair? V1617) (and (pair? (cdr V1617)) (and (pair? (cdr (cdr V1617))) (and (pair? (cdr (cdr (cdr V1617)))) (kl:element? (car V1617) (cons (quote _scheme_at_p) (cons (quote _scheme_at_v) (cons (quote append) (cons (quote and) (cons (quote or) (cons (quote +) (cons (quote *) (cons (quote do) (quote ())))))))))))))) (cons (car V1617) (cons (car (cdr V1617)) (cons (kl:shen.assoc-macro (cons (car V1617) (cdr (cdr V1617)))) (quote ()))))) (#t V1617))) (quote shen.assoc-macro)) (begin (register-function-arity (quote shen.let-macro) 1) (define (kl:shen.let-macro V1619) (cond ((and (pair? V1619) (and (eq? (quote let) (car V1619)) (and (pair? (cdr V1619)) (and (pair? (cdr (cdr V1619))) (and (pair? (cdr (cdr (cdr V1619)))) (pair? (cdr (cdr (cdr (cdr V1619)))))))))) (cons (quote let) (cons (car (cdr V1619)) (cons (car (cdr (cdr V1619))) (cons (kl:shen.let-macro (cons (quote let) (cdr (cdr (cdr V1619))))) (quote ())))))) (#t V1619))) (quote shen.let-macro)) (begin (register-function-arity (quote shen.abs-macro) 1) (define (kl:shen.abs-macro V1621) (cond ((and (pair? V1621) (and (eq? (quote /.) (car V1621)) (and (pair? (cdr V1621)) (and (pair? (cdr (cdr V1621))) (pair? (cdr (cdr (cdr V1621)))))))) (cons (quote lambda) (cons (car (cdr V1621)) (cons (kl:shen.abs-macro (cons (quote /.) (cdr (cdr V1621)))) (quote ()))))) ((and (pair? V1621) (and (eq? (quote /.) (car V1621)) (and (pair? (cdr V1621)) (and (pair? (cdr (cdr V1621))) (null? (cdr (cdr (cdr V1621)))))))) (cons (quote lambda) (cdr V1621))) (#t V1621))) (quote shen.abs-macro)) (begin (register-function-arity (quote shen.cases-macro) 1) (define (kl:shen.cases-macro V1625) (cond ((and (pair? V1625) (and (eq? (quote cases) (car V1625)) (and (pair? (cdr V1625)) (and (kl:= #t (car (cdr V1625))) (pair? (cdr (cdr V1625))))))) (car (cdr (cdr V1625)))) ((and (pair? V1625) (and (eq? (quote cases) (car V1625)) (and (pair? (cdr V1625)) (and (pair? (cdr (cdr V1625))) (null? (cdr (cdr (cdr V1625)))))))) (cons (quote if) (cons (car (cdr V1625)) (cons (car (cdr (cdr V1625))) (cons (cons (quote simple-error) (cons "error: cases exhausted" (quote ()))) (quote ())))))) ((and (pair? V1625) (and (eq? (quote cases) (car V1625)) (and (pair? (cdr V1625)) (pair? (cdr (cdr V1625)))))) (cons (quote if) (cons (car (cdr V1625)) (cons (car (cdr (cdr V1625))) (cons (kl:shen.cases-macro (cons (quote cases) (cdr (cdr (cdr V1625))))) (quote ())))))) ((and (pair? V1625) (and (eq? (quote cases) (car V1625)) (and (pair? (cdr V1625)) (null? (cdr (cdr V1625)))))) (simple-error "error: odd number of case elements\n")) (#t V1625))) (quote shen.cases-macro)) (begin (register-function-arity (quote shen.timer-macro) 1) (define (kl:shen.timer-macro V1627) (cond ((and (pair? V1627) (and (eq? (quote time) (car V1627)) (and (pair? (cdr V1627)) (null? (cdr (cdr V1627)))))) (kl:shen.let-macro (cons (quote let) (cons (quote Start) (cons (cons (quote get-time) (cons (quote run) (quote ()))) (cons (quote Result) (cons (car (cdr V1627)) (cons (quote Finish) (cons (cons (quote get-time) (cons (quote run) (quote ()))) (cons (quote Time) (cons (cons (quote -) (cons (quote Finish) (cons (quote Start) (quote ())))) (cons (quote Message) (cons (cons (quote shen.prhush) (cons (cons (quote cn) (cons "\nrun time: " (cons (cons (quote cn) (cons (cons (quote str) (cons (quote Time) (quote ()))) (cons " secs\n" (quote ())))) (quote ())))) (cons (cons (quote stoutput) (quote ())) (quote ())))) (cons (quote Result) (quote ()))))))))))))))) (#t V1627))) (quote shen.timer-macro)) (begin (register-function-arity (quote shen.tuple-up) 1) (define (kl:shen.tuple-up V1629) (cond ((pair? V1629) (cons (quote _scheme_at_p) (cons (car V1629) (cons (kl:shen.tuple-up (cdr V1629)) (quote ()))))) (#t V1629))) (quote shen.tuple-up)) (begin (register-function-arity (quote shen.put/get-macro) 1) (define (kl:shen.put/get-macro V1631) (cond ((and (pair? V1631) (and (eq? (quote put) (car V1631)) (and (pair? (cdr V1631)) (and (pair? (cdr (cdr V1631))) (and (pair? (cdr (cdr (cdr V1631)))) (null? (cdr (cdr (cdr (cdr V1631)))))))))) (cons (quote put) (cons (car (cdr V1631)) (cons (car (cdr (cdr V1631))) (cons (car (cdr (cdr (cdr V1631)))) (cons (cons (quote value) (cons (quote *property-vector*) (quote ()))) (quote ()))))))) ((and (pair? V1631) (and (eq? (quote get) (car V1631)) (and (pair? (cdr V1631)) (and (pair? (cdr (cdr V1631))) (null? (cdr (cdr (cdr V1631)))))))) (cons (quote get) (cons (car (cdr V1631)) (cons (car (cdr (cdr V1631))) (cons (cons (quote value) (cons (quote *property-vector*) (quote ()))) (quote ())))))) ((and (pair? V1631) (and (eq? (quote unput) (car V1631)) (and (pair? (cdr V1631)) (and (pair? (cdr (cdr V1631))) (null? (cdr (cdr (cdr V1631)))))))) (cons (quote unput) (cons (car (cdr V1631)) (cons (car (cdr (cdr V1631))) (cons (cons (quote value) (cons (quote *property-vector*) (quote ()))) (quote ())))))) (#t V1631))) (quote shen.put/get-macro)) (begin (register-function-arity (quote shen.function-macro) 1) (define (kl:shen.function-macro V1633) (cond ((and (pair? V1633) (and (eq? (quote function) (car V1633)) (and (pair? (cdr V1633)) (null? (cdr (cdr V1633)))))) (kl:shen.function-abstraction (car (cdr V1633)) (kl:arity (car (cdr V1633))))) (#t V1633))) (quote shen.function-macro)) (begin (register-function-arity (quote shen.function-abstraction) 2) (define (kl:shen.function-abstraction V1636 V1637) (cond ((kl:= 0 V1637) (simple-error (kl:shen.app V1636 " has no lambda form\n" (quote shen.a)))) ((kl:= -1 V1637) (cons (quote function) (cons V1636 (quote ())))) (#t (kl:shen.function-abstraction-help V1636 V1637 (quote ()))))) (quote shen.function-abstraction)) (begin (register-function-arity (quote shen.function-abstraction-help) 3) (define (kl:shen.function-abstraction-help V1641 V1642 V1643) (cond ((kl:= 0 V1642) (cons V1641 V1643)) (#t (let ((X (kl:gensym (quote V)))) (cons (quote /.) (cons X (cons (kl:shen.function-abstraction-help V1641 (- V1642 1) (kl:append V1643 (cons X (quote ())))) (quote ())))))))) (quote shen.function-abstraction-help)) (begin (register-function-arity (quote undefmacro) 1) (define (kl:undefmacro V1645) (let ((MacroReg (kl:value (quote shen.*macroreg*)))) (let ((Pos (kl:shen.findpos V1645 MacroReg))) (let ((Remove1 (kl:set (quote shen.*macroreg*) (kl:remove V1645 MacroReg)))) (let ((Remove2 (kl:set (quote *macros*) (kl:shen.remove-nth Pos (kl:value (quote *macros*)))))) V1645))))) (quote undefmacro)) (begin (register-function-arity (quote shen.findpos) 2) (define (kl:shen.findpos V1655 V1656) (cond ((null? V1656) (simple-error (kl:shen.app V1655 " is not a macro\n" (quote shen.a)))) ((and (pair? V1656) (kl:= (car V1656) V1655)) 1) ((pair? V1656) (+ 1 (kl:shen.findpos V1655 (cdr V1656)))) (#t (kl:shen.f_error (quote shen.findpos))))) (quote shen.findpos)) (begin (register-function-arity (quote shen.remove-nth) 2) (define (kl:shen.remove-nth V1661 V1662) (cond ((and (kl:= 1 V1661) (pair? V1662)) (cdr V1662)) ((pair? V1662) (cons (car V1662) (kl:shen.remove-nth (- V1661 1) (cdr V1662)))) (#t (kl:shen.f_error (quote shen.remove-nth))))) (quote shen.remove-nth))