"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 pr) 2) (define (kl:pr V4031 V4032) (guard (lambda (E) V4031) (lambda () (kl:shen.prh V4031 V4032 0)))) (quote pr)) (begin (register-function-arity (quote shen.prh) 3) (define (kl:shen.prh V4036 V4037 V4038) (kl:shen.prh V4036 V4037 (kl:shen.write-char-and-inc V4036 V4037 V4038))) (quote shen.prh)) (begin (register-function-arity (quote shen.write-char-and-inc) 3) (define (kl:shen.write-char-and-inc V4042 V4043 V4044) (begin (kl:write-byte (kl:string->n (make-string 1 (string-ref V4042 V4044))) V4043) (+ V4044 1))) (quote shen.write-char-and-inc)) (begin (register-function-arity (quote print) 1) (define (kl:print V4046) (let ((String (kl:shen.insert V4046 "~S"))) (let ((Print (kl:shen.prhush String (kl:stoutput)))) V4046))) (quote print)) (begin (register-function-arity (quote shen.prhush) 2) (define (kl:shen.prhush V4049 V4050) (if (assert-boolean (kl:value (quote *hush*))) V4049 (kl:pr V4049 V4050))) (quote shen.prhush)) (begin (register-function-arity (quote shen.mkstr) 2) (define (kl:shen.mkstr V4053 V4054) (cond ((string? V4053) (kl:shen.mkstr-l (kl:shen.proc-nl V4053) V4054)) (#t (kl:shen.mkstr-r (cons (quote shen.proc-nl) (cons V4053 (quote ()))) V4054)))) (quote shen.mkstr)) (begin (register-function-arity (quote shen.mkstr-l) 2) (define (kl:shen.mkstr-l V4057 V4058) (cond ((null? V4058) V4057) ((pair? V4058) (kl:shen.mkstr-l (kl:shen.insert-l (car V4058) V4057) (cdr V4058))) (#t (kl:shen.f_error (quote shen.mkstr-l))))) (quote shen.mkstr-l)) (begin (register-function-arity (quote shen.insert-l) 2) (define (kl:shen.insert-l V4063 V4064) (cond ((equal? "" V4064) "") ((and (assert-boolean (kl:shen.+string? V4064)) (and (equal? "~" (make-string 1 (string-ref V4064 0))) (and (assert-boolean (kl:shen.+string? (kl:tlstr V4064))) (equal? "A" (make-string 1 (string-ref (kl:tlstr V4064) 0)))))) (cons (quote shen.app) (cons V4063 (cons (kl:tlstr (kl:tlstr V4064)) (cons (quote shen.a) (quote ())))))) ((and (assert-boolean (kl:shen.+string? V4064)) (and (equal? "~" (make-string 1 (string-ref V4064 0))) (and (assert-boolean (kl:shen.+string? (kl:tlstr V4064))) (equal? "R" (make-string 1 (string-ref (kl:tlstr V4064) 0)))))) (cons (quote shen.app) (cons V4063 (cons (kl:tlstr (kl:tlstr V4064)) (cons (quote shen.r) (quote ())))))) ((and (assert-boolean (kl:shen.+string? V4064)) (and (equal? "~" (make-string 1 (string-ref V4064 0))) (and (assert-boolean (kl:shen.+string? (kl:tlstr V4064))) (equal? "S" (make-string 1 (string-ref (kl:tlstr V4064) 0)))))) (cons (quote shen.app) (cons V4063 (cons (kl:tlstr (kl:tlstr V4064)) (cons (quote shen.s) (quote ())))))) ((assert-boolean (kl:shen.+string? V4064)) (kl:shen.factor-cn (cons (quote cn) (cons (make-string 1 (string-ref V4064 0)) (cons (kl:shen.insert-l V4063 (kl:tlstr V4064)) (quote ())))))) ((and (pair? V4064) (and (eq? (quote cn) (car V4064)) (and (pair? (cdr V4064)) (and (pair? (cdr (cdr V4064))) (null? (cdr (cdr (cdr V4064)))))))) (cons (quote cn) (cons (car (cdr V4064)) (cons (kl:shen.insert-l V4063 (car (cdr (cdr V4064)))) (quote ()))))) ((and (pair? V4064) (and (eq? (quote shen.app) (car V4064)) (and (pair? (cdr V4064)) (and (pair? (cdr (cdr V4064))) (and (pair? (cdr (cdr (cdr V4064)))) (null? (cdr (cdr (cdr (cdr V4064)))))))))) (cons (quote shen.app) (cons (car (cdr V4064)) (cons (kl:shen.insert-l V4063 (car (cdr (cdr V4064)))) (cdr (cdr (cdr V4064))))))) (#t (kl:shen.f_error (quote shen.insert-l))))) (quote shen.insert-l)) (begin (register-function-arity (quote shen.factor-cn) 1) (define (kl:shen.factor-cn V4066) (cond ((and (pair? V4066) (and (eq? (quote cn) (car V4066)) (and (pair? (cdr V4066)) (and (pair? (cdr (cdr V4066))) (and (pair? (car (cdr (cdr V4066)))) (and (eq? (quote cn) (car (car (cdr (cdr V4066))))) (and (pair? (cdr (car (cdr (cdr V4066))))) (and (pair? (cdr (cdr (car (cdr (cdr V4066)))))) (and (null? (cdr (cdr (cdr (car (cdr (cdr V4066))))))) (and (null? (cdr (cdr (cdr V4066)))) (and (string? (car (cdr V4066))) (string? (car (cdr (car (cdr (cdr V4066))))))))))))))))) (cons (quote cn) (cons (string-append (car (cdr V4066)) (car (cdr (car (cdr (cdr V4066)))))) (cdr (cdr (car (cdr (cdr V4066)))))))) (#t V4066))) (quote shen.factor-cn)) (begin (register-function-arity (quote shen.proc-nl) 1) (define (kl:shen.proc-nl V4068) (cond ((equal? "" V4068) "") ((and (assert-boolean (kl:shen.+string? V4068)) (and (equal? "~" (make-string 1 (string-ref V4068 0))) (and (assert-boolean (kl:shen.+string? (kl:tlstr V4068))) (equal? "%" (make-string 1 (string-ref (kl:tlstr V4068) 0)))))) (string-append (kl:n->string 10) (kl:shen.proc-nl (kl:tlstr (kl:tlstr V4068))))) ((assert-boolean (kl:shen.+string? V4068)) (string-append (make-string 1 (string-ref V4068 0)) (kl:shen.proc-nl (kl:tlstr V4068)))) (#t (kl:shen.f_error (quote shen.proc-nl))))) (quote shen.proc-nl)) (begin (register-function-arity (quote shen.mkstr-r) 2) (define (kl:shen.mkstr-r V4071 V4072) (cond ((null? V4072) V4071) ((pair? V4072) (kl:shen.mkstr-r (cons (quote shen.insert) (cons (car V4072) (cons V4071 (quote ())))) (cdr V4072))) (#t (kl:shen.f_error (quote shen.mkstr-r))))) (quote shen.mkstr-r)) (begin (register-function-arity (quote shen.insert) 2) (define (kl:shen.insert V4075 V4076) (kl:shen.insert-h V4075 V4076 "")) (quote shen.insert)) (begin (register-function-arity (quote shen.insert-h) 3) (define (kl:shen.insert-h V4082 V4083 V4084) (cond ((equal? "" V4083) V4084) ((and (assert-boolean (kl:shen.+string? V4083)) (and (equal? "~" (make-string 1 (string-ref V4083 0))) (and (assert-boolean (kl:shen.+string? (kl:tlstr V4083))) (equal? "A" (make-string 1 (string-ref (kl:tlstr V4083) 0)))))) (string-append V4084 (kl:shen.app V4082 (kl:tlstr (kl:tlstr V4083)) (quote shen.a)))) ((and (assert-boolean (kl:shen.+string? V4083)) (and (equal? "~" (make-string 1 (string-ref V4083 0))) (and (assert-boolean (kl:shen.+string? (kl:tlstr V4083))) (equal? "R" (make-string 1 (string-ref (kl:tlstr V4083) 0)))))) (string-append V4084 (kl:shen.app V4082 (kl:tlstr (kl:tlstr V4083)) (quote shen.r)))) ((and (assert-boolean (kl:shen.+string? V4083)) (and (equal? "~" (make-string 1 (string-ref V4083 0))) (and (assert-boolean (kl:shen.+string? (kl:tlstr V4083))) (equal? "S" (make-string 1 (string-ref (kl:tlstr V4083) 0)))))) (string-append V4084 (kl:shen.app V4082 (kl:tlstr (kl:tlstr V4083)) (quote shen.s)))) ((assert-boolean (kl:shen.+string? V4083)) (kl:shen.insert-h V4082 (kl:tlstr V4083) (string-append V4084 (make-string 1 (string-ref V4083 0))))) (#t (kl:shen.f_error (quote shen.insert-h))))) (quote shen.insert-h)) (begin (register-function-arity (quote shen.app) 3) (define (kl:shen.app V4088 V4089 V4090) (string-append (kl:shen.arg->str V4088 V4090) V4089)) (quote shen.app)) (begin (register-function-arity (quote shen.arg->str) 2) (define (kl:shen.arg->str V4098 V4099) (cond ((eq? V4098 (quote shen.fail!)) "...") ((assert-boolean (kl:shen.list? V4098)) (kl:shen.list->str V4098 V4099)) ((string? V4098) (kl:shen.str->str V4098 V4099)) ((vector? V4098) (kl:shen.vector->str V4098 V4099)) (#t (kl:shen.atom->str V4098)))) (quote shen.arg->str)) (begin (register-function-arity (quote shen.list->str) 2) (define (kl:shen.list->str V4102 V4103) (cond ((eq? (quote shen.r) V4103) (kl:_scheme_at_s "(" (kl:_scheme_at_s (kl:shen.iter-list V4102 (quote shen.r) (kl:shen.maxseq)) ")"))) (#t (kl:_scheme_at_s "[" (kl:_scheme_at_s (kl:shen.iter-list V4102 V4103 (kl:shen.maxseq)) "]"))))) (quote shen.list->str)) (begin (register-function-arity (quote shen.maxseq) 0) (define (kl:shen.maxseq) (kl:value (quote *maximum-print-sequence-size*))) (quote shen.maxseq)) (begin (register-function-arity (quote shen.iter-list) 3) (define (kl:shen.iter-list V4117 V4118 V4119) (cond ((null? V4117) "") ((kl:= 0 V4119) "... etc") ((and (pair? V4117) (null? (cdr V4117))) (kl:shen.arg->str (car V4117) V4118)) ((pair? V4117) (kl:_scheme_at_s (kl:shen.arg->str (car V4117) V4118) (kl:_scheme_at_s " " (kl:shen.iter-list (cdr V4117) V4118 (- V4119 1))))) (#t (kl:_scheme_at_s "|" (kl:_scheme_at_s " " (kl:shen.arg->str V4117 V4118)))))) (quote shen.iter-list)) (begin (register-function-arity (quote shen.str->str) 2) (define (kl:shen.str->str V4126 V4127) (cond ((eq? (quote shen.a) V4127) V4126) (#t (kl:_scheme_at_s (kl:n->string 34) (kl:_scheme_at_s V4126 (kl:n->string 34)))))) (quote shen.str->str)) (begin (register-function-arity (quote shen.vector->str) 2) (define (kl:shen.vector->str V4130 V4131) (if (assert-boolean (kl:shen.print-vector? V4130)) ((kl:function (vector-ref V4130 0)) V4130) (if (assert-boolean (kl:vector? V4130)) (kl:_scheme_at_s "<" (kl:_scheme_at_s (kl:shen.iter-vector V4130 1 V4131 (kl:shen.maxseq)) ">")) (kl:_scheme_at_s "<" (kl:_scheme_at_s "<" (kl:_scheme_at_s (kl:shen.iter-vector V4130 0 V4131 (kl:shen.maxseq)) ">>")))))) (quote shen.vector->str)) (begin (register-function-arity (quote shen.print-vector?) 1) (define (kl:shen.print-vector? V4133) (let ((Zero (vector-ref V4133 0))) (if (eq? Zero (quote shen.tuple)) #t (if (eq? Zero (quote shen.pvar)) #t (if (eq? Zero (quote shen.dictionary)) #t (if (kl:not (number? Zero)) (kl:shen.fbound? Zero) #f)))))) (quote shen.print-vector?)) (begin (register-function-arity (quote shen.fbound?) 1) (define (kl:shen.fbound? V4135) (guard (lambda (E) #f) (lambda () (begin (kl:shen.lookup-func V4135) #t)))) (quote shen.fbound?)) (begin (register-function-arity (quote shen.tuple) 1) (define (kl:shen.tuple V4137) (string-append "(@p " (kl:shen.app (vector-ref V4137 1) (string-append " " (kl:shen.app (vector-ref V4137 2) ")" (quote shen.s))) (quote shen.s)))) (quote shen.tuple)) (begin (register-function-arity (quote shen.dictionary) 1) (define (kl:shen.dictionary V4139) "(dict ...)") (quote shen.dictionary)) (begin (register-function-arity (quote shen.iter-vector) 4) (define (kl:shen.iter-vector V4150 V4151 V4152 V4153) (cond ((kl:= 0 V4153) "... etc") (#t (let ((Item (guard (lambda (E) (quote shen.out-of-bounds)) (lambda () (vector-ref V4150 V4151))))) (let ((Next (guard (lambda (E) (quote shen.out-of-bounds)) (lambda () (vector-ref V4150 (+ V4151 1)))))) (if (eq? Item (quote shen.out-of-bounds)) "" (if (eq? Next (quote shen.out-of-bounds)) (kl:shen.arg->str Item V4152) (kl:_scheme_at_s (kl:shen.arg->str Item V4152) (kl:_scheme_at_s " " (kl:shen.iter-vector V4150 (+ V4151 1) V4152 (- V4153 1))))))))))) (quote shen.iter-vector)) (begin (register-function-arity (quote shen.atom->str) 1) (define (kl:shen.atom->str V4155) (guard (lambda (E) (kl:shen.funexstring)) (lambda () (kl:str V4155)))) (quote shen.atom->str)) (begin (register-function-arity (quote shen.funexstring) 0) (define (kl:shen.funexstring) (kl:_scheme_at_s "\x10" (kl:_scheme_at_s "f" (kl:_scheme_at_s "u" (kl:_scheme_at_s "n" (kl:_scheme_at_s "e" (kl:_scheme_at_s (kl:shen.arg->str (kl:gensym (kl:intern "x")) (quote shen.a)) "\x11"))))))) (quote shen.funexstring)) (begin (register-function-arity (quote shen.list?) 1) (define (kl:shen.list? V4157) (or (kl:empty? V4157) (pair? V4157))) (quote shen.list?))