"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 declare (V18597 V18598) (let Record (set shen.*signedfuncs* (cons (cons V18597 V18598) (value shen.*signedfuncs*))) (let Variancy (trap-error (shen.variancy-test V18597 V18598) (lambda E shen.skip)) (let Type (shen.rcons_form (shen.demodulate V18598)) (let F* (concat shen.type-signature-of- V18597) (let Parameters (shen.parameters 1) (let Clause (cons (cons F* (cons X ())) (cons :- (cons (cons (cons unify! (cons X (cons Type ()))) ()) ()))) (let AUM_instruction (shen.aum Clause Parameters) (let Code (shen.aum_to_shen AUM_instruction) (let ShenDef (cons define (cons F* (append Parameters (append (cons ProcessN (cons Continuation ())) (cons -> (cons Code ())))))) (let Eval (shen.eval-without-macros ShenDef) V18597))))))))))) (defun shen.demodulate (V18600) (trap-error (let Demod (shen.walk (lambda Y (shen.demod Y)) V18600) (if (= Demod V18600) V18600 (shen.demodulate Demod))) (lambda E V18600))) (defun shen.variancy-test (V18603 V18604) (let TypeF (shen.typecheck V18603 B) (let Check (if (= symbol TypeF) shen.skip (if (shen.variant? TypeF V18604) shen.skip (shen.prhush (cn "warning: changing the type of " (shen.app V18603 " may create errors " shen.a)) (stoutput)))) shen.skip))) (defun shen.variant? (V18617 V18618) (cond ((= V18618 V18617) true) ((and (cons? V18617) (and (cons? V18618) (= (hd V18618) (hd V18617)))) (shen.variant? (tl V18617) (tl V18618))) ((and (cons? V18617) (and (cons? V18618) (and (shen.pvar? (hd V18617)) (variable? (hd V18618))))) (shen.variant? (subst shen.a (hd V18617) (tl V18617)) (subst shen.a (hd V18618) (tl V18618)))) ((and (cons? V18617) (and (cons? (hd V18617)) (and (cons? V18618) (cons? (hd V18618))))) (shen.variant? (append (hd V18617) (tl V18617)) (append (hd V18618) (tl V18618)))) (true false))) (declare absvector? (cons A (cons --> (cons boolean ())))) (declare adjoin (cons A (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) (declare and (cons boolean (cons --> (cons (cons boolean (cons --> (cons boolean ()))) ())))) (declare shen.app (cons A (cons --> (cons (cons string (cons --> (cons (cons symbol (cons --> (cons string ()))) ()))) ())))) (declare append (cons (cons list (cons A ())) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) (declare arity (cons A (cons --> (cons number ())))) (declare assoc (cons A (cons --> (cons (cons (cons list (cons (cons list (cons A ())) ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) (declare boolean? (cons A (cons --> (cons boolean ())))) (declare bound? (cons symbol (cons --> (cons boolean ())))) (declare cd (cons string (cons --> (cons string ())))) (declare close (cons (cons stream (cons A ())) (cons --> (cons (cons list (cons B ())) ())))) (declare cn (cons string (cons --> (cons (cons string (cons --> (cons string ()))) ())))) (declare compile (cons (cons A (cons shen.==> (cons B ()))) (cons --> (cons (cons A (cons --> (cons (cons (cons A (cons --> (cons B ()))) (cons --> (cons B ()))) ()))) ())))) (declare cons? (cons A (cons --> (cons boolean ())))) (declare destroy (cons (cons A (cons --> (cons B ()))) (cons --> (cons symbol ())))) (declare difference (cons (cons list (cons A ())) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) (declare do (cons A (cons --> (cons (cons B (cons --> (cons B ()))) ())))) (declare (cons (cons list (cons A ())) (cons shen.==> (cons (cons list (cons B ())) ())))) (declare shen. (cons (cons list (cons A ())) (cons shen.==> (cons (cons list (cons A ())) ())))) (declare element? (cons A (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons boolean ()))) ())))) (declare empty? (cons A (cons --> (cons boolean ())))) (declare enable-type-theory (cons symbol (cons --> (cons boolean ())))) (declare external (cons symbol (cons --> (cons (cons list (cons symbol ())) ())))) (declare error-to-string (cons exception (cons --> (cons string ())))) (declare explode (cons A (cons --> (cons (cons list (cons string ())) ())))) (declare fail (cons --> (cons symbol ()))) (declare fail-if (cons (cons symbol (cons --> (cons boolean ()))) (cons --> (cons (cons symbol (cons --> (cons symbol ()))) ())))) (declare fix (cons (cons A (cons --> (cons A ()))) (cons --> (cons (cons A (cons --> (cons A ()))) ())))) (declare freeze (cons A (cons --> (cons (cons lazy (cons A ())) ())))) (declare fst (cons (cons A (cons * (cons B ()))) (cons --> (cons A ())))) (declare function (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons A (cons --> (cons B ()))) ())))) (declare gensym (cons symbol (cons --> (cons symbol ())))) (declare <-vector (cons (cons vector (cons A ())) (cons --> (cons (cons number (cons --> (cons A ()))) ())))) (declare vector-> (cons (cons vector (cons A ())) (cons --> (cons (cons number (cons --> (cons (cons A (cons --> (cons (cons vector (cons A ())) ()))) ()))) ())))) (declare vector (cons number (cons --> (cons (cons vector (cons A ())) ())))) (declare get-time (cons symbol (cons --> (cons number ())))) (declare hash (cons A (cons --> (cons (cons number (cons --> (cons number ()))) ())))) (declare head (cons (cons list (cons A ())) (cons --> (cons A ())))) (declare hdv (cons (cons vector (cons A ())) (cons --> (cons A ())))) (declare hdstr (cons string (cons --> (cons string ())))) (declare if (cons boolean (cons --> (cons (cons A (cons --> (cons (cons A (cons --> (cons A ()))) ()))) ())))) (declare it (cons --> (cons string ()))) (declare implementation (cons --> (cons string ()))) (declare include (cons (cons list (cons symbol ())) (cons --> (cons (cons list (cons symbol ())) ())))) (declare include-all-but (cons (cons list (cons symbol ())) (cons --> (cons (cons list (cons symbol ())) ())))) (declare inferences (cons --> (cons number ()))) (declare shen.insert (cons A (cons --> (cons (cons string (cons --> (cons string ()))) ())))) (declare integer? (cons A (cons --> (cons boolean ())))) (declare intersection (cons (cons list (cons A ())) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) (declare kill (cons --> (cons A ()))) (declare language (cons --> (cons string ()))) (declare length (cons (cons list (cons A ())) (cons --> (cons number ())))) (declare limit (cons (cons vector (cons A ())) (cons --> (cons number ())))) (declare load (cons string (cons --> (cons symbol ())))) (declare map (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons B ())) ()))) ())))) (declare mapcan (cons (cons A (cons --> (cons (cons list (cons B ())) ()))) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons B ())) ()))) ())))) (declare maxinferences (cons number (cons --> (cons number ())))) (declare n->string (cons number (cons --> (cons string ())))) (declare nl (cons number (cons --> (cons number ())))) (declare not (cons boolean (cons --> (cons boolean ())))) (declare nth (cons number (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons A ()))) ())))) (declare number? (cons A (cons --> (cons boolean ())))) (declare occurrences (cons A (cons --> (cons (cons B (cons --> (cons number ()))) ())))) (declare occurs-check (cons symbol (cons --> (cons boolean ())))) (declare optimise (cons symbol (cons --> (cons boolean ())))) (declare or (cons boolean (cons --> (cons (cons boolean (cons --> (cons boolean ()))) ())))) (declare os (cons --> (cons string ()))) (declare package? (cons symbol (cons --> (cons boolean ())))) (declare port (cons --> (cons string ()))) (declare porters (cons --> (cons string ()))) (declare pos (cons string (cons --> (cons (cons number (cons --> (cons string ()))) ())))) (declare pr (cons string (cons --> (cons (cons (cons stream (cons out ())) (cons --> (cons string ()))) ())))) (declare print (cons A (cons --> (cons A ())))) (declare profile (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons A (cons --> (cons B ()))) ())))) (declare preclude (cons (cons list (cons symbol ())) (cons --> (cons (cons list (cons symbol ())) ())))) (declare shen.proc-nl (cons string (cons --> (cons string ())))) (declare profile-results (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons (cons A (cons --> (cons B ()))) (cons * (cons number ()))) ())))) (declare protect (cons symbol (cons --> (cons symbol ())))) (declare preclude-all-but (cons (cons list (cons symbol ())) (cons --> (cons (cons list (cons symbol ())) ())))) (declare shen.prhush (cons string (cons --> (cons (cons (cons stream (cons out ())) (cons --> (cons string ()))) ())))) (declare ps (cons symbol (cons --> (cons (cons list (cons unit ())) ())))) (declare read (cons (cons stream (cons in ())) (cons --> (cons unit ())))) (declare read-byte (cons (cons stream (cons in ())) (cons --> (cons number ())))) (declare read-file-as-bytelist (cons string (cons --> (cons (cons list (cons number ())) ())))) (declare read-file-as-string (cons string (cons --> (cons string ())))) (declare read-file (cons string (cons --> (cons (cons list (cons unit ())) ())))) (declare read-from-string (cons string (cons --> (cons (cons list (cons unit ())) ())))) (declare release (cons --> (cons string ()))) (declare remove (cons A (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) (declare reverse (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ())))) (declare simple-error (cons string (cons --> (cons A ())))) (declare snd (cons (cons A (cons * (cons B ()))) (cons --> (cons B ())))) (declare specialise (cons symbol (cons --> (cons symbol ())))) (declare spy (cons symbol (cons --> (cons boolean ())))) (declare step (cons symbol (cons --> (cons boolean ())))) (declare stinput (cons --> (cons (cons stream (cons in ())) ()))) (declare stoutput (cons --> (cons (cons stream (cons out ())) ()))) (declare string? (cons A (cons --> (cons boolean ())))) (declare str (cons A (cons --> (cons string ())))) (declare string->n (cons string (cons --> (cons number ())))) (declare string->symbol (cons string (cons --> (cons symbol ())))) (declare sum (cons (cons list (cons number ())) (cons --> (cons number ())))) (declare symbol? (cons A (cons --> (cons boolean ())))) (declare systemf (cons symbol (cons --> (cons symbol ())))) (declare tail (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ())))) (declare tlstr (cons string (cons --> (cons string ())))) (declare tlv (cons (cons vector (cons A ())) (cons --> (cons (cons vector (cons A ())) ())))) (declare tc (cons symbol (cons --> (cons boolean ())))) (declare tc? (cons --> (cons boolean ()))) (declare thaw (cons (cons lazy (cons A ())) (cons --> (cons A ())))) (declare track (cons symbol (cons --> (cons symbol ())))) (declare trap-error (cons A (cons --> (cons (cons (cons exception (cons --> (cons A ()))) (cons --> (cons A ()))) ())))) (declare tuple? (cons A (cons --> (cons boolean ())))) (declare undefmacro (cons symbol (cons --> (cons symbol ())))) (declare union (cons (cons list (cons A ())) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons list (cons A ())) ()))) ())))) (declare unprofile (cons (cons A (cons --> (cons B ()))) (cons --> (cons (cons A (cons --> (cons B ()))) ())))) (declare untrack (cons symbol (cons --> (cons symbol ())))) (declare unspecialise (cons symbol (cons --> (cons symbol ())))) (declare variable? (cons A (cons --> (cons boolean ())))) (declare vector? (cons A (cons --> (cons boolean ())))) (declare version (cons --> (cons string ()))) (declare write-to-file (cons string (cons --> (cons (cons A (cons --> (cons A ()))) ())))) (declare write-byte (cons number (cons --> (cons (cons (cons stream (cons out ())) (cons --> (cons number ()))) ())))) (declare y-or-n? (cons string (cons --> (cons boolean ())))) (declare > (cons number (cons --> (cons (cons number (cons --> (cons boolean ()))) ())))) (declare < (cons number (cons --> (cons (cons number (cons --> (cons boolean ()))) ())))) (declare >= (cons number (cons --> (cons (cons number (cons --> (cons boolean ()))) ())))) (declare <= (cons number (cons --> (cons (cons number (cons --> (cons boolean ()))) ())))) (declare = (cons A (cons --> (cons (cons A (cons --> (cons boolean ()))) ())))) (declare + (cons number (cons --> (cons (cons number (cons --> (cons number ()))) ())))) (declare / (cons number (cons --> (cons (cons number (cons --> (cons number ()))) ())))) (declare - (cons number (cons --> (cons (cons number (cons --> (cons number ()))) ())))) (declare * (cons number (cons --> (cons (cons number (cons --> (cons number ()))) ())))) (declare == (cons A (cons --> (cons (cons B (cons --> (cons boolean ()))) ()))))