diff --git a/README.md b/README.md index ad280b1..19cd68b 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# 神.java | Shen for Java +# 神.java | Shen for Java (Shen 16) http://shenlanguage.org/ @@ -17,21 +17,22 @@ See also: [shen.clj](https://github.com/hraberg/shen.clj) ## This Java Port -**Shen.java is an [invokedynamic](http://www.slideshare.net/CharlesNutter/jax-2012-invoke-dynamic-keynote) based [K Lambda](http://www.shenlanguage.org/documentation/shendoc.htm) compiler.** I don't vouch for any of the implementation details regarding this - I'm learning as we go. All code lives in [`Shen.java`](https://github.com/hraberg/Shen.java/blob/master/src/shen/Shen.java). It passes the Shen test suite. - -The main [Shen JVM port](https://www.assembla.com/code/shen-on-java/git/nodes) is done by Joel Shellman and might be used for [Babel](http://www.shenlanguage.org/babel/babel.htm), Mark's IDE project. +**Shen.java is an [invokedynamic](http://www.slideshare.net/CharlesNutter/jax-2012-invoke-dynamic-keynote) based [K Lambda](http://www.shenlanguage.org/documentation/shendoc.htm) compiler.** All code lives in [`Shen.java`](https://github.com/hraberg/Shen.java/blob/master/src/shen/Shen.java). It passes the Shen test suite. This port is loosely based on [`shen.clj`](https://github.com/hraberg/shen.clj), but has no dependency on Clojure. Started as an [interpreter](https://github.com/hraberg/Shen.java/blob/2359095c59435597e5761c72dbe9f0246fad0864/src/shen/Shen.java) using [MethodHandles](http://docs.oracle.com/javase/7/docs/api/java/lang/invoke/MethodHandle.html) as a primitive. It's about 2x faster than `shen.clj`. -This is pretty experimental, and this entire project acts as a playground for various JDK 8 and JVM language stuff. There's an IntelliJ project, which requires [IDEA 12](http://www.jetbrains.com/idea/download/index.html) and [JDK 8 with Lambda support](http://jdk8.java.net/lambda/) (b98 - there are often small but breaking changes). It's based on this [Maven project](https://github.com/hraberg/Shen.java/blob/master/pom.xml). +Core requirements : +* [JDK 8u40 Build b06](https://jdk8.java.net/download.html). Thanks to Vicente Arturo Romero Zaldivar of Oracle Corporation for fixing [bug JDK-8046357](https://bugs.openjdk.java.net/browse/JDK-8046357) +* [Maven](http://maven.apache.org/). See [Maven project file](https://github.com/artella-coding/Shen.java/blob/master/pom.xml). + +Optional requirements : There's an IntelliJ project, which requires [IDEA 12](http://www.jetbrains.com/idea/download/index.html). -JDK 8 with lamdba can be downloaded at the following locations : -* [Latest JDK 8 with lambda](https://jdk8.java.net/lambda/) -* [Older releases of JDK 8 with lamdba](http://download.java.net/lambda/) ### To run the REPL: +#### In Linux : + export JAVA_HOME=/path/to/jdk1.8.0/with/lambdas ./shen.java @@ -69,22 +70,62 @@ JDK 8 with lamdba can be downloaded at the following locations : (/. X (integer? (/ X 3)))) [0 3 6 9 12 15 18 21 24 27 30 33 36 39 42 45 48 51 54 57 60... etc] +#### In Windows XP & 7 : + +* Click "Download ZIP" button at https://github.com/artella-coding/Shen.java. +Alternatively : https://github.com/artella-coding/Shen.java/archive/master.zip. + +* Download Apache maven from http://maven.apache.org/download.cgi & extract. +Suppose extracted directory is C:\Program Files\maven\apache-maven-2.2.1. + +* Download jdk8 from https://jdk8.java.net/download.html + + To extract in Windows 7 simply unzip. + + To extract in Windows XP : + + * Right click on jdk-8-fcs-bin-b129-windows-i586-07_feb_2014.exe + + * Choose 7-Zip, then choose 'extract to "jdk-8-fcs-bin-b129-windows-i586-07_feb_2014"'. Suppose extracted dictory is : + + C:\Program Files\jdk-8-fcs-bin-b129-windows-i586-07_feb_2014 + + * Then within extracted directory, choose tools.zip, right click, choose 7-Zip, and "Extract Here". + + Then create a file run.bat with the following contents at the top level of the jdk directory : + + @echo off + + set "JAVA_HOME=C:\Program Files\jdk-8-fcs-bin-b129-windows-i586-07_feb_2014" + + FOR /R %%f IN (*.pack) DO "%JAVA_HOME%\bin\unpack200.exe" -r -v "%%f" "%%~pf%%~nf.jar" + + and run it. + +* In **buildAndRunWindows.bat** : + + * Set **JAVA_HOME** appropriately (i.e. C:\Program Files\jdk-8-fcs-bin-b129-windows-i586-07_feb_2014 if performed as above). + * Set **MAVEN_HOME** appropriately (i.e. C:\Program Files\maven\apache-maven-2.2.1) if performed as above). + +Then first run of **buildAndRunWindows.bat** performs build. +Subsequent invocations runs the repl. + ### The Shen Test Suite -Now passes. It is run at the end of the build: +Passes all tests. It is run at the end of the build: ./build # or ./tests if the jar already exists. [... loads of output ...] - passed ... 146 + passed ... 128 failed ...0 pass rate ...100.0% ok 0 - run time: 9.882 secs + run time: 37.771 secs It's close to 2x faster than [`shen.clj`](https://github.com/hraberg/shen.clj). diff --git a/buildAndRunWindows.bat b/buildAndRunWindows.bat new file mode 100755 index 0000000..6a20cce --- /dev/null +++ b/buildAndRunWindows.bat @@ -0,0 +1,23 @@ +@echo off + +set "JAVA_HOME=C:\Program Files\jdk-8-fcs-bin-b129-windows-i586-07_feb_2014" +set "MAVEN_HOME=C:\Program Files\maven\apache-maven-2.2.1" + +IF NOT EXIST "%JAVA_HOME%" ( + echo "%JAVA_HOME% does not exist" + EXIT /B +) + +IF NOT EXIST "%MAVEN_HOME%" ( + echo "%MAVEN_HOME% does not exist" + EXIT /B +) + +IF EXIST "./target/shen.java-0.1.0-SNAPSHOT.jar" ( + echo "Project has been already been build. See ./target directory" +) ELSE ( + echo "Building project" + "%MAVEN_HOME%\bin\mvn.bat" package +) + +"%JAVA_HOME%\bin\java" -Xss1000K -jar target/shen.java-0.1.0-SNAPSHOT.jar diff --git a/errors.shen b/errors.shen new file mode 100644 index 0000000..b6c186a --- /dev/null +++ b/errors.shen @@ -0,0 +1,6 @@ +\\To make errors disappear uncomment out the +\\line below + +\\(load "errors_oldProlog.shen") + +(load "errors_illustrate.shen") diff --git a/errors_debug.shen b/errors_debug.shen new file mode 100644 index 0000000..c09eec3 --- /dev/null +++ b/errors_debug.shen @@ -0,0 +1,43 @@ +\* +See following two posts : + +https://groups.google.com/d/msg/qilang/3DXJWo0hcRc/wNUU5OKdDMkJ + +https://groups.google.com/d/msg/qilang/9WxbCbxg8f4/dJsJtLmREkcJ + +Note that you can only track functions which are not made +external. For example if you add "bind" to the list below, +Shen complains that it is not a legitimate function name +*\ + +(package shen [] + +\\from prolog.shen +(define deref + [X | Y] ProcessN -> [(deref X ProcessN) | (deref Y ProcessN)] + X ProcessN -> (if (pvar? X) + (let Value (valvector X ProcessN) + (if (= Value -null-) + X + (deref Value ProcessN))) + X)) + +\\from prolog.shen +(define lazyderef + X ProcessN -> (if (pvar? X) + (let Value (valvector X ProcessN) + (if (= Value -null-) + X + (lazyderef Value ProcessN))) + X)) +\* +\\from prolog.shen +(define bind + X Y ProcessN Continuation -> (do (bindv X Y ProcessN) + (let Result (thaw Continuation) + (do (unbindv X ProcessN) + Result)))) +*\ +) + +(map (function track) [shen.deref shen.lazyderef]) diff --git a/errors_illustrate.shen b/errors_illustrate.shen new file mode 100644 index 0000000..c6b0040 --- /dev/null +++ b/errors_illustrate.shen @@ -0,0 +1,88 @@ +\\See errors.shen file + +(defprolog mem + X [X | _] <--; + X [Y | Z] <-- (mem X Z);) + +\* +The mem function above works fine. However +it is the mem function below which, in conjunction with +the new form of the prolog-macro, and the +"(return X)" which seems to cause the error. +Tracking the mem function shows that it returns +fine. +*\ + +(defprolog mem + X (mode [X | _] -) <--; + X (mode [_ | Y] -) <-- (mem X Y);) + +\* +(defun mem (V542 V543 V544 V545) + (let Case + (let V531 (shen.lazyderef V543 V544) + (if (cons? V531) + (let X (hd V531) (do (shen.incinfs) (unify! X V542 V544 V545))) + false)) + (if (= Case false) + (let V532 (shen.lazyderef V543 V544) + (if (cons? V532) (let Y (tl V532) (do (shen.incinfs) (mem V542 Y V544 V545))) false)) + Case))) +*\ + +\\This line causes the problem +(prolog? (mem 1 [X | 2]) (return X)) + +\* + +Note that the following works fine : + +(prolog? (mem 1 [X | 2]) (return [X])) +(prolog? (return 2)) +(prolog? (mem 1 [X | 2]) (return "2")) +(prolog? (mem 1 [X | 2]) (return Y)) +(prolog? (mem "1" [X | 2]) (return X)) + +But the following does not : + +(prolog? (mem 1 [X | 2]) (return 2)) + +Also if you track mem, then the line above works fine. +But as soon as you untrack, the error returns. To see +this do : + +(track mem) + +(prolog? (mem 1 [X | 2]) (return X)) + +(untrack mem) + +(prolog? (mem 1 [X | 2]) (return X)) + +See also the post at : + +https://groups.google.com/d/msg/qilang/3DXJWo0hcRc/Q5iXoYaF-FsJ + +*****[EXTRA BRACKET PHENOMENON]***** + +Also found if you define mem as (notice extra brackets around +"(mem X Y)"): + +(defprolog mem + X (mode [X | _] -) <--; + X (mode [_ | Y] -) <-- ((mem X Y));) + +(prolog? (mem 1 [X | 2]) (return X)) + +then the problem line of code works fine. You can also +put the extra brackets upon the invocation of mem i.e +the following code works fine : + +(defprolog mem + X (mode [X | _] -) <--; + X (mode [_ | Y] -) <-- (mem X Y);) + +\\Notice extra brackets below +(prolog? ((mem 1 [X | 2])) (return X)) + +*\ diff --git a/errors_oldProlog.shen b/errors_oldProlog.shen new file mode 100644 index 0000000..e1f898e --- /dev/null +++ b/errors_oldProlog.shen @@ -0,0 +1,15 @@ +\\See errors.shen file +\\overwriting prolog-macro with old +\\version seems to get rid of errors. + +(package shen [] + +\\This is the old prolog-macro +(define prolog-macro + [prolog? | X] -> [intprolog (prolog-form X)] + X -> X) + +(define prolog-form + X -> (cons_form (map (function cons_form) X))) + +) diff --git a/shen.java b/shen.java index 2d9ce40..f6aac25 100755 --- a/shen.java +++ b/shen.java @@ -2,7 +2,15 @@ rlwrap=$(which rlwrap) || "" &> /dev/null java="$rlwrap $JAVA_HOME/bin/java $JAVA_OPTS" -shen="find . -name shen.java-*.jar" -test -z `$shen` && mvn package -$java -Xss500k -jar `$shen` +if [ "`which shen.java`" != "" ]; then + DIR=$(dirname `which shen.java`) + echo "Using installation in "$DIR +else + DIR="." +fi + +shen="find $DIR -name shen.java-*.jar" + +test -z `$shen` && mvn -f $DIR"/pom.xml" package +$java -Xss1000k -jar `$shen` diff --git a/shen/Test Programs/Chap13/problems.txt b/shen/Test Programs/Chap13/problems.txt deleted file mode 100644 index 9eba58b..0000000 --- a/shen/Test Programs/Chap13/problems.txt +++ /dev/null @@ -1,26 +0,0 @@ - -[[[y-combinator [/. ADD [/. X [/. Y [if [= X 0] Y [[ADD [-- X]] [++ Y]]]]]]] 2] 3] - - -[[[y-combinator [/. ADD [/. X [/. Y [if [= X 0] Y [[ADD [-- X]] [++ Y]]]]]]] 33] 4] - -[[[/. [@p X Y] X] -[y-combinator [/. T -[@p [/. A [cases [[/. 1 false] A] - [[/. X [[[/. [@p X Y] Y] T] [-- X]]] A]]] - [/. A [cases [[/. 1 true] A] - [[/. X [[[/. [@p X Y] X] T] [-- X]]] A]]]]]]] 6] - - - - - - - - - - - - - - diff --git a/shen/Test Programs/einstein.shen b/shen/Test Programs/einstein.shen index 51a7363..ad1d4a5 100644 --- a/shen/Test Programs/einstein.shen +++ b/shen/Test Programs/einstein.shen @@ -29,5 +29,6 @@ X Y List <-- (iright Y X List);) (defprolog iright - L R [L | [R | _]] <--; - L R [_ | Rest] <-- (iright L R Rest);) \ No newline at end of file + L R (mode [L | [R | _]] -) <--; + L R (mode [_ | Rest] -) <-- (iright L R Rest);) + diff --git a/shen/Test Programs/qmachine.shen b/shen/Test Programs/qmachine.shen index 50122ed..e68ea08 100644 --- a/shen/Test Programs/qmachine.shen +++ b/shen/Test Programs/qmachine.shen @@ -34,15 +34,15 @@ (define forall {(progression A) --> (A --> boolean) --> boolean} - Progression P -> (super Progression P and true)) + Progression P -> (super Progression P (function and) true)) (define exists {(progression A) --> (A --> boolean) --> boolean} - Progression P -> (super Progression P or false)) + Progression P -> (super Progression P (function or) false)) (define for {(progression A) --> (A --> B) --> number} - Progression P -> (super Progression P progn 0)) + Progression P -> (super Progression P (function progn) 0)) (define progn {A --> B --> B} diff --git a/shen/Test Programs/strings.shen b/shen/Test Programs/strings.shen index ed60d96..539942b 100644 --- a/shen/Test Programs/strings.shen +++ b/shen/Test Programs/strings.shen @@ -10,8 +10,7 @@ Rep "" Ss -> (@s Rep Ss) Rep (@s S Ss) (@s S Ss') -> (subst-string' Rep Ss Ss') _ _ _ -> "failed!") - - + (define rwilli {string --> string} "" -> "" diff --git a/shen/benchmarks/heatwave.gif b/shen/benchmarks/heatwave.gif deleted file mode 100644 index 434dee3..0000000 Binary files a/shen/benchmarks/heatwave.gif and /dev/null differ diff --git a/shen/benchmarks/jnk.shen b/shen/benchmarks/jnk.shen new file mode 100644 index 0000000..37c0d6d --- /dev/null +++ b/shen/benchmarks/jnk.shen @@ -0,0 +1,194 @@ +(define kl-to-lisp + Params Param -> Param where (element? Param Params) + Params [type X _] -> (kl-to-lisp Params X) + Params [lambda X Y] -> [FUNCTION [LAMBDA [X] (kl-to-lisp [X | Params] Y)]] + Params [let X Y Z] -> [LET [[X (kl-to-lisp Params Y)]] + (kl-to-lisp [X | Params] Z)] + _ [defun F Params Code] -> [DEFUN F Params (kl-to-lisp Params Code)] + Params [cond | Cond] -> [COND | (map (/. C (cond_code Params C)) (insert-default Cond))] + Params [Param | X] -> (higher-order-code Param + (map (/. Y (kl-to-lisp Params Y)) X)) + where (element? Param Params) + Params [[X | Y] | Z] -> (higher-order-code (kl-to-lisp Params [X | Y]) + (map (/. W (kl-to-lisp Params W)) Z)) + Params [F | X] -> (assemble-application F + (map (/. Y (kl-to-lisp Params Y)) X)) + where (symbol? F) + _ [] -> [] + _ S -> [QUOTE S] where (or (symbol? S) (boolean? S)) + _ X -> X) + +(define insert-default + [] -> [[true [ERROR "error: cond failure~%"]]] + [[true X] | Y] -> [[true X] | Y] + [Case | Cases] -> [Case | (insert-default Cases)]) + +(define higher-order-code + F X -> [let Args [LIST | X] + [let NewF [maplispsym F] + [trap-error [APPLY NewF Args] + [lambda E [COND [[arity-error? F Args] + [funcall [EVAL [nest-lambda F NewF]] Args]] + [[EQ NewF [QUOTE or]] + [funcall [lambda X1 [lambda X2 [or X1 X2]]] Args]] + [[EQ NewF [QUOTE and]] + [funcall [lambda X1 [lambda X2 [and X1 X2]]] Args]] + [[EQ NewF [QUOTE trap-error]] + [funcall [lambda X1 [lambda X2 [trap-error X1 X2]]] Args]] + [[bad-lambda-call? NewF Args] + [funcall NewF Args]] + [T [relay-error E]]]]]]]) + +(define bad-lambda-call? + F Args -> (AND (FUNCTIONP F) (NOT (= (LIST-LENGTH Args) 1)))) + +(define relay-error + E -> (ERROR (error-to-string E))) + +(define funcall + Lambda [] -> Lambda + Lambda [X | Y] -> (funcall (FUNCALL Lambda X) Y)) + +(define arity-error? + F Args -> (AND (SYMBOLP F) + (> (trap-error (arity F) (/. E -1)) (LIST-LENGTH Args))) + +(define nest-lambda + F NewF -> (nest-lambda-help NewF (trap-error (arity F) (/. E -1)))) + +(define nest-lambda-help + F -1 -> F + F 0 -> F + F N -> (let X (gensym (protect Y)) + [lambda X (nest-lambda-help (add-p F X) (- N 1))])) + +(define add-p + [F | X] Y -> (append [F | X] [Y]) + F X -> [F X]) + +(define cond_code + Params [Test Result] -> [(lisp_test Params Test) + (kl-to-lisp Params Result)]) + +(define lisp_test + _ true -> T + Params [and | Tests] -> [AND | (map (/. X (wrap (kl-to-lisp Params X))) Tests)] + Params Test -> (wrap (kl-to-lisp Params Test))) + + (define wrap + [cons? X] -> [CONSP X] + [string? X] -> [STRINGP X] + [number? X] -> [NUMBERP X] + [empty? X] -> [NULL X] + [and P Q] -> [AND (wrap P) (wrap Q)] + [or P Q] -> [OR (wrap P) (wrap Q)] + [not P] -> [NOT (wrap P)] + [equal? X []] -> [NULL X] + [equal? [] X] -> [NULL X] + [equal? X [Quote Y]] -> [EQ X [Quote Y]] + where (and (= (SYMBOLP Y) T) (= Quote QUOTE)) + [equal? [Quote Y] X] -> [EQ [Quote Y] X] + where (and (= (SYMBOLP Y) T) (= Quote QUOTE)) + [equal? [fail] X] -> [EQ [fail] X] + [equal? X [fail]] -> [EQ X [fail]] + [equal? S X] -> [EQUAL S X] where (string? S) + [equal? X S] -> [EQUAL X S] where (string? S) + [equal? X Y] -> [shen-ABSEQUAL X Y] + [shen-+string? [tlstr X]] -> [NOT [STRING-EQUAL [tlstr X] ""]] + [shen-pvar? X] -> [AND [ARRAYP X] [NOT [STRINGP X]] [EQ [AREF X 0] [QUOTE shen-pvar]]] + [tuple? X] -> [AND [ARRAYP X] [NOT [STRINGP X]] [EQ [AREF X 0] [QUOTE shen-tuple]]] + [greater? X Y] -> [> X Y] + [greater-than-or-equal-to? X Y] -> [>= X Y] + [less? X Y] -> [< X Y] + [less-than-or-equal-to? X Y] -> [<= X Y] + X -> [wrapper X]) + + (define wrapper + true -> T + false -> [] + X -> (error "boolean expected: not ~S~%" X)) + + (define assemble-application + hd [X] -> (protect [CAR X]) + tl [X] -> (protect [CDR X]) + cons [X Y] -> (protect [CONS X Y]) + append [X Y] -> (protect [APPEND X Y]) + reverse [X] -> (protect [REVERSE X]) + if [P Q R] -> (protect [IF (wrap P) Q R]) + + [1 X] -> [1+ X] + + [X 1] -> [1+ X] + - [X 1] -> [1- X] + value [[Quote X]] -> X where (= Quote (protect QUOTE)) + set [[Quote X] [1+ X]] -> [INCF X] where (= Quote (protect QUOTE)) + set [[Quote X] [1- X]] -> [DECF X] where (= Quote (protect QUOTE)) + F X -> (let NewF (maplispsym F) + Arity (trap-error (arity F) (/. E -1)) + (if (or (= Arity (length X)) (= Arity -1)) + [NewF | X] + [funcall (nest-lambda F NewF) [(protect LIST) | X]]))) + +(define maplispsym + = -> equal? + > -> greater? + < -> less? + >= -> greater-than-or-equal-to? + <= -> less-than-or-equal-to? + + -> add + - -> subtract + / -> divide + * -> multiply + F -> F) + + (define factorh + [Defun F Params [Cond | Code]] -> [Defun F Params [BLOCK [] (process-tree (tree (map returns Code)))]] + where (and (= Cond COND) (= Defun DEFUN)) + Code -> Code) + +(define returns + [Test Result] -> [Test [RETURN Result]]) + +(define process-tree + (@p P Q R no-tag) -> [IF P (optimise-selectors P (process-tree Q)) (process-tree R)] + (@p P Q R Tag) -> [TAGBODY [IF P (optimise-selectors P (process-tree Q))] Tag (process-tree R)] + Q -> Q where (not (tuple? Q))) + +(define optimise-selectors + Test Code -> (optimise-selectors-help (selectors-from Test) Code)) + +(define selectors-from + [Consp X] -> [[CAR X] [CDR X]] where (= Consp CONSP) + [tuple? X] -> [[fst X] [snd X]] + _ -> []) + +(define optimise-selectors-help + [] Code -> Code + [S1 S2] Code -> (let O1 (occurrences S1 Code) + O2 (occurrences S2 Code) + V1 (gensym V) + V2 (gensym V) + (if (and (> O1 1) (> O2 1)) + [LET [[V1 S1] [V2 S2]] + (subst V1 S1 (subst V2 S2 Code))] + (if (> O1 1) + [LET [[V1 S1]] (subst V1 S1 Code)] + (if (> O2 1) + [LET [[V2 S2]] (subst V2 S2 Code)] + Code))))) + +(define tree + [[[And P Q] R] | S] -> (let Tag (gensym tag) + Left (tree (append (branch-by P [[[And P Q] R] | S]) [[T [GO Tag]]])) + Right (tree (branch-by-not P [[[And P Q] R] | S])) + (@p P Left Right Tag)) where (= And AND) + [[True Q] | _] -> Q where (= True T) + [[P Q] | R] -> (@p P Q (tree R) no-tag)) + +(define branch-by + P [[[And P Q] R] | S] -> [[Q R] | (branch-by P S)] where (= And AND) + P [[P R] | S] -> [[T R]] + _ Code -> []) + +(define branch-by-not + P [[[And P Q] R] | S] -> (branch-by-not P S) where (= And AND) + P [[P R] | S] -> S + _ Code -> Code) \ No newline at end of file diff --git a/shen/benchmarks/picture.jpg b/shen/benchmarks/picture.jpg deleted file mode 100644 index 8874988..0000000 Binary files a/shen/benchmarks/picture.jpg and /dev/null differ diff --git a/shen/benchmarks/plato.jpg b/shen/benchmarks/plato.jpg deleted file mode 100644 index 9465fbf..0000000 Binary files a/shen/benchmarks/plato.jpg and /dev/null differ diff --git a/shen/klambda/core.kl b/shen/klambda/core.kl index 362209b..479db1c 100644 --- a/shen/klambda/core.kl +++ b/shen/klambda/core.kl @@ -47,134 +47,134 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun shen.shen->kl (V607 V608) (compile shen. (cons V607 V608) (lambda X (shen.shen-syntax-error V607 X)))) +"(defun shen.shen->kl (V614 V615) (compile (lambda X608 (shen. X608)) (cons V614 V615) (lambda X (shen.shen-syntax-error V614 X)))) -(defun shen.shen-syntax-error (V609 V610) (simple-error (cn "syntax error in " (shen.app V609 (cn " here: +(defun shen.shen-syntax-error (V616 V617) (simple-error (cn "syntax error in " (shen.app V616 (cn " here: - " (shen.app (shen.next-50 50 V610) " + " (shen.app (shen.next-50 50 V617) " " shen.a)) shen.a)))) -(defun shen. (V615) (let Result (let Parse_shen. (shen. V615) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.compile_to_machine_code (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V615) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.compile_to_machine_code (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V622) (let Result (let Parse_shen. (shen. V622) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.compile_to_machine_code (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V622) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.compile_to_machine_code (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V620) (let Result (if (cons? (hd V620)) (let Parse_X (hd (hd V620)) (shen.pair (hd (shen.pair (tl (hd V620)) (shen.hdtl V620))) (if (and (symbol? Parse_X) (not (shen.sysfunc? Parse_X))) Parse_X (simple-error (shen.app Parse_X " is not a legitimate function name. +(defun shen. (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. " shen.a))))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen.sysfunc? (V621) (element? V621 (get (intern "shen") shen.external-symbols (value *property-vector*)))) +(defun shen.sysfunc? (V628) (element? V628 (get (intern "shen") shen.external-symbols (value *property-vector*)))) -(defun shen. (V626) (let Result (if (and (cons? (hd V626)) (= { (hd (hd V626)))) (let Parse_shen. (shen. (shen.pair (tl (hd V626)) (shen.hdtl V626))) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= } (hd (hd Parse_shen.)))) (shen.pair (hd (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (shen.demodulate (shen.curry-type (shen.hdtl Parse_shen.)))) (fail)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V633) (let Result (if (and (cons? (hd V633)) (= { (hd (hd V633)))) (let Parse_shen. (shen. (shen.pair (tl (hd V633)) (shen.hdtl V633))) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= } (hd (hd Parse_shen.)))) (shen.pair (hd (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (shen.demodulate (shen.curry-type (shen.hdtl Parse_shen.)))) (fail)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen.curry-type (V627) (cond ((and (cons? V627) (and (cons? (tl V627)) (and (= --> (hd (tl V627))) (and (cons? (tl (tl V627))) (and (cons? (tl (tl (tl V627)))) (= --> (hd (tl (tl (tl V627)))))))))) (shen.curry-type (cons (hd V627) (cons --> (cons (tl (tl V627)) ()))))) ((and (cons? V627) (and (cons? (tl V627)) (and (= * (hd (tl V627))) (and (cons? (tl (tl V627))) (and (cons? (tl (tl (tl V627)))) (= * (hd (tl (tl (tl V627)))))))))) (shen.curry-type (cons (hd V627) (cons * (cons (tl (tl V627)) ()))))) ((cons? V627) (map shen.curry-type V627)) (true V627))) +(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))) -(defun shen. (V632) (let Result (if (cons? (hd V632)) (let Parse_X (hd (hd V632)) (let Parse_shen. (shen. (shen.pair (tl (hd V632)) (shen.hdtl V632))) (if (not (= (fail) Parse_shen.)) (if (not (element? Parse_X (cons { (cons } ())))) (shen.pair (hd Parse_shen.) (cons Parse_X (shen.hdtl Parse_shen.))) (fail)) (fail)))) (fail)) (if (= Result (fail)) (let Result (let Parse_ ( V632) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V639) (let Result (if (cons? (hd V639)) (let Parse_X (hd (hd V639)) (let Parse_shen. (shen. (shen.pair (tl (hd V639)) (shen.hdtl V639))) (if (not (= (fail) Parse_shen.)) (if (not (element? Parse_X (cons { (cons } ())))) (shen.pair (hd Parse_shen.) (cons Parse_X (shen.hdtl Parse_shen.))) (fail)) (fail)))) (fail)) (if (= Result (fail)) (let Result (let Parse_ ( V639) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V637) (let Result (let Parse_shen. (shen. V637) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.linearise (shen.hdtl Parse_shen.)) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V637) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.linearise (shen.hdtl Parse_shen.)) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V644) (let Result (let Parse_shen. (shen. V644) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.linearise (shen.hdtl Parse_shen.)) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V644) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.linearise (shen.hdtl Parse_shen.)) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V642) (let Result (let Parse_shen. (shen. V642) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= -> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= where (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (cons where (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V642) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= -> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V642) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= <- (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= where (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (cons where (cons (shen.hdtl Parse_shen.) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.) ())) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V642) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= <- (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.) ())) ()))) (fail))) (fail)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result))) +(defun shen. (V649) (let Result (let Parse_shen. (shen. V649) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= -> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= where (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (cons where (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V649) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= -> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V649) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= <- (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= where (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (cons where (cons (shen.hdtl Parse_shen.) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.) ())) ()))) ()))) (fail))) (fail)) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V649) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= <- (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (cons shen.choicepoint! (cons (shen.hdtl Parse_shen.) ())) ()))) (fail))) (fail)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result))) -(defun shen.fail_if (V643 V644) (if (V643 V644) (fail) V644)) +(defun shen.fail_if (V650 V651) (if (V650 V651) (fail) V651)) -(defun shen.succeeds? (V649) (cond ((= V649 (fail)) false) (true true))) +(defun shen.succeeds? (V656) (cond ((= V656 (fail)) false) (true true))) -(defun shen. (V654) (let Result (let Parse_shen. (shen. V654) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V654) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V661) (let Result (let Parse_shen. (shen. V661) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V661) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V659) (let Result (if (and (cons? (hd V659)) (cons? (hd (hd V659)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (= @p (hd (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))))) (let Parse_shen. (shen. (shen.pair (tl (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (shen.hdtl (shen.pair (hd (hd V659)) (shen.hdtl V659))))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pair (hd (shen.pair (tl (hd V659)) (shen.hdtl V659))) (cons @p (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V659)) (cons? (hd (hd V659)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (= cons (hd (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))))) (let Parse_shen. (shen. (shen.pair (tl (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (shen.hdtl (shen.pair (hd (hd V659)) (shen.hdtl V659))))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pair (hd (shen.pair (tl (hd V659)) (shen.hdtl V659))) (cons cons (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V659)) (cons? (hd (hd V659)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (= @v (hd (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))))) (let Parse_shen. (shen. (shen.pair (tl (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (shen.hdtl (shen.pair (hd (hd V659)) (shen.hdtl V659))))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pair (hd (shen.pair (tl (hd V659)) (shen.hdtl V659))) (cons @v (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V659)) (cons? (hd (hd V659)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (= @s (hd (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))))) (let Parse_shen. (shen. (shen.pair (tl (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (shen.hdtl (shen.pair (hd (hd V659)) (shen.hdtl V659))))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pair (hd (shen.pair (tl (hd V659)) (shen.hdtl V659))) (cons @s (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V659)) (cons? (hd (hd V659)))) (shen.snd-or-fail (if (and (cons? (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (= vector (hd (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))))) (if (and (cons? (hd (shen.pair (tl (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (shen.hdtl (shen.pair (hd (hd V659)) (shen.hdtl V659)))))) (= 0 (hd (hd (shen.pair (tl (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (shen.hdtl (shen.pair (hd (hd V659)) (shen.hdtl V659)))))))) (shen.pair (hd (shen.pair (tl (hd (shen.pair (tl (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (shen.hdtl (shen.pair (hd (hd V659)) (shen.hdtl V659)))))) (shen.hdtl (shen.pair (tl (hd (shen.pair (hd (hd V659)) (shen.hdtl V659)))) (shen.hdtl (shen.pair (hd (hd V659)) (shen.hdtl V659))))))) (shen.pair (hd (shen.pair (tl (hd V659)) (shen.hdtl V659))) (cons vector (cons 0 ())))) (fail)) (fail))) (fail)) (if (= Result (fail)) (let Result (if (cons? (hd V659)) (let Parse_X (hd (hd V659)) (if (cons? Parse_X) (shen.pair (hd (shen.pair (tl (hd V659)) (shen.hdtl V659))) (shen.constructor-error Parse_X)) (fail))) (fail)) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V659) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)) Result)) Result)) Result))) +(defun shen. (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. (shen. (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.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons @p (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (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. (shen. (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.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons cons (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (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. (shen. (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.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons @v (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (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. (shen. (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.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pair (hd (shen.pair (tl (hd V666)) (shen.hdtl V666))) (cons @s (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (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. (shen. V666) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)) Result)) Result)) Result))) -(defun shen.constructor-error (V660) (simple-error (shen.app V660 " is not a legitimate constructor +(defun shen.constructor-error (V667) (simple-error (shen.app V667 " is not a legitimate constructor " shen.a))) -(defun shen. (V665) (let Result (if (cons? (hd V665)) (let Parse_X (hd (hd V665)) (if (= Parse_X _) (shen.pair (hd (shen.pair (tl (hd V665)) (shen.hdtl V665))) (gensym Parse_Y)) (fail))) (fail)) (if (= Result (fail)) (let Result (if (cons? (hd V665)) (let Parse_X (hd (hd V665)) (if (not (element? Parse_X (cons -> (cons <- ())))) (shen.pair (hd (shen.pair (tl (hd V665)) (shen.hdtl V665))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (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))) -(defun shen. (V670) (let Result (let Parse_shen. (shen. V670) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V677) (let Result (let Parse_shen. (shen. V677) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V675) (let Result (let Parse_shen. (shen. V675) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V682) (let Result (let Parse_shen. (shen. V682) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V680) (let Result (if (cons? (hd V680)) (let Parse_X (hd (hd V680)) (shen.pair (hd (shen.pair (tl (hd V680)) (shen.hdtl V680))) Parse_X)) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (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))) -(defun shen. (V685) (let Result (if (cons? (hd V685)) (let Parse_X (hd (hd V685)) (shen.pair (hd (shen.pair (tl (hd V685)) (shen.hdtl V685))) Parse_X)) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (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))) -(defun shen.compile_to_machine_code (V686 V687) (let Lambda+ (shen.compile_to_lambda+ V686 V687) (let KL (shen.compile_to_kl V686 Lambda+) (let Record (shen.record-source V686 KL) KL)))) +(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)))) -(defun shen.record-source (V690 V691) (cond ((value shen.*installing-kl*) shen.skip) (true (put V690 shen.source V691 (value *property-vector*))))) +(defun shen.record-source (V697 V698) (cond ((value shen.*installing-kl*) shen.skip) (true (put V697 shen.source V698 (value *property-vector*))))) -(defun shen.compile_to_lambda+ (V692 V693) (let Arity (shen.aritycheck V692 V693) (let Free (map (lambda Rule (shen.free_variable_check V692 Rule)) V693) (let Variables (shen.parameters Arity) (let Strip (map shen.strip-protect V693) (let Abstractions (map shen.abstract_rule Strip) (let Applications (map (lambda X (shen.application_build Variables X)) Abstractions) (cons Variables (cons Applications ()))))))))) +(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 ()))))))))) -(defun shen.free_variable_check (V694 V695) (cond ((and (cons? V695) (and (cons? (tl V695)) (= () (tl (tl V695))))) (let Bound (shen.extract_vars (hd V695)) (let Free (shen.extract_free_vars Bound (hd (tl V695))) (shen.free_variable_warnings V694 Free)))) (true (shen.sys-error shen.free_variable_check)))) +(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)))) -(defun shen.extract_vars (V696) (cond ((variable? V696) (cons V696 ())) ((cons? V696) (union (shen.extract_vars (hd V696)) (shen.extract_vars (tl V696)))) (true ()))) +(defun shen.extract_vars (V703) (cond ((variable? V703) (cons V703 ())) ((cons? V703) (union (shen.extract_vars (hd V703)) (shen.extract_vars (tl V703)))) (true ()))) -(defun shen.extract_free_vars (V706 V707) (cond ((and (cons? V707) (and (cons? (tl V707)) (and (= () (tl (tl V707))) (= (hd V707) protect)))) ()) ((and (variable? V707) (not (element? V707 V706))) (cons V707 ())) ((and (cons? V707) (and (= lambda (hd V707)) (and (cons? (tl V707)) (and (cons? (tl (tl V707))) (= () (tl (tl (tl V707)))))))) (shen.extract_free_vars (cons (hd (tl V707)) V706) (hd (tl (tl V707))))) ((and (cons? V707) (and (= let (hd V707)) (and (cons? (tl V707)) (and (cons? (tl (tl V707))) (and (cons? (tl (tl (tl V707)))) (= () (tl (tl (tl (tl V707)))))))))) (union (shen.extract_free_vars V706 (hd (tl (tl V707)))) (shen.extract_free_vars (cons (hd (tl V707)) V706) (hd (tl (tl (tl V707))))))) ((cons? V707) (union (shen.extract_free_vars V706 (hd V707)) (shen.extract_free_vars V706 (tl V707)))) (true ()))) +(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 ()))) -(defun shen.free_variable_warnings (V710 V711) (cond ((= () V711) _) (true (simple-error (cn "error: the following variables are free in " (shen.app V710 (cn ": " (shen.app (shen.list_variables V711) "" shen.a)) shen.a)))))) +(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)))))) -(defun shen.list_variables (V712) (cond ((and (cons? V712) (= () (tl V712))) (cn (str (hd V712)) ".")) ((cons? V712) (cn (str (hd V712)) (cn ", " (shen.list_variables (tl V712))))) (true (shen.sys-error shen.list_variables)))) +(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)))) -(defun shen.strip-protect (V713) (cond ((and (cons? V713) (and (cons? (tl V713)) (and (= () (tl (tl V713))) (= (hd V713) protect)))) (hd (tl V713))) ((cons? V713) (cons (shen.strip-protect (hd V713)) (shen.strip-protect (tl V713)))) (true V713))) +(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))) -(defun shen.linearise (V714) (cond ((and (cons? V714) (and (cons? (tl V714)) (= () (tl (tl V714))))) (shen.linearise_help (shen.flatten (hd V714)) (hd V714) (hd (tl V714)))) (true (shen.sys-error shen.linearise)))) +(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)))) -(defun shen.flatten (V715) (cond ((= () V715) ()) ((cons? V715) (append (shen.flatten (hd V715)) (shen.flatten (tl V715)))) (true (cons V715 ())))) +(defun shen.flatten (V722) (cond ((= () V722) ()) ((cons? V722) (append (shen.flatten (hd V722)) (shen.flatten (tl V722)))) (true (cons V722 ())))) -(defun shen.linearise_help (V716 V717 V718) (cond ((= () V716) (cons V717 (cons V718 ()))) ((cons? V716) (if (and (variable? (hd V716)) (element? (hd V716) (tl V716))) (let Var (gensym (hd V716)) (let NewAction (cons where (cons (cons = (cons (hd V716) (cons Var ()))) (cons V718 ()))) (let NewPatts (shen.linearise_X (hd V716) Var V717) (shen.linearise_help (tl V716) NewPatts NewAction)))) (shen.linearise_help (tl V716) V717 V718))) (true (shen.sys-error shen.linearise_help)))) +(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)))) -(defun shen.linearise_X (V727 V728 V729) (cond ((= V729 V727) V728) ((cons? V729) (let L (shen.linearise_X V727 V728 (hd V729)) (if (= L (hd V729)) (cons (hd V729) (shen.linearise_X V727 V728 (tl V729))) (cons L (tl V729))))) (true V729))) +(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))) -(defun shen.aritycheck (V731 V732) (cond ((and (cons? V732) (and (cons? (hd V732)) (and (cons? (tl (hd V732))) (and (= () (tl (tl (hd V732)))) (= () (tl V732)))))) (do (shen.aritycheck-action (hd (tl (hd V732)))) (shen.aritycheck-name V731 (arity V731) (length (hd (hd V732)))))) ((and (cons? V732) (and (cons? (hd V732)) (and (cons? (tl (hd V732))) (and (= () (tl (tl (hd V732)))) (and (cons? (tl V732)) (and (cons? (hd (tl V732))) (and (cons? (tl (hd (tl V732)))) (= () (tl (tl (hd (tl V732)))))))))))) (if (= (length (hd (hd V732))) (length (hd (hd (tl V732))))) (do (shen.aritycheck-action (hd (tl (hd V732)))) (shen.aritycheck V731 (tl V732))) (simple-error (cn "arity error in " (shen.app V731 " +(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 " " shen.a))))) (true (shen.sys-error shen.aritycheck)))) -(defun shen.aritycheck-name (V741 V742 V743) (cond ((= -1 V742) V743) ((= V743 V742) V743) (true (do (shen.prhush (cn " -warning: changing the arity of " (shen.app V741 " can cause errors. -" shen.a)) (stoutput)) V743)))) +(defun shen.aritycheck-name (V748 V749 V750) (cond ((= -1 V749) V750) ((= V750 V749) V750) (true (do (shen.prhush (cn " +warning: changing the arity of " (shen.app V748 " can cause errors. +" shen.a)) (stoutput)) V750)))) -(defun shen.aritycheck-action (V749) (cond ((cons? V749) (do (shen.aah (hd V749) (tl V749)) (map shen.aritycheck-action V749))) (true shen.skip))) +(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))) -(defun shen.aah (V750 V751) (let Arity (arity V750) (let Len (length V751) (if (and (> Arity -1) (> Len Arity)) (shen.prhush (cn "warning: " (shen.app V750 (cn " might not like " (shen.app Len (cn " argument" (shen.app (if (> Len 1) "s" "") ". +(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" "") ". " shen.a)) shen.a)) shen.a)) (stoutput)) shen.skip)))) -(defun shen.abstract_rule (V752) (cond ((and (cons? V752) (and (cons? (tl V752)) (= () (tl (tl V752))))) (shen.abstraction_build (hd V752) (hd (tl V752)))) (true (shen.sys-error shen.abstract_rule)))) +(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)))) -(defun shen.abstraction_build (V753 V754) (cond ((= () V753) V754) ((cons? V753) (cons /. (cons (hd V753) (cons (shen.abstraction_build (tl V753) V754) ())))) (true (shen.sys-error shen.abstraction_build)))) +(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)))) -(defun shen.parameters (V755) (cond ((= 0 V755) ()) (true (cons (gensym V) (shen.parameters (- V755 1)))))) +(defun shen.parameters (V762) (cond ((= 0 V762) ()) (true (cons (gensym V) (shen.parameters (- V762 1)))))) -(defun shen.application_build (V756 V757) (cond ((= () V756) V757) ((cons? V756) (shen.application_build (tl V756) (cons V757 (cons (hd V756) ())))) (true (shen.sys-error shen.application_build)))) +(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)))) -(defun shen.compile_to_kl (V758 V759) (cond ((and (cons? V759) (and (cons? (tl V759)) (= () (tl (tl V759))))) (let Arity (shen.store-arity V758 (length (hd V759))) (let Reduce (map shen.reduce (hd (tl V759))) (let CondExpression (shen.cond-expression V758 (hd V759) Reduce) (let TypeTable (if (value shen.*optimise*) (shen.typextable (shen.get-type V758) (hd V759)) shen.skip) (let TypedCondExpression (if (value shen.*optimise*) (shen.assign-types (hd V759) TypeTable CondExpression) CondExpression) (let KL (cons defun (cons V758 (cons (hd V759) (cons TypedCondExpression ())))) KL))))))) (true (shen.sys-error shen.compile_to_kl)))) +(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)))) -(defun shen.get-type (V764) (cond ((cons? V764) shen.skip) (true (let FType (assoc V764 (value shen.*signedfuncs*)) (if (empty? FType) shen.skip (tl FType)))))) +(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)))))) -(defun shen.typextable (V773 V774) (cond ((and (cons? V773) (and (cons? (tl V773)) (and (= --> (hd (tl V773))) (and (cons? (tl (tl V773))) (and (= () (tl (tl (tl V773)))) (cons? V774)))))) (if (variable? (hd V773)) (shen.typextable (hd (tl (tl V773))) (tl V774)) (cons (cons (hd V774) (hd V773)) (shen.typextable (hd (tl (tl V773))) (tl V774))))) (true ()))) +(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 ()))) -(defun shen.assign-types (V775 V776 V777) (cond ((and (cons? V777) (and (= let (hd V777)) (and (cons? (tl V777)) (and (cons? (tl (tl V777))) (and (cons? (tl (tl (tl V777)))) (= () (tl (tl (tl (tl V777)))))))))) (cons let (cons (hd (tl V777)) (cons (shen.assign-types V775 V776 (hd (tl (tl V777)))) (cons (shen.assign-types (cons (hd (tl V777)) V775) V776 (hd (tl (tl (tl V777))))) ()))))) ((and (cons? V777) (and (= lambda (hd V777)) (and (cons? (tl V777)) (and (cons? (tl (tl V777))) (= () (tl (tl (tl V777)))))))) (cons lambda (cons (hd (tl V777)) (cons (shen.assign-types (cons (hd (tl V777)) V775) V776 (hd (tl (tl V777)))) ())))) ((and (cons? V777) (= cond (hd V777))) (cons cond (map (lambda Y (cons (shen.assign-types V775 V776 (hd Y)) (cons (shen.assign-types V775 V776 (hd (tl Y))) ()))) (tl V777)))) ((cons? V777) (let NewTable (shen.typextable (shen.get-type (hd V777)) (tl V777)) (cons (hd V777) (map (lambda Y (shen.assign-types V775 (append V776 NewTable) Y)) (tl V777))))) (true (let AtomType (assoc V777 V776) (if (cons? AtomType) (cons type (cons V777 (cons (tl AtomType) ()))) (if (element? V777 V775) V777 (shen.atom-type V777))))))) +(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))))))) -(defun shen.atom-type (V778) (if (string? V778) (cons type (cons V778 (cons string ()))) (if (number? V778) (cons type (cons V778 (cons number ()))) (if (boolean? V778) (cons type (cons V778 (cons boolean ()))) (if (symbol? V778) (cons type (cons V778 (cons symbol ()))) V778))))) +(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))))) -(defun shen.store-arity (V781 V782) (cond ((value shen.*installing-kl*) shen.skip) (true (put V781 arity V782 (value *property-vector*))))) +(defun shen.store-arity (V788 V789) (cond ((value shen.*installing-kl*) shen.skip) (true (put V788 arity V789 (value *property-vector*))))) -(defun shen.reduce (V783) (do (set shen.*teststack* ()) (let Result (shen.reduce_help V783) (cons (cons : (cons shen.tests (reverse (value shen.*teststack*)))) (cons Result ()))))) +(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 ()))))) -(defun shen.reduce_help (V784) (cond ((and (cons? V784) (and (cons? (hd V784)) (and (= /. (hd (hd V784))) (and (cons? (tl (hd V784))) (and (cons? (hd (tl (hd V784)))) (and (= cons (hd (hd (tl (hd V784))))) (and (cons? (tl (hd (tl (hd V784))))) (and (cons? (tl (tl (hd (tl (hd V784)))))) (and (= () (tl (tl (tl (hd (tl (hd V784))))))) (and (cons? (tl (tl (hd V784)))) (and (= () (tl (tl (tl (hd V784))))) (and (cons? (tl V784)) (= () (tl (tl V784))))))))))))))) (do (shen.add_test (cons cons? (tl V784))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V784))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V784)))))) (cons (shen.ebr (hd (tl V784)) (hd (tl (hd V784))) (hd (tl (tl (hd V784))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hd (tl V784)) ())) (cons (cons tl (tl V784)) ())) (shen.reduce_help Application))))) ((and (cons? V784) (and (cons? (hd V784)) (and (= /. (hd (hd V784))) (and (cons? (tl (hd V784))) (and (cons? (hd (tl (hd V784)))) (and (= @p (hd (hd (tl (hd V784))))) (and (cons? (tl (hd (tl (hd V784))))) (and (cons? (tl (tl (hd (tl (hd V784)))))) (and (= () (tl (tl (tl (hd (tl (hd V784))))))) (and (cons? (tl (tl (hd V784)))) (and (= () (tl (tl (tl (hd V784))))) (and (cons? (tl V784)) (= () (tl (tl V784))))))))))))))) (do (shen.add_test (cons tuple? (tl V784))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V784))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V784)))))) (cons (shen.ebr (hd (tl V784)) (hd (tl (hd V784))) (hd (tl (tl (hd V784))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons fst (tl V784)) ())) (cons (cons snd (tl V784)) ())) (shen.reduce_help Application))))) ((and (cons? V784) (and (cons? (hd V784)) (and (= /. (hd (hd V784))) (and (cons? (tl (hd V784))) (and (cons? (hd (tl (hd V784)))) (and (= @v (hd (hd (tl (hd V784))))) (and (cons? (tl (hd (tl (hd V784))))) (and (cons? (tl (tl (hd (tl (hd V784)))))) (and (= () (tl (tl (tl (hd (tl (hd V784))))))) (and (cons? (tl (tl (hd V784)))) (and (= () (tl (tl (tl (hd V784))))) (and (cons? (tl V784)) (= () (tl (tl V784))))))))))))))) (do (shen.add_test (cons shen.+vector? (tl V784))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V784))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V784)))))) (cons (shen.ebr (hd (tl V784)) (hd (tl (hd V784))) (hd (tl (tl (hd V784))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons hdv (tl V784)) ())) (cons (cons tlv (tl V784)) ())) (shen.reduce_help Application))))) ((and (cons? V784) (and (cons? (hd V784)) (and (= /. (hd (hd V784))) (and (cons? (tl (hd V784))) (and (cons? (hd (tl (hd V784)))) (and (= @s (hd (hd (tl (hd V784))))) (and (cons? (tl (hd (tl (hd V784))))) (and (cons? (tl (tl (hd (tl (hd V784)))))) (and (= () (tl (tl (tl (hd (tl (hd V784))))))) (and (cons? (tl (tl (hd V784)))) (and (= () (tl (tl (tl (hd V784))))) (and (cons? (tl V784)) (= () (tl (tl V784))))))))))))))) (do (shen.add_test (cons shen.+string? (tl V784))) (let Abstraction (cons /. (cons (hd (tl (hd (tl (hd V784))))) (cons (cons /. (cons (hd (tl (tl (hd (tl (hd V784)))))) (cons (shen.ebr (hd (tl V784)) (hd (tl (hd V784))) (hd (tl (tl (hd V784))))) ()))) ()))) (let Application (cons (cons Abstraction (cons (cons pos (cons (hd (tl V784)) (cons 0 ()))) ())) (cons (cons tlstr (tl V784)) ())) (shen.reduce_help Application))))) ((and (cons? V784) (and (cons? (hd V784)) (and (= /. (hd (hd V784))) (and (cons? (tl (hd V784))) (and (cons? (tl (tl (hd V784)))) (and (= () (tl (tl (tl (hd V784))))) (and (cons? (tl V784)) (and (= () (tl (tl V784))) (not (variable? (hd (tl (hd V784))))))))))))) (do (shen.add_test (cons = (cons (hd (tl (hd V784))) (tl V784)))) (shen.reduce_help (hd (tl (tl (hd V784))))))) ((and (cons? V784) (and (cons? (hd V784)) (and (= /. (hd (hd V784))) (and (cons? (tl (hd V784))) (and (cons? (tl (tl (hd V784)))) (and (= () (tl (tl (tl (hd V784))))) (and (cons? (tl V784)) (= () (tl (tl V784)))))))))) (shen.reduce_help (shen.ebr (hd (tl V784)) (hd (tl (hd V784))) (hd (tl (tl (hd V784))))))) ((and (cons? V784) (and (= where (hd V784)) (and (cons? (tl V784)) (and (cons? (tl (tl V784))) (= () (tl (tl (tl V784)))))))) (do (shen.add_test (hd (tl V784))) (shen.reduce_help (hd (tl (tl V784)))))) ((and (cons? V784) (and (cons? (tl V784)) (= () (tl (tl V784))))) (let Z (shen.reduce_help (hd V784)) (if (= (hd V784) Z) V784 (shen.reduce_help (cons Z (tl V784)))))) (true V784))) +(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))) -(defun shen.+string? (V785) (cond ((= "" V785) false) (true (string? V785)))) +(defun shen.+string? (V792) (cond ((= "" V792) false) (true (string? V792)))) -(defun shen.+vector (V786) (cond ((= V786 (vector 0)) false) (true (vector? V786)))) +(defun shen.+vector (V793) (cond ((= V793 (vector 0)) false) (true (vector? V793)))) -(defun shen.ebr (V795 V796 V797) (cond ((= V797 V796) V795) ((and (cons? V797) (and (= /. (hd V797)) (and (cons? (tl V797)) (and (cons? (tl (tl V797))) (and (= () (tl (tl (tl V797)))) (> (occurrences V796 (hd (tl V797))) 0)))))) V797) ((and (cons? V797) (and (= let (hd V797)) (and (cons? (tl V797)) (and (cons? (tl (tl V797))) (and (cons? (tl (tl (tl V797)))) (and (= () (tl (tl (tl (tl V797))))) (= (hd (tl V797)) V796))))))) (cons let (cons (hd (tl V797)) (cons (shen.ebr V795 (hd (tl V797)) (hd (tl (tl V797)))) (tl (tl (tl V797))))))) ((cons? V797) (cons (shen.ebr V795 V796 (hd V797)) (shen.ebr V795 V796 (tl V797)))) (true V797))) +(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))) -(defun shen.add_test (V800) (set shen.*teststack* (cons V800 (value shen.*teststack*)))) +(defun shen.add_test (V807) (set shen.*teststack* (cons V807 (value shen.*teststack*)))) -(defun shen.cond-expression (V801 V802 V803) (let Err (shen.err-condition V801) (let Cases (shen.case-form V803 Err) (let EncodeChoices (shen.encode-choices Cases V801) (shen.cond-form EncodeChoices))))) +(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))))) -(defun shen.cond-form (V806) (cond ((and (cons? V806) (and (cons? (hd V806)) (and (= true (hd (hd V806))) (and (cons? (tl (hd V806))) (= () (tl (tl (hd V806)))))))) (hd (tl (hd V806)))) (true (cons cond V806)))) +(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)))) -(defun shen.encode-choices (V809 V810) (cond ((= () V809) ()) ((and (cons? V809) (and (cons? (hd V809)) (and (= true (hd (hd V809))) (and (cons? (tl (hd V809))) (and (cons? (hd (tl (hd V809)))) (and (= shen.choicepoint! (hd (hd (tl (hd V809))))) (and (cons? (tl (hd (tl (hd V809))))) (and (= () (tl (tl (hd (tl (hd V809)))))) (and (= () (tl (tl (hd V809)))) (= () (tl V809))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V809))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (if (value shen.*installing-kl*) (cons shen.sys-error (cons V810 ())) (cons shen.f_error (cons V810 ()))) (cons Result ())))) ())))) ())) ())) ((and (cons? V809) (and (cons? (hd V809)) (and (= true (hd (hd V809))) (and (cons? (tl (hd V809))) (and (cons? (hd (tl (hd V809)))) (and (= shen.choicepoint! (hd (hd (tl (hd V809))))) (and (cons? (tl (hd (tl (hd V809))))) (and (= () (tl (tl (hd (tl (hd V809)))))) (= () (tl (tl (hd V809)))))))))))) (cons (cons true (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V809))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (shen.cond-form (shen.encode-choices (tl V809) V810)) (cons Result ())))) ())))) ())) ())) ((and (cons? V809) (and (cons? (hd V809)) (and (cons? (tl (hd V809))) (and (cons? (hd (tl (hd V809)))) (and (= shen.choicepoint! (hd (hd (tl (hd V809))))) (and (cons? (tl (hd (tl (hd V809))))) (and (= () (tl (tl (hd (tl (hd V809)))))) (= () (tl (tl (hd V809))))))))))) (cons (cons true (cons (cons let (cons Freeze (cons (cons freeze (cons (shen.cond-form (shen.encode-choices (tl V809) V810)) ())) (cons (cons if (cons (hd (hd V809)) (cons (cons let (cons Result (cons (hd (tl (hd (tl (hd V809))))) (cons (cons if (cons (cons = (cons Result (cons (cons fail ()) ()))) (cons (cons thaw (cons Freeze ())) (cons Result ())))) ())))) (cons (cons thaw (cons Freeze ())) ())))) ())))) ())) ())) ((and (cons? V809) (and (cons? (hd V809)) (and (cons? (tl (hd V809))) (= () (tl (tl (hd V809))))))) (cons (hd V809) (shen.encode-choices (tl V809) V810))) (true (shen.sys-error shen.encode-choices)))) +(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)))) -(defun shen.case-form (V815 V816) (cond ((= () V815) (cons V816 ())) ((and (cons? V815) (and (cons? (hd V815)) (and (cons? (hd (hd V815))) (and (= : (hd (hd (hd V815)))) (and (cons? (tl (hd (hd V815)))) (and (= shen.tests (hd (tl (hd (hd V815))))) (and (= () (tl (tl (hd (hd V815))))) (and (cons? (tl (hd V815))) (and (cons? (hd (tl (hd V815)))) (and (= shen.choicepoint! (hd (hd (tl (hd V815))))) (and (cons? (tl (hd (tl (hd V815))))) (and (= () (tl (tl (hd (tl (hd V815)))))) (= () (tl (tl (hd V815)))))))))))))))) (cons (cons true (tl (hd V815))) (shen.case-form (tl V815) V816))) ((and (cons? V815) (and (cons? (hd V815)) (and (cons? (hd (hd V815))) (and (= : (hd (hd (hd V815)))) (and (cons? (tl (hd (hd V815)))) (and (= shen.tests (hd (tl (hd (hd V815))))) (and (= () (tl (tl (hd (hd V815))))) (and (cons? (tl (hd V815))) (= () (tl (tl (hd V815)))))))))))) (cons (cons true (tl (hd V815))) ())) ((and (cons? V815) (and (cons? (hd V815)) (and (cons? (hd (hd V815))) (and (= : (hd (hd (hd V815)))) (and (cons? (tl (hd (hd V815)))) (and (= shen.tests (hd (tl (hd (hd V815))))) (and (cons? (tl (hd V815))) (= () (tl (tl (hd V815))))))))))) (cons (cons (shen.embed-and (tl (tl (hd (hd V815))))) (tl (hd V815))) (shen.case-form (tl V815) V816))) (true (shen.sys-error shen.case-form)))) +(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)))) -(defun shen.embed-and (V817) (cond ((and (cons? V817) (= () (tl V817))) (hd V817)) ((cons? V817) (cons and (cons (hd V817) (cons (shen.embed-and (tl V817)) ())))) (true (shen.sys-error shen.embed-and)))) +(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)))) -(defun shen.err-condition (V818) (cons true (cons (cons shen.f_error (cons V818 ())) ()))) +(defun shen.err-condition (V825) (cons true (cons (cons shen.f_error (cons V825 ())) ()))) -(defun shen.sys-error (V819) (simple-error (cn "system function " (shen.app V819 ": unexpected argument +(defun shen.sys-error (V826) (simple-error (cn "system function " (shen.app V826 ": unexpected argument " shen.a)))) diff --git a/shen/klambda/declarations.kl b/shen/klambda/declarations.kl index 22daf57..65f3a7c 100644 --- a/shen/klambda/declarations.kl +++ b/shen/klambda/declarations.kl @@ -73,7 +73,7 @@ (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 ()))))))))))))))))))))))))))) -(set shen.*special* (cons @p (cons @s (cons @v (cons cons (cons lambda (cons let (cons type (cons where (cons set (cons open ()))))))))))) +(set shen.*special* (cons @p (cons @s (cons @v (cons cons (cons lambda (cons let (cons where (cons set (cons open ())))))))))) (set shen.*extraspecial* (cons define (cons shen.process-datatype (cons input+ (cons defcc (cons read+ (cons defmacro ()))))))) @@ -109,21 +109,23 @@ (set shen.*optimise* false) -(defun shen.initialise_arity_table (V820) (cond ((= () V820) ()) ((and (cons? V820) (cons? (tl V820))) (let DecArity (put (hd V820) arity (hd (tl V820)) (value *property-vector*)) (shen.initialise_arity_table (tl (tl V820))))) (true (shen.sys-error shen.initialise_arity_table)))) +(set *version* "version 16") -(defun arity (V821) (trap-error (get V821 arity (value *property-vector*)) (lambda E -1))) +(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)))) -(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 intersection (cons 2 (cons kill (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 package (cons 3 (cons pos (cons 2 (cons print (cons 1 (cons profile (cons 1 (cons profile-results (cons 0 (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 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 shen.sum (cons 1 (cons symbol? (cons 1 (cons tail (cons 1 (cons tl (cons 1 (cons tc (cons 1 (cons tc? (cons 1 (cons thaw (cons 1 (cons tlstr (cons 1 (cons track (cons 1 (cons trap-error (cons 2 (cons tuple? (cons 1 (cons type (cons 1 (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 1 (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 (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 ()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) +(defun arity (V828) (trap-error (get V828 arity (value *property-vector*)) (lambda E -1))) -(defun systemf (V822) (let Shen (intern "shen") (let External (get Shen shen.external-symbols (value *property-vector*)) (put Shen shen.external-symbols (adjoin V822 External) (value *property-vector*))))) +(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 (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 ()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) -(defun adjoin (V823 V824) (if (element? V823 V824) V824 (cons V823 V824))) +(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*))))) -(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 (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 read (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 package (cons output (cons out (cons or (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 kill (cons is (cons intersection (cons inferences (cons intern (cons integer? (cons input (cons input+ (cons include (cons include-all-but (cons in (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*)) +(defun adjoin (V830 V831) (if (element? V830 V831) V831 (cons V830 V831))) -(defun specialise (V825) (do (set shen.*special* (cons V825 (value shen.*special*))) V825)) +(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 (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*)) -(defun unspecialise (V826) (do (set shen.*special* (remove V826 (value shen.*special*))) V826)) +(defun specialise (V832) (do (set shen.*special* (cons V832 (value shen.*special*))) V832)) + +(defun unspecialise (V833) (do (set shen.*special* (remove V833 (value shen.*special*))) V833)) diff --git a/shen/klambda/load.kl b/shen/klambda/load.kl index d526d93..e85c44b 100644 --- a/shen/klambda/load.kl +++ b/shen/klambda/load.kl @@ -47,38 +47,38 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun load (V827) (let Load (let Start (get-time run) (let Result (shen.load-help (value shen.*tc*) (read-file V827)) (let Finish (get-time run) (let Time (- Finish Start) (let Message (shen.prhush (cn " +"(defun load (V839) (let Load (let Start (get-time run) (let Result (shen.load-help (value shen.*tc*) (read-file V839)) (let Finish (get-time run) (let Time (- Finish Start) (let Message (shen.prhush (cn " run time: " (cn (str Time) " secs ")) (stoutput)) Result))))) (let Infs (if (value shen.*tc*) (shen.prhush (cn " typechecked in " (shen.app (inferences) " inferences " shen.a)) (stoutput)) shen.skip) loaded))) -(defun shen.load-help (V832 V833) (cond ((= false V832) (map (lambda X (shen.prhush (shen.app (shen.eval-without-macros X) " -" shen.s) (stoutput))) V833)) (true (let RemoveSynonyms (mapcan shen.remove-synonyms V833) (let Table (mapcan shen.typetable RemoveSynonyms) (let Assume (map shen.assumetype Table) (trap-error (map shen.typecheck-and-load RemoveSynonyms) (lambda E (shen.unwind-types E Table))))))))) +(defun shen.load-help (V844 V845) (cond ((= false V844) (map (lambda X (shen.prhush (shen.app (shen.eval-without-macros X) " +" shen.s) (stoutput))) V845)) (true (let RemoveSynonyms (mapcan (lambda X834 (shen.remove-synonyms X834)) V845) (let Table (mapcan (lambda X835 (shen.typetable X835)) RemoveSynonyms) (let Assume (map (lambda X836 (shen.assumetype X836)) Table) (trap-error (map (lambda X837 (shen.typecheck-and-load X837)) RemoveSynonyms) (lambda E (shen.unwind-types E Table))))))))) -(defun shen.remove-synonyms (V834) (cond ((and (cons? V834) (= shen.synonyms-help (hd V834))) (do (eval V834) ())) (true (cons V834 ())))) +(defun shen.remove-synonyms (V846) (cond ((and (cons? V846) (= shen.synonyms-help (hd V846))) (do (eval V846) ())) (true (cons V846 ())))) -(defun shen.typecheck-and-load (V835) (do (nl 1) (shen.typecheck-and-evaluate V835 (gensym A)))) +(defun shen.typecheck-and-load (V847) (do (nl 1) (shen.typecheck-and-evaluate V847 (gensym A)))) -(defun shen.typetable (V844) (cond ((and (cons? V844) (and (= define (hd V844)) (cons? (tl V844)))) (let Sig (compile shen. (tl (tl V844)) ()) (if (= Sig (fail)) (simple-error (shen.app (hd (tl V844)) " lacks a proper signature. -" shen.a)) (cons (cons (hd (tl V844)) Sig) ())))) ((and (cons? V844) (and (= defcc (hd V844)) (and (cons? (tl V844)) (and (cons? (tl (tl V844))) (and (= { (hd (tl (tl V844)))) (and (cons? (tl (tl (tl V844)))) (and (cons? (hd (tl (tl (tl V844))))) (and (= list (hd (hd (tl (tl (tl V844)))))) (and (cons? (tl (hd (tl (tl (tl V844)))))) (and (= () (tl (tl (hd (tl (tl (tl V844))))))) (and (cons? (tl (tl (tl (tl V844))))) (and (= ==> (hd (tl (tl (tl (tl V844)))))) (and (cons? (tl (tl (tl (tl (tl V844)))))) (and (cons? (tl (tl (tl (tl (tl (tl V844))))))) (= } (hd (tl (tl (tl (tl (tl (tl V844)))))))))))))))))))))) (cons (cons (hd (tl V844)) (cons (hd (tl (tl (tl V844)))) (cons ==> (cons (hd (tl (tl (tl (tl (tl V844)))))) ())))) ())) ((and (cons? V844) (and (= defcc (hd V844)) (cons? (tl V844)))) (simple-error (shen.app (hd (tl V844)) " lacks a proper signature. +(defun shen.typetable (V856) (cond ((and (cons? V856) (and (= define (hd V856)) (cons? (tl V856)))) (let Sig (compile (lambda X838 (shen. X838)) (tl (tl V856)) ()) (if (= Sig (fail)) (simple-error (shen.app (hd (tl V856)) " lacks a proper signature. +" shen.a)) (cons (cons (hd (tl V856)) Sig) ())))) ((and (cons? V856) (and (= defcc (hd V856)) (and (cons? (tl V856)) (and (cons? (tl (tl V856))) (and (= { (hd (tl (tl V856)))) (and (cons? (tl (tl (tl V856)))) (and (cons? (hd (tl (tl (tl V856))))) (and (= list (hd (hd (tl (tl (tl V856)))))) (and (cons? (tl (hd (tl (tl (tl V856)))))) (and (= () (tl (tl (hd (tl (tl (tl V856))))))) (and (cons? (tl (tl (tl (tl V856))))) (and (= ==> (hd (tl (tl (tl (tl V856)))))) (and (cons? (tl (tl (tl (tl (tl V856)))))) (and (cons? (tl (tl (tl (tl (tl (tl V856))))))) (= } (hd (tl (tl (tl (tl (tl (tl V856)))))))))))))))))))))) (cons (cons (hd (tl V856)) (cons (hd (tl (tl (tl V856)))) (cons ==> (cons (hd (tl (tl (tl (tl (tl V856)))))) ())))) ())) ((and (cons? V856) (and (= defcc (hd V856)) (cons? (tl V856)))) (simple-error (shen.app (hd (tl V856)) " lacks a proper signature. " shen.a))) (true ()))) -(defun shen.assumetype (V845) (cond ((cons? V845) (declare (hd V845) (tl V845))) (true (shen.sys-error shen.assumetype)))) +(defun shen.assumetype (V857) (cond ((cons? V857) (declare (hd V857) (tl V857))) (true (shen.sys-error shen.assumetype)))) -(defun shen.unwind-types (V850 V851) (cond ((= () V851) (simple-error (error-to-string V850))) ((and (cons? V851) (cons? (hd V851))) (do (shen.remtype (hd (hd V851))) (shen.unwind-types V850 (tl V851)))) (true (shen.sys-error shen.unwind-types)))) +(defun shen.unwind-types (V862 V863) (cond ((= () V863) (simple-error (error-to-string V862))) ((and (cons? V863) (cons? (hd V863))) (do (shen.remtype (hd (hd V863))) (shen.unwind-types V862 (tl V863)))) (true (shen.sys-error shen.unwind-types)))) -(defun shen.remtype (V852) (set shen.*signedfuncs* (shen.removetype V852 (value shen.*signedfuncs*)))) +(defun shen.remtype (V864) (set shen.*signedfuncs* (shen.removetype V864 (value shen.*signedfuncs*)))) -(defun shen.removetype (V857 V858) (cond ((= () V858) ()) ((and (cons? V858) (and (cons? (hd V858)) (= (hd (hd V858)) V857))) (shen.removetype (hd (hd V858)) (tl V858))) ((cons? V858) (cons (hd V858) (shen.removetype V857 (tl V858)))) (true (shen.sys-error shen.removetype)))) +(defun shen.removetype (V869 V870) (cond ((= () V870) ()) ((and (cons? V870) (and (cons? (hd V870)) (= (hd (hd V870)) V869))) (shen.removetype (hd (hd V870)) (tl V870))) ((cons? V870) (cons (hd V870) (shen.removetype V869 (tl V870)))) (true (shen.sys-error shen.removetype)))) -(defun shen. (V864) (let Result (let Parse_shen. (shen. V864) (if (not (= (fail) Parse_shen.)) (let Parse_ ( Parse_shen.) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V876) (let Result (let Parse_shen. (shen. V876) (if (not (= (fail) Parse_shen.)) (let Parse_ ( Parse_shen.) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) -(defun write-to-file (V865 V866) (let Stream (open file V865 out) (let String (if (string? V866) (shen.app V866 " +(defun write-to-file (V877 V878) (let Stream (open V877 out) (let String (if (string? V878) (shen.app V878 " -" shen.a) (shen.app V866 " +" shen.a) (shen.app V878 " -" shen.s)) (let Write (pr String Stream) (let Close (close Stream) V866))))) +" shen.s)) (let Write (pr String Stream) (let Close (close Stream) V878))))) diff --git a/shen/klambda/macros.kl b/shen/klambda/macros.kl index 06d89ae..16fa210 100644 --- a/shen/klambda/macros.kl +++ b/shen/klambda/macros.kl @@ -47,78 +47,66 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun macroexpand (V868) (let Y (shen.compose (value *macros*) V868) (if (= V868 Y) V868 (shen.walk (lambda V867 (macroexpand V867)) Y)))) +"(defun macroexpand (V882) (let Y (shen.compose (value *macros*) V882) (if (= V882 Y) V882 (shen.walk (lambda X879 (macroexpand X879)) Y)))) (set *macros* (cons shen.timer-macro (cons shen.cases-macro (cons shen.abs-macro (cons shen.put/get-macro (cons shen.compile-macro (cons shen.datatype-macro (cons shen.let-macro (cons shen.assoc-macro (cons shen.make-string-macro (cons shen.output-macro (cons shen.input-macro (cons shen.error-macro (cons shen.prolog-macro (cons shen.synonyms-macro (cons shen.nl-macro (cons shen.@s-macro (cons shen.defprolog-macro (cons shen.function-macro ()))))))))))))))))))) -(defun shen.error-macro (V869) (cond ((and (cons? V869) (and (= error (hd V869)) (cons? (tl V869)))) (cons simple-error (cons (shen.mkstr (hd (tl V869)) (tl (tl V869))) ()))) (true V869))) +(defun shen.error-macro (V883) (cond ((and (cons? V883) (and (= error (hd V883)) (cons? (tl V883)))) (cons simple-error (cons (shen.mkstr (hd (tl V883)) (tl (tl V883))) ()))) (true V883))) -(defun shen.output-macro (V870) (cond ((and (cons? V870) (and (= output (hd V870)) (cons? (tl V870)))) (cons shen.prhush (cons (shen.mkstr (hd (tl V870)) (tl (tl V870))) (cons (cons stoutput ()) ())))) ((and (cons? V870) (and (= pr (hd V870)) (and (cons? (tl V870)) (= () (tl (tl V870)))))) (cons pr (cons (hd (tl V870)) (cons (cons stoutput ()) ())))) (true V870))) +(defun shen.output-macro (V884) (cond ((and (cons? V884) (and (= output (hd V884)) (cons? (tl V884)))) (cons shen.prhush (cons (shen.mkstr (hd (tl V884)) (tl (tl V884))) (cons (cons stoutput ()) ())))) ((and (cons? V884) (and (= pr (hd V884)) (and (cons? (tl V884)) (= () (tl (tl V884)))))) (cons pr (cons (hd (tl V884)) (cons (cons stoutput ()) ())))) (true V884))) -(defun shen.make-string-macro (V871) (cond ((and (cons? V871) (and (= make-string (hd V871)) (cons? (tl V871)))) (shen.mkstr (hd (tl V871)) (tl (tl V871)))) (true V871))) +(defun shen.make-string-macro (V885) (cond ((and (cons? V885) (and (= make-string (hd V885)) (cons? (tl V885)))) (shen.mkstr (hd (tl V885)) (tl (tl V885)))) (true V885))) -(defun shen.input-macro (V872) (cond ((and (cons? V872) (and (= lineread (hd V872)) (= () (tl V872)))) (cons lineread (cons (cons stinput ()) ()))) ((and (cons? V872) (and (= input (hd V872)) (= () (tl V872)))) (cons input (cons (cons stinput ()) ()))) ((and (cons? V872) (and (= read (hd V872)) (= () (tl V872)))) (cons read (cons (cons stinput ()) ()))) ((and (cons? V872) (and (= input+ (hd V872)) (and (cons? (tl V872)) (= () (tl (tl V872)))))) (cons input+ (cons (hd (tl V872)) (cons (cons stinput ()) ())))) ((and (cons? V872) (and (= read+ (hd V872)) (and (cons? (tl V872)) (= () (tl (tl V872)))))) (cons read+ (cons (hd (tl V872)) (cons (cons stinput ()) ())))) (true V872))) +(defun shen.input-macro (V886) (cond ((and (cons? V886) (and (= lineread (hd V886)) (= () (tl V886)))) (cons lineread (cons (cons stinput ()) ()))) ((and (cons? V886) (and (= input (hd V886)) (= () (tl V886)))) (cons input (cons (cons stinput ()) ()))) ((and (cons? V886) (and (= read (hd V886)) (= () (tl V886)))) (cons read (cons (cons stinput ()) ()))) ((and (cons? V886) (and (= input+ (hd V886)) (and (cons? (tl V886)) (= () (tl (tl V886)))))) (cons input+ (cons (hd (tl V886)) (cons (cons stinput ()) ())))) ((and (cons? V886) (and (= read-byte (hd V886)) (= () (tl V886)))) (cons read-byte (cons (cons stinput ()) ()))) (true V886))) -(defun shen.compose (V873 V874) (cond ((= () V873) V874) ((cons? V873) (shen.compose (tl V873) ((hd V873) V874))) (true (shen.sys-error shen.compose)))) +(defun shen.compose (V887 V888) (cond ((= () V887) V888) ((cons? V887) (shen.compose (tl V887) ((hd V887) V888))) (true (shen.sys-error shen.compose)))) -(defun shen.compile-macro (V875) (cond ((and (cons? V875) (and (= compile (hd V875)) (and (cons? (tl V875)) (and (cons? (tl (tl V875))) (= () (tl (tl (tl V875)))))))) (cons compile (cons (hd (tl V875)) (cons (hd (tl (tl V875))) (cons (cons lambda (cons E (cons (cons if (cons (cons cons? (cons E ())) (cons (cons error (cons "parse error here: ~S~%" (cons E ()))) (cons (cons error (cons "parse error~%" ())) ())))) ()))) ()))))) (true V875))) +(defun shen.compile-macro (V889) (cond ((and (cons? V889) (and (= compile (hd V889)) (and (cons? (tl V889)) (and (cons? (tl (tl V889))) (= () (tl (tl (tl V889)))))))) (cons compile (cons (hd (tl V889)) (cons (hd (tl (tl V889))) (cons (cons lambda (cons E (cons (cons if (cons (cons cons? (cons E ())) (cons (cons error (cons "parse error here: ~S~%" (cons E ()))) (cons (cons error (cons "parse error~%" ())) ())))) ()))) ()))))) (true V889))) -(defun shen.prolog-macro (V876) (cond ((and (cons? V876) (= prolog? (hd V876))) (cons shen.intprolog (cons (shen.prolog-form (tl V876)) ()))) (true V876))) +(defun shen.prolog-macro (V890) (cond ((and (cons? V890) (= prolog? (hd V890))) (let F (gensym shen.f) (let Receive (shen.receive-terms (tl V890)) (let PrologDef (eval (append (cons defprolog (cons F ())) (append Receive (append (cons <-- ()) (append (shen.pass-literals (tl V890)) (cons ; ())))))) (let Query (cons F (append Receive (cons (cons shen.start-new-prolog-process ()) (cons (cons freeze (cons true ())) ())))) Query))))) (true V890))) -(defun shen.defprolog-macro (V877) (cond ((and (cons? V877) (and (= defprolog (hd V877)) (cons? (tl V877)))) (compile shen. (tl V877) (lambda Y (shen.prolog-error (hd (tl V877)) Y)))) (true V877))) +(defun shen.receive-terms (V895) (cond ((= () V895) ()) ((and (cons? V895) (and (cons? (hd V895)) (and (= receive (hd (hd V895))) (and (cons? (tl (hd V895))) (= () (tl (tl (hd V895)))))))) (cons (hd (tl (hd V895))) (shen.receive-terms (tl V895)))) ((cons? V895) (shen.receive-terms (tl V895))) (true (shen.sys-error shen.receive-terms)))) -(defun shen.prolog-form (V878) (shen.cons_form (map shen.cons_form V878))) +(defun shen.pass-literals (V898) (cond ((= () V898) ()) ((and (cons? V898) (and (cons? (hd V898)) (and (= receive (hd (hd V898))) (and (cons? (tl (hd V898))) (= () (tl (tl (hd V898)))))))) (shen.pass-literals (tl V898))) ((cons? V898) (cons (hd V898) (shen.pass-literals (tl V898)))) (true (shen.sys-error shen.pass-literals)))) -(defun shen.datatype-macro (V879) (cond ((and (cons? V879) (and (= datatype (hd V879)) (cons? (tl V879)))) (cons shen.process-datatype (cons (shen.intern-type (hd (tl V879))) (cons (cons compile (cons (cons function (cons shen. ())) (cons (shen.rcons_form (tl (tl V879))) (cons (cons function (cons shen.datatype-error ())) ())))) ())))) (true V879))) +(defun shen.defprolog-macro (V899) (cond ((and (cons? V899) (and (= defprolog (hd V899)) (cons? (tl V899)))) (compile (lambda X880 (shen. X880)) (tl V899) (lambda Y (shen.prolog-error (hd (tl V899)) Y)))) (true V899))) -(defun shen.intern-type (V880) (intern (cn "type#" (str V880)))) +(defun shen.datatype-macro (V900) (cond ((and (cons? V900) (and (= datatype (hd V900)) (cons? (tl V900)))) (cons shen.process-datatype (cons (shen.intern-type (hd (tl V900))) (cons (cons compile (cons (cons function (cons shen. ())) (cons (shen.rcons_form (tl (tl V900))) (cons (cons function (cons shen.datatype-error ())) ())))) ())))) (true V900))) -"(defcc - := [define | ];) - -(defcc - ; - := (append [(protect X) -> (protect X)]);) - -(defcc - -> where ; - -> ; - <- where ; - <- ;) - -(defcc - := [[walk [function macroexpand] ]];)" +(defun shen.intern-type (V901) (intern (cn "type#" (str V901)))) -(defun shen.@s-macro (V881) (cond ((and (cons? V881) (and (= @s (hd V881)) (and (cons? (tl V881)) (and (cons? (tl (tl V881))) (cons? (tl (tl (tl V881)))))))) (cons @s (cons (hd (tl V881)) (cons (shen.@s-macro (cons @s (tl (tl V881)))) ())))) ((and (cons? V881) (and (= @s (hd V881)) (and (cons? (tl V881)) (and (cons? (tl (tl V881))) (and (= () (tl (tl (tl V881)))) (string? (hd (tl V881)))))))) (let E (explode (hd (tl V881))) (if (> (length E) 1) (shen.@s-macro (cons @s (append E (tl (tl V881))))) V881))) (true V881))) +(defun shen.@s-macro (V902) (cond ((and (cons? V902) (and (= @s (hd V902)) (and (cons? (tl V902)) (and (cons? (tl (tl V902))) (cons? (tl (tl (tl V902)))))))) (cons @s (cons (hd (tl V902)) (cons (shen.@s-macro (cons @s (tl (tl V902)))) ())))) ((and (cons? V902) (and (= @s (hd V902)) (and (cons? (tl V902)) (and (cons? (tl (tl V902))) (and (= () (tl (tl (tl V902)))) (string? (hd (tl V902)))))))) (let E (explode (hd (tl V902))) (if (> (length E) 1) (shen.@s-macro (cons @s (append E (tl (tl V902))))) V902))) (true V902))) -(defun shen.synonyms-macro (V882) (cond ((and (cons? V882) (= synonyms (hd V882))) (cons shen.synonyms-help (cons (shen.rcons_form (tl V882)) ()))) (true V882))) +(defun shen.synonyms-macro (V903) (cond ((and (cons? V903) (= synonyms (hd V903))) (cons shen.synonyms-help (cons (shen.rcons_form (shen.curry-synonyms (tl V903))) ()))) (true V903))) -(defun shen.nl-macro (V883) (cond ((and (cons? V883) (and (= nl (hd V883)) (= () (tl V883)))) (cons nl (cons 1 ()))) (true V883))) +(defun shen.curry-synonyms (V904) (map (lambda X881 (shen.curry-type X881)) V904)) -(defun shen.assoc-macro (V884) (cond ((and (cons? V884) (and (cons? (tl V884)) (and (cons? (tl (tl V884))) (and (cons? (tl (tl (tl V884)))) (element? (hd V884) (cons @p (cons @v (cons append (cons and (cons or (cons + (cons * (cons do ()))))))))))))) (cons (hd V884) (cons (hd (tl V884)) (cons (shen.assoc-macro (cons (hd V884) (tl (tl V884)))) ())))) (true V884))) +(defun shen.nl-macro (V905) (cond ((and (cons? V905) (and (= nl (hd V905)) (= () (tl V905)))) (cons nl (cons 1 ()))) (true V905))) -(defun shen.let-macro (V885) (cond ((and (cons? V885) (and (= let (hd V885)) (and (cons? (tl V885)) (and (cons? (tl (tl V885))) (and (cons? (tl (tl (tl V885)))) (cons? (tl (tl (tl (tl V885)))))))))) (cons let (cons (hd (tl V885)) (cons (hd (tl (tl V885))) (cons (shen.let-macro (cons let (tl (tl (tl V885))))) ()))))) (true V885))) +(defun shen.assoc-macro (V906) (cond ((and (cons? V906) (and (cons? (tl V906)) (and (cons? (tl (tl V906))) (and (cons? (tl (tl (tl V906)))) (element? (hd V906) (cons @p (cons @v (cons append (cons and (cons or (cons + (cons * (cons do ()))))))))))))) (cons (hd V906) (cons (hd (tl V906)) (cons (shen.assoc-macro (cons (hd V906) (tl (tl V906)))) ())))) (true V906))) -(defun shen.abs-macro (V886) (cond ((and (cons? V886) (and (= /. (hd V886)) (and (cons? (tl V886)) (and (cons? (tl (tl V886))) (cons? (tl (tl (tl V886)))))))) (cons lambda (cons (hd (tl V886)) (cons (shen.abs-macro (cons /. (tl (tl V886)))) ())))) ((and (cons? V886) (and (= /. (hd V886)) (and (cons? (tl V886)) (and (cons? (tl (tl V886))) (= () (tl (tl (tl V886)))))))) (cons lambda (tl V886))) (true V886))) +(defun shen.let-macro (V907) (cond ((and (cons? V907) (and (= let (hd V907)) (and (cons? (tl V907)) (and (cons? (tl (tl V907))) (and (cons? (tl (tl (tl V907)))) (cons? (tl (tl (tl (tl V907)))))))))) (cons let (cons (hd (tl V907)) (cons (hd (tl (tl V907))) (cons (shen.let-macro (cons let (tl (tl (tl V907))))) ()))))) (true V907))) -(defun shen.cases-macro (V889) (cond ((and (cons? V889) (and (= cases (hd V889)) (and (cons? (tl V889)) (and (= true (hd (tl V889))) (cons? (tl (tl V889))))))) (hd (tl (tl V889)))) ((and (cons? V889) (and (= cases (hd V889)) (and (cons? (tl V889)) (and (cons? (tl (tl V889))) (= () (tl (tl (tl V889)))))))) (cons if (cons (hd (tl V889)) (cons (hd (tl (tl V889))) (cons (cons simple-error (cons "error: cases exhausted" ())) ()))))) ((and (cons? V889) (and (= cases (hd V889)) (and (cons? (tl V889)) (cons? (tl (tl V889)))))) (cons if (cons (hd (tl V889)) (cons (hd (tl (tl V889))) (cons (shen.cases-macro (cons cases (tl (tl (tl V889))))) ()))))) ((and (cons? V889) (and (= cases (hd V889)) (and (cons? (tl V889)) (= () (tl (tl V889)))))) (simple-error "error: odd number of case elements -")) (true V889))) +(defun shen.abs-macro (V908) (cond ((and (cons? V908) (and (= /. (hd V908)) (and (cons? (tl V908)) (and (cons? (tl (tl V908))) (cons? (tl (tl (tl V908)))))))) (cons lambda (cons (hd (tl V908)) (cons (shen.abs-macro (cons /. (tl (tl V908)))) ())))) ((and (cons? V908) (and (= /. (hd V908)) (and (cons? (tl V908)) (and (cons? (tl (tl V908))) (= () (tl (tl (tl V908)))))))) (cons lambda (tl V908))) (true V908))) -(defun shen.timer-macro (V890) (cond ((and (cons? V890) (and (= time (hd V890)) (and (cons? (tl V890)) (= () (tl (tl V890)))))) (shen.let-macro (cons let (cons Start (cons (cons get-time (cons run ())) (cons Result (cons (hd (tl V890)) (cons Finish (cons (cons get-time (cons run ())) (cons Time (cons (cons - (cons Finish (cons Start ()))) (cons Message (cons (cons shen.prhush (cons (cons cn (cons " +(defun shen.cases-macro (V911) (cond ((and (cons? V911) (and (= cases (hd V911)) (and (cons? (tl V911)) (and (= true (hd (tl V911))) (cons? (tl (tl V911))))))) (hd (tl (tl V911)))) ((and (cons? V911) (and (= cases (hd V911)) (and (cons? (tl V911)) (and (cons? (tl (tl V911))) (= () (tl (tl (tl V911)))))))) (cons if (cons (hd (tl V911)) (cons (hd (tl (tl V911))) (cons (cons simple-error (cons "error: cases exhausted" ())) ()))))) ((and (cons? V911) (and (= cases (hd V911)) (and (cons? (tl V911)) (cons? (tl (tl V911)))))) (cons if (cons (hd (tl V911)) (cons (hd (tl (tl V911))) (cons (shen.cases-macro (cons cases (tl (tl (tl V911))))) ()))))) ((and (cons? V911) (and (= cases (hd V911)) (and (cons? (tl V911)) (= () (tl (tl V911)))))) (simple-error "error: odd number of case elements +")) (true V911))) + +(defun shen.timer-macro (V912) (cond ((and (cons? V912) (and (= time (hd V912)) (and (cons? (tl V912)) (= () (tl (tl V912)))))) (shen.let-macro (cons let (cons Start (cons (cons get-time (cons run ())) (cons Result (cons (hd (tl V912)) (cons Finish (cons (cons get-time (cons run ())) (cons Time (cons (cons - (cons Finish (cons Start ()))) (cons Message (cons (cons shen.prhush (cons (cons cn (cons " run time: " (cons (cons cn (cons (cons str (cons Time ())) (cons " secs -" ()))) ()))) (cons (cons stoutput ()) ()))) (cons Result ())))))))))))))) (true V890))) +" ()))) ()))) (cons (cons stoutput ()) ()))) (cons Result ())))))))))))))) (true V912))) -(defun shen.tuple-up (V891) (cond ((cons? V891) (cons @p (cons (hd V891) (cons (shen.tuple-up (tl V891)) ())))) (true V891))) +(defun shen.tuple-up (V913) (cond ((cons? V913) (cons @p (cons (hd V913) (cons (shen.tuple-up (tl V913)) ())))) (true V913))) -(defun shen.put/get-macro (V892) (cond ((and (cons? V892) (and (= put (hd V892)) (and (cons? (tl V892)) (and (cons? (tl (tl V892))) (and (cons? (tl (tl (tl V892)))) (= () (tl (tl (tl (tl V892)))))))))) (cons put (cons (hd (tl V892)) (cons (hd (tl (tl V892))) (cons (hd (tl (tl (tl V892)))) (cons (cons value (cons *property-vector* ())) ())))))) ((and (cons? V892) (and (= get (hd V892)) (and (cons? (tl V892)) (and (cons? (tl (tl V892))) (= () (tl (tl (tl V892)))))))) (cons get (cons (hd (tl V892)) (cons (hd (tl (tl V892))) (cons (cons value (cons *property-vector* ())) ()))))) (true V892))) +(defun shen.put/get-macro (V914) (cond ((and (cons? V914) (and (= put (hd V914)) (and (cons? (tl V914)) (and (cons? (tl (tl V914))) (and (cons? (tl (tl (tl V914)))) (= () (tl (tl (tl (tl V914)))))))))) (cons put (cons (hd (tl V914)) (cons (hd (tl (tl V914))) (cons (hd (tl (tl (tl V914)))) (cons (cons value (cons *property-vector* ())) ())))))) ((and (cons? V914) (and (= get (hd V914)) (and (cons? (tl V914)) (and (cons? (tl (tl V914))) (= () (tl (tl (tl V914)))))))) (cons get (cons (hd (tl V914)) (cons (hd (tl (tl V914))) (cons (cons value (cons *property-vector* ())) ()))))) (true V914))) -(defun shen.function-macro (V893) (cond ((and (cons? V893) (and (= function (hd V893)) (and (cons? (tl V893)) (= () (tl (tl V893)))))) (shen.function-abstraction (hd (tl V893)) (arity (hd (tl V893))))) (true V893))) +(defun shen.function-macro (V915) (cond ((and (cons? V915) (and (= function (hd V915)) (and (cons? (tl V915)) (= () (tl (tl V915)))))) (shen.function-abstraction (hd (tl V915)) (arity (hd (tl V915))))) (true V915))) -(defun shen.function-abstraction (V894 V895) (cond ((= 0 V895) (cons freeze (cons V894 ()))) ((= -1 V895) V894) (true (shen.function-abstraction-help V894 V895 ())))) +(defun shen.function-abstraction (V916 V917) (cond ((= 0 V917) (cons freeze (cons V916 ()))) ((= -1 V917) V916) (true (shen.function-abstraction-help V916 V917 ())))) -(defun shen.function-abstraction-help (V896 V897 V898) (cond ((= 0 V897) (cons V896 V898)) (true (let X (gensym V) (cons /. (cons X (cons (shen.function-abstraction-help V896 (- V897 1) (append V898 (cons X ()))) ()))))))) +(defun shen.function-abstraction-help (V918 V919 V920) (cond ((= 0 V919) (cons V918 V920)) (true (let X (gensym V) (cons /. (cons X (cons (shen.function-abstraction-help V918 (- V919 1) (append V920 (cons X ()))) ()))))))) -(defun undefmacro (V899) (do (set *macros* (remove V899 (value *macros*))) V899)) +(defun undefmacro (V921) (do (set *macros* (remove V921 (value *macros*))) V921)) diff --git a/shen/klambda/prolog.kl b/shen/klambda/prolog.kl index 5ddd356..a08a4d7 100644 --- a/shen/klambda/prolog.kl +++ b/shen/klambda/prolog.kl @@ -47,206 +47,206 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun shen. (V906) (let Result (let Parse_shen. (shen. V906) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (hd (shen.prolog->shen (map (lambda Parse_X (shen.insert-predicate (shen.hdtl Parse_shen.) Parse_X)) (shen.hdtl Parse_shen.))))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) +"(defun shen. (V937) (let Result (let Parse_shen. (shen. V937) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (hd (shen.prolog->shen (map (lambda Parse_X (shen.insert-predicate (shen.hdtl Parse_shen.) Parse_X)) (shen.hdtl Parse_shen.))))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen.prolog-error (V913 V914) (cond ((and (cons? V914) (and (cons? (tl V914)) (= () (tl (tl V914))))) (simple-error (cn "prolog syntax error in " (shen.app V913 (cn " here: +(defun shen.prolog-error (V944 V945) (cond ((and (cons? V945) (and (cons? (tl V945)) (= () (tl (tl V945))))) (simple-error (cn "prolog syntax error in " (shen.app V944 (cn " here: - " (shen.app (shen.next-50 50 (hd V914)) " -" shen.a)) shen.a)))) (true (simple-error (cn "prolog syntax error in " (shen.app V913 " + " (shen.app (shen.next-50 50 (hd V945)) " +" shen.a)) shen.a)))) (true (simple-error (cn "prolog syntax error in " (shen.app V944 " " shen.a)))))) -(defun shen.next-50 (V919 V920) (cond ((= () V920) "") ((= 0 V919) "") ((cons? V920) (cn (shen.decons-string (hd V920)) (shen.next-50 (- V919 1) (tl V920)))) (true (shen.sys-error shen.next-50)))) +(defun shen.next-50 (V950 V951) (cond ((= () V951) "") ((= 0 V950) "") ((cons? V951) (cn (shen.decons-string (hd V951)) (shen.next-50 (- V950 1) (tl V951)))) (true (shen.sys-error shen.next-50)))) -(defun shen.decons-string (V921) (cond ((and (cons? V921) (and (= cons (hd V921)) (and (cons? (tl V921)) (and (cons? (tl (tl V921))) (= () (tl (tl (tl V921)))))))) (shen.app (shen.eval-cons V921) " " shen.s)) (true (shen.app V921 " " shen.r)))) +(defun shen.decons-string (V952) (cond ((and (cons? V952) (and (= cons (hd V952)) (and (cons? (tl V952)) (and (cons? (tl (tl V952))) (= () (tl (tl (tl V952)))))))) (shen.app (shen.eval-cons V952) " " shen.s)) (true (shen.app V952 " " shen.r)))) -(defun shen.insert-predicate (V922 V923) (cond ((and (cons? V923) (and (cons? (tl V923)) (= () (tl (tl V923))))) (cons (cons V922 (hd V923)) (cons :- (tl V923)))) (true (shen.sys-error shen.insert-predicate)))) +(defun shen.insert-predicate (V953 V954) (cond ((and (cons? V954) (and (cons? (tl V954)) (= () (tl (tl V954))))) (cons (cons V953 (hd V954)) (cons :- (tl V954)))) (true (shen.sys-error shen.insert-predicate)))) -(defun shen. (V928) (let Result (if (cons? (hd V928)) (let Parse_X (hd (hd V928)) (shen.pair (hd (shen.pair (tl (hd V928)) (shen.hdtl V928))) Parse_X)) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V959) (let Result (if (cons? (hd V959)) (let Parse_X (hd (hd V959)) (shen.pair (hd (shen.pair (tl (hd V959)) (shen.hdtl V959))) Parse_X)) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V933) (let Result (let Parse_shen. (shen. V933) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V933) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) (append (shen.hdtl Parse_) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V964) (let Result (let Parse_shen. (shen. V964) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V964) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) (append (shen.hdtl Parse_) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V938) (let Result (let Parse_shen. (shen. V938) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= <-- (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))) (fail))) (fail))) (fail)) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V969) (let Result (let Parse_shen. (shen. V969) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= <-- (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))) (fail))) (fail))) (fail)) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V943) (let Result (let Parse_shen. (shen. V943) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V943) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) (append (shen.hdtl Parse_) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V974) (let Result (let Parse_shen. (shen. V974) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V974) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) (append (shen.hdtl Parse_) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V948) (let Result (if (cons? (hd V948)) (let Parse_X (hd (hd V948)) (if (and (not (= <-- Parse_X)) (shen.legitimate-term? Parse_X)) (shen.pair (hd (shen.pair (tl (hd V948)) (shen.hdtl V948))) (shen.eval-cons Parse_X)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V979) (let Result (if (cons? (hd V979)) (let Parse_X (hd (hd V979)) (if (and (not (= <-- Parse_X)) (shen.legitimate-term? Parse_X)) (shen.pair (hd (shen.pair (tl (hd V979)) (shen.hdtl V979))) (shen.eval-cons Parse_X)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen.legitimate-term? (V953) (cond ((and (cons? V953) (and (= cons (hd V953)) (and (cons? (tl V953)) (and (cons? (tl (tl V953))) (= () (tl (tl (tl V953)))))))) (and (shen.legitimate-term? (hd (tl V953))) (shen.legitimate-term? (hd (tl (tl V953)))))) ((and (cons? V953) (and (= mode (hd V953)) (and (cons? (tl V953)) (and (cons? (tl (tl V953))) (and (= + (hd (tl (tl V953)))) (= () (tl (tl (tl V953))))))))) (shen.legitimate-term? (hd (tl V953)))) ((and (cons? V953) (and (= mode (hd V953)) (and (cons? (tl V953)) (and (cons? (tl (tl V953))) (and (= - (hd (tl (tl V953)))) (= () (tl (tl (tl V953))))))))) (shen.legitimate-term? (hd (tl V953)))) ((cons? V953) false) (true true))) +(defun shen.legitimate-term? (V984) (cond ((and (cons? V984) (and (= cons (hd V984)) (and (cons? (tl V984)) (and (cons? (tl (tl V984))) (= () (tl (tl (tl V984)))))))) (and (shen.legitimate-term? (hd (tl V984))) (shen.legitimate-term? (hd (tl (tl V984)))))) ((and (cons? V984) (and (= mode (hd V984)) (and (cons? (tl V984)) (and (cons? (tl (tl V984))) (and (= + (hd (tl (tl V984)))) (= () (tl (tl (tl V984))))))))) (shen.legitimate-term? (hd (tl V984)))) ((and (cons? V984) (and (= mode (hd V984)) (and (cons? (tl V984)) (and (cons? (tl (tl V984))) (and (= - (hd (tl (tl V984)))) (= () (tl (tl (tl V984))))))))) (shen.legitimate-term? (hd (tl V984)))) ((cons? V984) false) (true true))) -(defun shen.eval-cons (V954) (cond ((and (cons? V954) (and (= cons (hd V954)) (and (cons? (tl V954)) (and (cons? (tl (tl V954))) (= () (tl (tl (tl V954)))))))) (cons (shen.eval-cons (hd (tl V954))) (shen.eval-cons (hd (tl (tl V954)))))) ((and (cons? V954) (and (= mode (hd V954)) (and (cons? (tl V954)) (and (cons? (tl (tl V954))) (= () (tl (tl (tl V954)))))))) (cons mode (cons (shen.eval-cons (hd (tl V954))) (tl (tl V954))))) (true V954))) +(defun shen.eval-cons (V985) (cond ((and (cons? V985) (and (= cons (hd V985)) (and (cons? (tl V985)) (and (cons? (tl (tl V985))) (= () (tl (tl (tl V985)))))))) (cons (shen.eval-cons (hd (tl V985))) (shen.eval-cons (hd (tl (tl V985)))))) ((and (cons? V985) (and (= mode (hd V985)) (and (cons? (tl V985)) (and (cons? (tl (tl V985))) (= () (tl (tl (tl V985)))))))) (cons mode (cons (shen.eval-cons (hd (tl V985))) (tl (tl V985))))) (true V985))) -(defun shen. (V959) (let Result (let Parse_shen. (shen. V959) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V959) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) (append (shen.hdtl Parse_) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V990) (let Result (let Parse_shen. (shen. V990) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V990) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) (append (shen.hdtl Parse_) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V964) (let Result (if (and (cons? (hd V964)) (= ! (hd (hd V964)))) (shen.pair (hd (shen.pair (tl (hd V964)) (shen.hdtl V964))) (cons cut (cons (intern "Throwcontrol") ()))) (fail)) (if (= Result (fail)) (let Result (if (cons? (hd V964)) (let Parse_X (hd (hd V964)) (if (cons? Parse_X) (shen.pair (hd (shen.pair (tl (hd V964)) (shen.hdtl V964))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V995) (let Result (if (and (cons? (hd V995)) (= ! (hd (hd V995)))) (shen.pair (hd (shen.pair (tl (hd V995)) (shen.hdtl V995))) (cons cut (cons (intern "Throwcontrol") ()))) (fail)) (if (= Result (fail)) (let Result (if (cons? (hd V995)) (let Parse_X (hd (hd V995)) (if (cons? Parse_X) (shen.pair (hd (shen.pair (tl (hd V995)) (shen.hdtl V995))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V969) (let Result (if (cons? (hd V969)) (let Parse_X (hd (hd V969)) (if (= Parse_X ;) (shen.pair (hd (shen.pair (tl (hd V969)) (shen.hdtl V969))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1000) (let Result (if (cons? (hd V1000)) (let Parse_X (hd (hd V1000)) (if (= Parse_X ;) (shen.pair (hd (shen.pair (tl (hd V1000)) (shen.hdtl V1000))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun cut (V970 V971 V972) (let Result (thaw V972) (if (= Result false) V970 Result))) +(defun cut (V1001 V1002 V1003) (let Result (thaw V1003) (if (= Result false) V1001 Result))) -(defun shen.insert_modes (V973) (cond ((and (cons? V973) (and (= mode (hd V973)) (and (cons? (tl V973)) (and (cons? (tl (tl V973))) (= () (tl (tl (tl V973)))))))) V973) ((= () V973) ()) ((cons? V973) (cons (cons mode (cons (hd V973) (cons + ()))) (cons mode (cons (shen.insert_modes (tl V973)) (cons - ()))))) (true V973))) +(defun shen.insert_modes (V1004) (cond ((and (cons? V1004) (and (= mode (hd V1004)) (and (cons? (tl V1004)) (and (cons? (tl (tl V1004))) (= () (tl (tl (tl V1004)))))))) V1004) ((= () V1004) ()) ((cons? V1004) (cons (cons mode (cons (hd V1004) (cons + ()))) (cons mode (cons (shen.insert_modes (tl V1004)) (cons - ()))))) (true V1004))) -(defun shen.s-prolog (V974) (map (lambda V900 (eval V900)) (shen.prolog->shen V974))) +(defun shen.s-prolog (V1005) (map (lambda X922 (eval X922)) (shen.prolog->shen V1005))) -(defun shen.prolog->shen (V975) (map shen.compile_prolog_procedure (shen.group_clauses (map shen.s-prolog_clause (mapcan shen.head_abstraction V975))))) +(defun shen.prolog->shen (V1006) (map (lambda X923 (shen.compile_prolog_procedure X923)) (shen.group_clauses (map (lambda X924 (shen.s-prolog_clause X924)) (mapcan (lambda X925 (shen.head_abstraction X925)) V1006))))) -(defun shen.s-prolog_clause (V976) (cond ((and (cons? V976) (and (cons? (tl V976)) (and (= :- (hd (tl V976))) (and (cons? (tl (tl V976))) (= () (tl (tl (tl V976)))))))) (cons (hd V976) (cons :- (cons (map shen.s-prolog_literal (hd (tl (tl V976)))) ())))) (true (shen.sys-error shen.s-prolog_clause)))) +(defun shen.s-prolog_clause (V1007) (cond ((and (cons? V1007) (and (cons? (tl V1007)) (and (= :- (hd (tl V1007))) (and (cons? (tl (tl V1007))) (= () (tl (tl (tl V1007)))))))) (cons (hd V1007) (cons :- (cons (map (lambda X926 (shen.s-prolog_literal X926)) (hd (tl (tl V1007)))) ())))) (true (shen.sys-error shen.s-prolog_clause)))) -(defun shen.head_abstraction (V977) (cond ((and (cons? V977) (and (cons? (tl V977)) (and (= :- (hd (tl V977))) (and (cons? (tl (tl V977))) (and (= () (tl (tl (tl V977)))) (< (shen.complexity_head (hd V977)) (value shen.*maxcomplexity*))))))) (cons V977 ())) ((and (cons? V977) (and (cons? (hd V977)) (and (cons? (tl V977)) (and (= :- (hd (tl V977))) (and (cons? (tl (tl V977))) (= () (tl (tl (tl V977))))))))) (let Terms (map (lambda Y (gensym V)) (tl (hd V977))) (let XTerms (shen.rcons_form (shen.remove_modes (tl (hd V977)))) (let Literal (cons unify (cons (shen.cons_form Terms) (cons XTerms ()))) (let Clause (cons (cons (hd (hd V977)) Terms) (cons :- (cons (cons Literal (hd (tl (tl V977)))) ()))) (cons Clause ())))))) (true (shen.sys-error shen.head_abstraction)))) +(defun shen.head_abstraction (V1008) (cond ((and (cons? V1008) (and (cons? (tl V1008)) (and (= :- (hd (tl V1008))) (and (cons? (tl (tl V1008))) (and (= () (tl (tl (tl V1008)))) (< (shen.complexity_head (hd V1008)) (value shen.*maxcomplexity*))))))) (cons V1008 ())) ((and (cons? V1008) (and (cons? (hd V1008)) (and (cons? (tl V1008)) (and (= :- (hd (tl V1008))) (and (cons? (tl (tl V1008))) (= () (tl (tl (tl V1008))))))))) (let Terms (map (lambda Y (gensym V)) (tl (hd V1008))) (let XTerms (shen.rcons_form (shen.remove_modes (tl (hd V1008)))) (let Literal (cons unify (cons (shen.cons_form Terms) (cons XTerms ()))) (let Clause (cons (cons (hd (hd V1008)) Terms) (cons :- (cons (cons Literal (hd (tl (tl V1008)))) ()))) (cons Clause ())))))) (true (shen.sys-error shen.head_abstraction)))) -(defun shen.complexity_head (V982) (cond ((cons? V982) (shen.product (map shen.complexity (tl V982)))) (true (shen.sys-error shen.complexity_head)))) +(defun shen.complexity_head (V1013) (cond ((cons? V1013) (shen.product (map (lambda X927 (shen.complexity X927)) (tl V1013)))) (true (shen.sys-error shen.complexity_head)))) -(defun shen.complexity (V990) (cond ((and (cons? V990) (and (= mode (hd V990)) (and (cons? (tl V990)) (and (cons? (hd (tl V990))) (and (= mode (hd (hd (tl V990)))) (and (cons? (tl (hd (tl V990)))) (and (cons? (tl (tl (hd (tl V990))))) (and (= () (tl (tl (tl (hd (tl V990)))))) (and (cons? (tl (tl V990))) (= () (tl (tl (tl V990))))))))))))) (shen.complexity (hd (tl V990)))) ((and (cons? V990) (and (= mode (hd V990)) (and (cons? (tl V990)) (and (cons? (hd (tl V990))) (and (cons? (tl (tl V990))) (and (= + (hd (tl (tl V990)))) (= () (tl (tl (tl V990)))))))))) (* 2 (* (shen.complexity (cons mode (cons (hd (hd (tl V990))) (tl (tl V990))))) (shen.complexity (cons mode (cons (tl (hd (tl V990))) (tl (tl V990)))))))) ((and (cons? V990) (and (= mode (hd V990)) (and (cons? (tl V990)) (and (cons? (hd (tl V990))) (and (cons? (tl (tl V990))) (and (= - (hd (tl (tl V990)))) (= () (tl (tl (tl V990)))))))))) (* (shen.complexity (cons mode (cons (hd (hd (tl V990))) (tl (tl V990))))) (shen.complexity (cons mode (cons (tl (hd (tl V990))) (tl (tl V990))))))) ((and (cons? V990) (and (= mode (hd V990)) (and (cons? (tl V990)) (and (cons? (tl (tl V990))) (and (= () (tl (tl (tl V990)))) (variable? (hd (tl V990)))))))) 1) ((and (cons? V990) (and (= mode (hd V990)) (and (cons? (tl V990)) (and (cons? (tl (tl V990))) (and (= + (hd (tl (tl V990)))) (= () (tl (tl (tl V990))))))))) 2) ((and (cons? V990) (and (= mode (hd V990)) (and (cons? (tl V990)) (and (cons? (tl (tl V990))) (and (= - (hd (tl (tl V990)))) (= () (tl (tl (tl V990))))))))) 1) (true (shen.complexity (cons mode (cons V990 (cons + ()))))))) +(defun shen.complexity (V1021) (cond ((and (cons? V1021) (and (= mode (hd V1021)) (and (cons? (tl V1021)) (and (cons? (hd (tl V1021))) (and (= mode (hd (hd (tl V1021)))) (and (cons? (tl (hd (tl V1021)))) (and (cons? (tl (tl (hd (tl V1021))))) (and (= () (tl (tl (tl (hd (tl V1021)))))) (and (cons? (tl (tl V1021))) (= () (tl (tl (tl V1021))))))))))))) (shen.complexity (hd (tl V1021)))) ((and (cons? V1021) (and (= mode (hd V1021)) (and (cons? (tl V1021)) (and (cons? (hd (tl V1021))) (and (cons? (tl (tl V1021))) (and (= + (hd (tl (tl V1021)))) (= () (tl (tl (tl V1021)))))))))) (* 2 (* (shen.complexity (cons mode (cons (hd (hd (tl V1021))) (tl (tl V1021))))) (shen.complexity (cons mode (cons (tl (hd (tl V1021))) (tl (tl V1021)))))))) ((and (cons? V1021) (and (= mode (hd V1021)) (and (cons? (tl V1021)) (and (cons? (hd (tl V1021))) (and (cons? (tl (tl V1021))) (and (= - (hd (tl (tl V1021)))) (= () (tl (tl (tl V1021)))))))))) (* (shen.complexity (cons mode (cons (hd (hd (tl V1021))) (tl (tl V1021))))) (shen.complexity (cons mode (cons (tl (hd (tl V1021))) (tl (tl V1021))))))) ((and (cons? V1021) (and (= mode (hd V1021)) (and (cons? (tl V1021)) (and (cons? (tl (tl V1021))) (and (= () (tl (tl (tl V1021)))) (variable? (hd (tl V1021)))))))) 1) ((and (cons? V1021) (and (= mode (hd V1021)) (and (cons? (tl V1021)) (and (cons? (tl (tl V1021))) (and (= + (hd (tl (tl V1021)))) (= () (tl (tl (tl V1021))))))))) 2) ((and (cons? V1021) (and (= mode (hd V1021)) (and (cons? (tl V1021)) (and (cons? (tl (tl V1021))) (and (= - (hd (tl (tl V1021)))) (= () (tl (tl (tl V1021))))))))) 1) (true (shen.complexity (cons mode (cons V1021 (cons + ()))))))) -(defun shen.product (V991) (cond ((= () V991) 1) ((cons? V991) (* (hd V991) (shen.product (tl V991)))) (true (shen.sys-error shen.product)))) +(defun shen.product (V1022) (cond ((= () V1022) 1) ((cons? V1022) (* (hd V1022) (shen.product (tl V1022)))) (true (shen.sys-error shen.product)))) -(defun shen.s-prolog_literal (V992) (cond ((and (cons? V992) (and (= is (hd V992)) (and (cons? (tl V992)) (and (cons? (tl (tl V992))) (= () (tl (tl (tl V992)))))))) (cons bind (cons (hd (tl V992)) (cons (shen.insert_deref (hd (tl (tl V992)))) ())))) ((and (cons? V992) (and (= when (hd V992)) (and (cons? (tl V992)) (= () (tl (tl V992)))))) (cons fwhen (cons (shen.insert_deref (hd (tl V992))) ()))) ((and (cons? V992) (and (= bind (hd V992)) (and (cons? (tl V992)) (and (cons? (tl (tl V992))) (= () (tl (tl (tl V992)))))))) (cons bind (cons (hd (tl V992)) (cons (shen.insert_lazyderef (hd (tl (tl V992)))) ())))) ((and (cons? V992) (and (= fwhen (hd V992)) (and (cons? (tl V992)) (= () (tl (tl V992)))))) (cons fwhen (cons (shen.insert_lazyderef (hd (tl V992))) ()))) ((cons? V992) (cons (shen.m_prolog_to_s-prolog_predicate (hd V992)) (tl V992))) (true (shen.sys-error shen.s-prolog_literal)))) +(defun shen.s-prolog_literal (V1023) (cond ((and (cons? V1023) (and (= is (hd V1023)) (and (cons? (tl V1023)) (and (cons? (tl (tl V1023))) (= () (tl (tl (tl V1023)))))))) (cons bind (cons (hd (tl V1023)) (cons (shen.insert_deref (hd (tl (tl V1023)))) ())))) ((and (cons? V1023) (and (= when (hd V1023)) (and (cons? (tl V1023)) (= () (tl (tl V1023)))))) (cons fwhen (cons (shen.insert_deref (hd (tl V1023))) ()))) ((and (cons? V1023) (and (= bind (hd V1023)) (and (cons? (tl V1023)) (and (cons? (tl (tl V1023))) (= () (tl (tl (tl V1023)))))))) (cons bind (cons (hd (tl V1023)) (cons (shen.insert_lazyderef (hd (tl (tl V1023)))) ())))) ((and (cons? V1023) (and (= fwhen (hd V1023)) (and (cons? (tl V1023)) (= () (tl (tl V1023)))))) (cons fwhen (cons (shen.insert_lazyderef (hd (tl V1023))) ()))) ((cons? V1023) (cons (shen.m_prolog_to_s-prolog_predicate (hd V1023)) (tl V1023))) (true (shen.sys-error shen.s-prolog_literal)))) -(defun shen.insert_deref (V993) (cond ((variable? V993) (cons shen.deref (cons V993 (cons ProcessN ())))) ((cons? V993) (cons (shen.insert_deref (hd V993)) (shen.insert_deref (tl V993)))) (true V993))) +(defun shen.insert_deref (V1024) (cond ((variable? V1024) (cons shen.deref (cons V1024 (cons ProcessN ())))) ((cons? V1024) (cons (shen.insert_deref (hd V1024)) (shen.insert_deref (tl V1024)))) (true V1024))) -(defun shen.insert_lazyderef (V994) (cond ((variable? V994) (cons shen.lazyderef (cons V994 (cons ProcessN ())))) ((cons? V994) (cons (shen.insert_lazyderef (hd V994)) (shen.insert_lazyderef (tl V994)))) (true V994))) +(defun shen.insert_lazyderef (V1025) (cond ((variable? V1025) (cons shen.lazyderef (cons V1025 (cons ProcessN ())))) ((cons? V1025) (cons (shen.insert_lazyderef (hd V1025)) (shen.insert_lazyderef (tl V1025)))) (true V1025))) -(defun shen.m_prolog_to_s-prolog_predicate (V995) (cond ((= = V995) unify) ((= =! V995) unify!) ((= == V995) identical) (true V995))) +(defun shen.m_prolog_to_s-prolog_predicate (V1026) (cond ((= = V1026) unify) ((= =! V1026) unify!) ((= == V1026) identical) (true V1026))) -(defun shen.group_clauses (V996) (cond ((= () V996) ()) ((cons? V996) (let Group (shen.collect (lambda X (shen.same_predicate? (hd V996) X)) V996) (let Rest (difference V996 Group) (cons Group (shen.group_clauses Rest))))) (true (shen.sys-error shen.group_clauses)))) +(defun shen.group_clauses (V1027) (cond ((= () V1027) ()) ((cons? V1027) (let Group (shen.collect (lambda X (shen.same_predicate? (hd V1027) X)) V1027) (let Rest (difference V1027 Group) (cons Group (shen.group_clauses Rest))))) (true (shen.sys-error shen.group_clauses)))) -(defun shen.collect (V999 V1000) (cond ((= () V1000) ()) ((cons? V1000) (if (V999 (hd V1000)) (cons (hd V1000) (shen.collect V999 (tl V1000))) (shen.collect V999 (tl V1000)))) (true (shen.sys-error shen.collect)))) +(defun shen.collect (V1030 V1031) (cond ((= () V1031) ()) ((cons? V1031) (if (V1030 (hd V1031)) (cons (hd V1031) (shen.collect V1030 (tl V1031))) (shen.collect V1030 (tl V1031)))) (true (shen.sys-error shen.collect)))) -(defun shen.same_predicate? (V1017 V1018) (cond ((and (cons? V1017) (and (cons? (hd V1017)) (and (cons? V1018) (cons? (hd V1018))))) (= (hd (hd V1017)) (hd (hd V1018)))) (true (shen.sys-error shen.same_predicate?)))) +(defun shen.same_predicate? (V1048 V1049) (cond ((and (cons? V1048) (and (cons? (hd V1048)) (and (cons? V1049) (cons? (hd V1049))))) (= (hd (hd V1048)) (hd (hd V1049)))) (true (shen.sys-error shen.same_predicate?)))) -(defun shen.compile_prolog_procedure (V1019) (let F (shen.procedure_name V1019) (let Shen (shen.clauses-to-shen F V1019) Shen))) +(defun shen.compile_prolog_procedure (V1050) (let F (shen.procedure_name V1050) (let Shen (shen.clauses-to-shen F V1050) Shen))) -(defun shen.procedure_name (V1032) (cond ((and (cons? V1032) (and (cons? (hd V1032)) (cons? (hd (hd V1032))))) (hd (hd (hd V1032)))) (true (shen.sys-error shen.procedure_name)))) +(defun shen.procedure_name (V1063) (cond ((and (cons? V1063) (and (cons? (hd V1063)) (cons? (hd (hd V1063))))) (hd (hd (hd V1063)))) (true (shen.sys-error shen.procedure_name)))) -(defun shen.clauses-to-shen (V1033 V1034) (let Linear (map shen.linearise-clause V1034) (let Arity (shen.prolog-aritycheck V1033 (map (lambda V901 (head V901)) V1034)) (let Parameters (shen.parameters Arity) (let AUM_instructions (map (lambda X (shen.aum X Parameters)) Linear) (let Code (shen.catch-cut (shen.nest-disjunct (map shen.aum_to_shen AUM_instructions))) (let ShenDef (cons define (cons V1033 (append Parameters (append (cons ProcessN (cons Continuation ())) (cons -> (cons Code ())))))) ShenDef))))))) +(defun shen.clauses-to-shen (V1064 V1065) (let Linear (map (lambda X928 (shen.linearise-clause X928)) V1065) (let Arity (shen.prolog-aritycheck V1064 (map (lambda X929 (head X929)) V1065)) (let Parameters (shen.parameters Arity) (let AUM_instructions (map (lambda X (shen.aum X Parameters)) Linear) (let Code (shen.catch-cut (shen.nest-disjunct (map (lambda X930 (shen.aum_to_shen X930)) AUM_instructions))) (let ShenDef (cons define (cons V1064 (append Parameters (append (cons ProcessN (cons Continuation ())) (cons -> (cons Code ())))))) ShenDef))))))) -(defun shen.catch-cut (V1035) (cond ((not (shen.occurs? cut V1035)) V1035) (true (cons let (cons Throwcontrol (cons (cons shen.catchpoint ()) (cons (cons shen.cutpoint (cons Throwcontrol (cons V1035 ()))) ()))))))) +(defun shen.catch-cut (V1066) (cond ((not (shen.occurs? cut V1066)) V1066) (true (cons let (cons Throwcontrol (cons (cons shen.catchpoint ()) (cons (cons shen.cutpoint (cons Throwcontrol (cons V1066 ()))) ()))))))) (defun shen.catchpoint () (set shen.*catch* (+ 1 (value shen.*catch*)))) -(defun shen.cutpoint (V1040 V1041) (cond ((= V1041 V1040) false) (true V1041))) +(defun shen.cutpoint (V1071 V1072) (cond ((= V1072 V1071) false) (true V1072))) -(defun shen.nest-disjunct (V1043) (cond ((and (cons? V1043) (= () (tl V1043))) (hd V1043)) ((cons? V1043) (shen.lisp-or (hd V1043) (shen.nest-disjunct (tl V1043)))) (true (shen.sys-error shen.nest-disjunct)))) +(defun shen.nest-disjunct (V1074) (cond ((and (cons? V1074) (= () (tl V1074))) (hd V1074)) ((cons? V1074) (shen.lisp-or (hd V1074) (shen.nest-disjunct (tl V1074)))) (true (shen.sys-error shen.nest-disjunct)))) -(defun shen.lisp-or (V1044 V1045) (cons let (cons Case (cons V1044 (cons (cons if (cons (cons = (cons Case (cons false ()))) (cons V1045 (cons Case ())))) ()))))) +(defun shen.lisp-or (V1075 V1076) (cons let (cons Case (cons V1075 (cons (cons if (cons (cons = (cons Case (cons false ()))) (cons V1076 (cons Case ())))) ()))))) -(defun shen.prolog-aritycheck (V1048 V1049) (cond ((and (cons? V1049) (= () (tl V1049))) (- (length (hd V1049)) 1)) ((and (cons? V1049) (cons? (tl V1049))) (if (= (length (hd V1049)) (length (hd (tl V1049)))) (shen.prolog-aritycheck V1048 (tl V1049)) (simple-error (cn "arity error in prolog procedure " (shen.app (cons V1048 ()) " +(defun shen.prolog-aritycheck (V1079 V1080) (cond ((and (cons? V1080) (= () (tl V1080))) (- (length (hd V1080)) 1)) ((and (cons? V1080) (cons? (tl V1080))) (if (= (length (hd V1080)) (length (hd (tl V1080)))) (shen.prolog-aritycheck V1079 (tl V1080)) (simple-error (cn "arity error in prolog procedure " (shen.app (cons V1079 ()) " " shen.a))))) (true (shen.sys-error shen.prolog-aritycheck)))) -(defun shen.linearise-clause (V1050) (cond ((and (cons? V1050) (and (cons? (tl V1050)) (and (= :- (hd (tl V1050))) (and (cons? (tl (tl V1050))) (= () (tl (tl (tl V1050)))))))) (let Linear (shen.linearise (cons (hd V1050) (tl (tl V1050)))) (shen.clause_form Linear))) (true (shen.sys-error shen.linearise-clause)))) +(defun shen.linearise-clause (V1081) (cond ((and (cons? V1081) (and (cons? (tl V1081)) (and (= :- (hd (tl V1081))) (and (cons? (tl (tl V1081))) (= () (tl (tl (tl V1081)))))))) (let Linear (shen.linearise (cons (hd V1081) (tl (tl V1081)))) (shen.clause_form Linear))) (true (shen.sys-error shen.linearise-clause)))) -(defun shen.clause_form (V1051) (cond ((and (cons? V1051) (and (cons? (tl V1051)) (= () (tl (tl V1051))))) (cons (shen.explicit_modes (hd V1051)) (cons :- (cons (shen.cf_help (hd (tl V1051))) ())))) (true (shen.sys-error shen.clause_form)))) +(defun shen.clause_form (V1082) (cond ((and (cons? V1082) (and (cons? (tl V1082)) (= () (tl (tl V1082))))) (cons (shen.explicit_modes (hd V1082)) (cons :- (cons (shen.cf_help (hd (tl V1082))) ())))) (true (shen.sys-error shen.clause_form)))) -(defun shen.explicit_modes (V1052) (cond ((cons? V1052) (cons (hd V1052) (map shen.em_help (tl V1052)))) (true (shen.sys-error shen.explicit_modes)))) +(defun shen.explicit_modes (V1083) (cond ((cons? V1083) (cons (hd V1083) (map (lambda X931 (shen.em_help X931)) (tl V1083)))) (true (shen.sys-error shen.explicit_modes)))) -(defun shen.em_help (V1053) (cond ((and (cons? V1053) (and (= mode (hd V1053)) (and (cons? (tl V1053)) (and (cons? (tl (tl V1053))) (= () (tl (tl (tl V1053)))))))) V1053) (true (cons mode (cons V1053 (cons + ())))))) +(defun shen.em_help (V1084) (cond ((and (cons? V1084) (and (= mode (hd V1084)) (and (cons? (tl V1084)) (and (cons? (tl (tl V1084))) (= () (tl (tl (tl V1084)))))))) V1084) (true (cons mode (cons V1084 (cons + ())))))) -(defun shen.cf_help (V1054) (cond ((and (cons? V1054) (and (= where (hd V1054)) (and (cons? (tl V1054)) (and (cons? (hd (tl V1054))) (and (= = (hd (hd (tl V1054)))) (and (cons? (tl (hd (tl V1054)))) (and (cons? (tl (tl (hd (tl V1054))))) (and (= () (tl (tl (tl (hd (tl V1054)))))) (and (cons? (tl (tl V1054))) (= () (tl (tl (tl V1054))))))))))))) (cons (cons (if (value shen.*occurs*) unify! unify) (tl (hd (tl V1054)))) (shen.cf_help (hd (tl (tl V1054)))))) (true V1054))) +(defun shen.cf_help (V1085) (cond ((and (cons? V1085) (and (= where (hd V1085)) (and (cons? (tl V1085)) (and (cons? (hd (tl V1085))) (and (= = (hd (hd (tl V1085)))) (and (cons? (tl (hd (tl V1085)))) (and (cons? (tl (tl (hd (tl V1085))))) (and (= () (tl (tl (tl (hd (tl V1085)))))) (and (cons? (tl (tl V1085))) (= () (tl (tl (tl V1085))))))))))))) (cons (cons (if (value shen.*occurs*) unify! unify) (tl (hd (tl V1085)))) (shen.cf_help (hd (tl (tl V1085)))))) (true V1085))) -(defun occurs-check (V1059) (cond ((= + V1059) (set shen.*occurs* true)) ((= - V1059) (set shen.*occurs* false)) (true (simple-error "occurs-check expects + or - +(defun occurs-check (V1090) (cond ((= + V1090) (set shen.*occurs* true)) ((= - V1090) (set shen.*occurs* false)) (true (simple-error "occurs-check expects + or - ")))) -(defun shen.aum (V1060 V1061) (cond ((and (cons? V1060) (and (cons? (hd V1060)) (and (cons? (tl V1060)) (and (= :- (hd (tl V1060))) (and (cons? (tl (tl V1060))) (= () (tl (tl (tl V1060))))))))) (let MuApplication (shen.make_mu_application (cons shen.mu (cons (tl (hd V1060)) (cons (shen.continuation_call (tl (hd V1060)) (hd (tl (tl V1060)))) ()))) V1061) (shen.mu_reduction MuApplication +))) (true (shen.sys-error shen.aum)))) +(defun shen.aum (V1091 V1092) (cond ((and (cons? V1091) (and (cons? (hd V1091)) (and (cons? (tl V1091)) (and (= :- (hd (tl V1091))) (and (cons? (tl (tl V1091))) (= () (tl (tl (tl V1091))))))))) (let MuApplication (shen.make_mu_application (cons shen.mu (cons (tl (hd V1091)) (cons (shen.continuation_call (tl (hd V1091)) (hd (tl (tl V1091)))) ()))) V1092) (shen.mu_reduction MuApplication +))) (true (shen.sys-error shen.aum)))) -(defun shen.continuation_call (V1062 V1063) (let VTerms (cons ProcessN (shen.extract_vars V1062)) (let VBody (shen.extract_vars V1063) (let Free (remove Throwcontrol (difference VBody VTerms)) (shen.cc_help Free V1063))))) +(defun shen.continuation_call (V1093 V1094) (let VTerms (cons ProcessN (shen.extract_vars V1093)) (let VBody (shen.extract_vars V1094) (let Free (remove Throwcontrol (difference VBody VTerms)) (shen.cc_help Free V1094))))) -(defun remove (V1064 V1065) (shen.remove-h V1064 V1065 ())) +(defun remove (V1095 V1096) (shen.remove-h V1095 V1096 ())) -(defun shen.remove-h (V1068 V1069 V1070) (cond ((= () V1069) (reverse V1070)) ((and (cons? V1069) (= (hd V1069) V1068)) (shen.remove-h (hd V1069) (tl V1069) V1070)) ((cons? V1069) (shen.remove-h V1068 (tl V1069) (cons (hd V1069) V1070))) (true (shen.sys-error shen.remove-h)))) +(defun shen.remove-h (V1099 V1100 V1101) (cond ((= () V1100) (reverse V1101)) ((and (cons? V1100) (= (hd V1100) V1099)) (shen.remove-h (hd V1100) (tl V1100) V1101)) ((cons? V1100) (shen.remove-h V1099 (tl V1100) (cons (hd V1100) V1101))) (true (shen.sys-error shen.remove-h)))) -(defun shen.cc_help (V1072 V1073) (cond ((and (= () V1072) (= () V1073)) (cons shen.pop (cons shen.the (cons shen.stack ())))) ((= () V1073) (cons shen.rename (cons shen.the (cons shen.variables (cons in (cons V1072 (cons and (cons shen.then (cons (cons shen.pop (cons shen.the (cons shen.stack ()))) ()))))))))) ((= () V1072) (cons call (cons shen.the (cons shen.continuation (cons V1073 ()))))) (true (cons shen.rename (cons shen.the (cons shen.variables (cons in (cons V1072 (cons and (cons shen.then (cons (cons call (cons shen.the (cons shen.continuation (cons V1073 ())))) ()))))))))))) +(defun shen.cc_help (V1103 V1104) (cond ((and (= () V1103) (= () V1104)) (cons shen.pop (cons shen.the (cons shen.stack ())))) ((= () V1104) (cons shen.rename (cons shen.the (cons shen.variables (cons in (cons V1103 (cons and (cons shen.then (cons (cons shen.pop (cons shen.the (cons shen.stack ()))) ()))))))))) ((= () V1103) (cons call (cons shen.the (cons shen.continuation (cons V1104 ()))))) (true (cons shen.rename (cons shen.the (cons shen.variables (cons in (cons V1103 (cons and (cons shen.then (cons (cons call (cons shen.the (cons shen.continuation (cons V1104 ())))) ()))))))))))) -(defun shen.make_mu_application (V1074 V1075) (cond ((and (cons? V1074) (and (= shen.mu (hd V1074)) (and (cons? (tl V1074)) (and (= () (hd (tl V1074))) (and (cons? (tl (tl V1074))) (and (= () (tl (tl (tl V1074)))) (= () V1075))))))) (hd (tl (tl V1074)))) ((and (cons? V1074) (and (= shen.mu (hd V1074)) (and (cons? (tl V1074)) (and (cons? (hd (tl V1074))) (and (cons? (tl (tl V1074))) (and (= () (tl (tl (tl V1074)))) (cons? V1075))))))) (cons (cons shen.mu (cons (hd (hd (tl V1074))) (cons (shen.make_mu_application (cons shen.mu (cons (tl (hd (tl V1074))) (tl (tl V1074)))) (tl V1075)) ()))) (cons (hd V1075) ()))) (true (shen.sys-error shen.make_mu_application)))) +(defun shen.make_mu_application (V1105 V1106) (cond ((and (cons? V1105) (and (= shen.mu (hd V1105)) (and (cons? (tl V1105)) (and (= () (hd (tl V1105))) (and (cons? (tl (tl V1105))) (and (= () (tl (tl (tl V1105)))) (= () V1106))))))) (hd (tl (tl V1105)))) ((and (cons? V1105) (and (= shen.mu (hd V1105)) (and (cons? (tl V1105)) (and (cons? (hd (tl V1105))) (and (cons? (tl (tl V1105))) (and (= () (tl (tl (tl V1105)))) (cons? V1106))))))) (cons (cons shen.mu (cons (hd (hd (tl V1105))) (cons (shen.make_mu_application (cons shen.mu (cons (tl (hd (tl V1105))) (tl (tl V1105)))) (tl V1106)) ()))) (cons (hd V1106) ()))) (true (shen.sys-error shen.make_mu_application)))) -(defun shen.mu_reduction (V1082 V1083) (cond ((and (cons? V1082) (and (cons? (hd V1082)) (and (= shen.mu (hd (hd V1082))) (and (cons? (tl (hd V1082))) (and (cons? (hd (tl (hd V1082)))) (and (= mode (hd (hd (tl (hd V1082))))) (and (cons? (tl (hd (tl (hd V1082))))) (and (cons? (tl (tl (hd (tl (hd V1082)))))) (and (= () (tl (tl (tl (hd (tl (hd V1082))))))) (and (cons? (tl (tl (hd V1082)))) (and (= () (tl (tl (tl (hd V1082))))) (and (cons? (tl V1082)) (= () (tl (tl V1082))))))))))))))) (shen.mu_reduction (cons (cons shen.mu (cons (hd (tl (hd (tl (hd V1082))))) (tl (tl (hd V1082))))) (tl V1082)) (hd (tl (tl (hd (tl (hd V1082)))))))) ((and (cons? V1082) (and (cons? (hd V1082)) (and (= shen.mu (hd (hd V1082))) (and (cons? (tl (hd V1082))) (and (cons? (tl (tl (hd V1082)))) (and (= () (tl (tl (tl (hd V1082))))) (and (cons? (tl V1082)) (and (= () (tl (tl V1082))) (= _ (hd (tl (hd V1082)))))))))))) (shen.mu_reduction (hd (tl (tl (hd V1082)))) V1083)) ((and (cons? V1082) (and (cons? (hd V1082)) (and (= shen.mu (hd (hd V1082))) (and (cons? (tl (hd V1082))) (and (cons? (tl (tl (hd V1082)))) (and (= () (tl (tl (tl (hd V1082))))) (and (cons? (tl V1082)) (and (= () (tl (tl V1082))) (shen.ephemeral_variable? (hd (tl (hd V1082))) (hd (tl V1082))))))))))) (subst (hd (tl V1082)) (hd (tl (hd V1082))) (shen.mu_reduction (hd (tl (tl (hd V1082)))) V1083))) ((and (cons? V1082) (and (cons? (hd V1082)) (and (= shen.mu (hd (hd V1082))) (and (cons? (tl (hd V1082))) (and (cons? (tl (tl (hd V1082)))) (and (= () (tl (tl (tl (hd V1082))))) (and (cons? (tl V1082)) (and (= () (tl (tl V1082))) (variable? (hd (tl (hd V1082)))))))))))) (cons let (cons (hd (tl (hd V1082))) (cons shen.be (cons (hd (tl V1082)) (cons in (cons (shen.mu_reduction (hd (tl (tl (hd V1082)))) V1083) ()))))))) ((and (cons? V1082) (and (cons? (hd V1082)) (and (= shen.mu (hd (hd V1082))) (and (cons? (tl (hd V1082))) (and (cons? (tl (tl (hd V1082)))) (and (= () (tl (tl (tl (hd V1082))))) (and (cons? (tl V1082)) (and (= () (tl (tl V1082))) (and (= - V1083) (shen.prolog_constant? (hd (tl (hd V1082))))))))))))) (let Z (gensym V) (cons let (cons Z (cons shen.be (cons (cons shen.the (cons shen.result (cons shen.of (cons shen.dereferencing (tl V1082))))) (cons in (cons (cons if (cons (cons Z (cons is (cons identical (cons shen.to (cons (hd (tl (hd V1082))) ()))))) (cons shen.then (cons (shen.mu_reduction (hd (tl (tl (hd V1082)))) -) (cons shen.else (cons shen.failed! ())))))) ())))))))) ((and (cons? V1082) (and (cons? (hd V1082)) (and (= shen.mu (hd (hd V1082))) (and (cons? (tl (hd V1082))) (and (cons? (tl (tl (hd V1082)))) (and (= () (tl (tl (tl (hd V1082))))) (and (cons? (tl V1082)) (and (= () (tl (tl V1082))) (and (= + V1083) (shen.prolog_constant? (hd (tl (hd V1082))))))))))))) (let Z (gensym V) (cons let (cons Z (cons shen.be (cons (cons shen.the (cons shen.result (cons shen.of (cons shen.dereferencing (tl V1082))))) (cons in (cons (cons if (cons (cons Z (cons is (cons identical (cons shen.to (cons (hd (tl (hd V1082))) ()))))) (cons shen.then (cons (shen.mu_reduction (hd (tl (tl (hd V1082)))) +) (cons shen.else (cons (cons if (cons (cons Z (cons is (cons shen.a (cons shen.variable ())))) (cons shen.then (cons (cons bind (cons Z (cons shen.to (cons (hd (tl (hd V1082))) (cons in (cons (shen.mu_reduction (hd (tl (tl (hd V1082)))) +) ())))))) (cons shen.else (cons shen.failed! ())))))) ())))))) ())))))))) ((and (cons? V1082) (and (cons? (hd V1082)) (and (= shen.mu (hd (hd V1082))) (and (cons? (tl (hd V1082))) (and (cons? (hd (tl (hd V1082)))) (and (cons? (tl (tl (hd V1082)))) (and (= () (tl (tl (tl (hd V1082))))) (and (cons? (tl V1082)) (and (= () (tl (tl V1082))) (= - V1083)))))))))) (let Z (gensym V) (cons let (cons Z (cons shen.be (cons (cons shen.the (cons shen.result (cons shen.of (cons shen.dereferencing (tl V1082))))) (cons in (cons (cons if (cons (cons Z (cons is (cons shen.a (cons shen.non-empty (cons list ()))))) (cons shen.then (cons (shen.mu_reduction (cons (cons shen.mu (cons (hd (hd (tl (hd V1082)))) (cons (cons (cons shen.mu (cons (tl (hd (tl (hd V1082)))) (tl (tl (hd V1082))))) (cons (cons shen.the (cons tail (cons shen.of (cons Z ())))) ())) ()))) (cons (cons shen.the (cons head (cons shen.of (cons Z ())))) ())) -) (cons shen.else (cons shen.failed! ())))))) ())))))))) ((and (cons? V1082) (and (cons? (hd V1082)) (and (= shen.mu (hd (hd V1082))) (and (cons? (tl (hd V1082))) (and (cons? (hd (tl (hd V1082)))) (and (cons? (tl (tl (hd V1082)))) (and (= () (tl (tl (tl (hd V1082))))) (and (cons? (tl V1082)) (and (= () (tl (tl V1082))) (= + V1083)))))))))) (let Z (gensym V) (cons let (cons Z (cons shen.be (cons (cons shen.the (cons shen.result (cons shen.of (cons shen.dereferencing (tl V1082))))) (cons in (cons (cons if (cons (cons Z (cons is (cons shen.a (cons shen.non-empty (cons list ()))))) (cons shen.then (cons (shen.mu_reduction (cons (cons shen.mu (cons (hd (hd (tl (hd V1082)))) (cons (cons (cons shen.mu (cons (tl (hd (tl (hd V1082)))) (tl (tl (hd V1082))))) (cons (cons shen.the (cons tail (cons shen.of (cons Z ())))) ())) ()))) (cons (cons shen.the (cons head (cons shen.of (cons Z ())))) ())) +) (cons shen.else (cons (cons if (cons (cons Z (cons is (cons shen.a (cons shen.variable ())))) (cons shen.then (cons (cons shen.rename (cons shen.the (cons shen.variables (cons in (cons (shen.extract_vars (hd (tl (hd V1082)))) (cons and (cons shen.then (cons (cons bind (cons Z (cons shen.to (cons (shen.rcons_form (shen.remove_modes (hd (tl (hd V1082))))) (cons in (cons (shen.mu_reduction (hd (tl (tl (hd V1082)))) +) ())))))) ())))))))) (cons shen.else (cons shen.failed! ())))))) ())))))) ())))))))) (true V1082))) +(defun shen.mu_reduction (V1113 V1114) (cond ((and (cons? V1113) (and (cons? (hd V1113)) (and (= shen.mu (hd (hd V1113))) (and (cons? (tl (hd V1113))) (and (cons? (hd (tl (hd V1113)))) (and (= mode (hd (hd (tl (hd V1113))))) (and (cons? (tl (hd (tl (hd V1113))))) (and (cons? (tl (tl (hd (tl (hd V1113)))))) (and (= () (tl (tl (tl (hd (tl (hd V1113))))))) (and (cons? (tl (tl (hd V1113)))) (and (= () (tl (tl (tl (hd V1113))))) (and (cons? (tl V1113)) (= () (tl (tl V1113))))))))))))))) (shen.mu_reduction (cons (cons shen.mu (cons (hd (tl (hd (tl (hd V1113))))) (tl (tl (hd V1113))))) (tl V1113)) (hd (tl (tl (hd (tl (hd V1113)))))))) ((and (cons? V1113) (and (cons? (hd V1113)) (and (= shen.mu (hd (hd V1113))) (and (cons? (tl (hd V1113))) (and (cons? (tl (tl (hd V1113)))) (and (= () (tl (tl (tl (hd V1113))))) (and (cons? (tl V1113)) (and (= () (tl (tl V1113))) (= _ (hd (tl (hd V1113)))))))))))) (shen.mu_reduction (hd (tl (tl (hd V1113)))) V1114)) ((and (cons? V1113) (and (cons? (hd V1113)) (and (= shen.mu (hd (hd V1113))) (and (cons? (tl (hd V1113))) (and (cons? (tl (tl (hd V1113)))) (and (= () (tl (tl (tl (hd V1113))))) (and (cons? (tl V1113)) (and (= () (tl (tl V1113))) (shen.ephemeral_variable? (hd (tl (hd V1113))) (hd (tl V1113))))))))))) (subst (hd (tl V1113)) (hd (tl (hd V1113))) (shen.mu_reduction (hd (tl (tl (hd V1113)))) V1114))) ((and (cons? V1113) (and (cons? (hd V1113)) (and (= shen.mu (hd (hd V1113))) (and (cons? (tl (hd V1113))) (and (cons? (tl (tl (hd V1113)))) (and (= () (tl (tl (tl (hd V1113))))) (and (cons? (tl V1113)) (and (= () (tl (tl V1113))) (variable? (hd (tl (hd V1113)))))))))))) (cons let (cons (hd (tl (hd V1113))) (cons shen.be (cons (hd (tl V1113)) (cons in (cons (shen.mu_reduction (hd (tl (tl (hd V1113)))) V1114) ()))))))) ((and (cons? V1113) (and (cons? (hd V1113)) (and (= shen.mu (hd (hd V1113))) (and (cons? (tl (hd V1113))) (and (cons? (tl (tl (hd V1113)))) (and (= () (tl (tl (tl (hd V1113))))) (and (cons? (tl V1113)) (and (= () (tl (tl V1113))) (and (= - V1114) (shen.prolog_constant? (hd (tl (hd V1113))))))))))))) (let Z (gensym V) (cons let (cons Z (cons shen.be (cons (cons shen.the (cons shen.result (cons shen.of (cons shen.dereferencing (tl V1113))))) (cons in (cons (cons if (cons (cons Z (cons is (cons identical (cons shen.to (cons (hd (tl (hd V1113))) ()))))) (cons shen.then (cons (shen.mu_reduction (hd (tl (tl (hd V1113)))) -) (cons shen.else (cons shen.failed! ())))))) ())))))))) ((and (cons? V1113) (and (cons? (hd V1113)) (and (= shen.mu (hd (hd V1113))) (and (cons? (tl (hd V1113))) (and (cons? (tl (tl (hd V1113)))) (and (= () (tl (tl (tl (hd V1113))))) (and (cons? (tl V1113)) (and (= () (tl (tl V1113))) (and (= + V1114) (shen.prolog_constant? (hd (tl (hd V1113))))))))))))) (let Z (gensym V) (cons let (cons Z (cons shen.be (cons (cons shen.the (cons shen.result (cons shen.of (cons shen.dereferencing (tl V1113))))) (cons in (cons (cons if (cons (cons Z (cons is (cons identical (cons shen.to (cons (hd (tl (hd V1113))) ()))))) (cons shen.then (cons (shen.mu_reduction (hd (tl (tl (hd V1113)))) +) (cons shen.else (cons (cons if (cons (cons Z (cons is (cons shen.a (cons shen.variable ())))) (cons shen.then (cons (cons bind (cons Z (cons shen.to (cons (hd (tl (hd V1113))) (cons in (cons (shen.mu_reduction (hd (tl (tl (hd V1113)))) +) ())))))) (cons shen.else (cons shen.failed! ())))))) ())))))) ())))))))) ((and (cons? V1113) (and (cons? (hd V1113)) (and (= shen.mu (hd (hd V1113))) (and (cons? (tl (hd V1113))) (and (cons? (hd (tl (hd V1113)))) (and (cons? (tl (tl (hd V1113)))) (and (= () (tl (tl (tl (hd V1113))))) (and (cons? (tl V1113)) (and (= () (tl (tl V1113))) (= - V1114)))))))))) (let Z (gensym V) (cons let (cons Z (cons shen.be (cons (cons shen.the (cons shen.result (cons shen.of (cons shen.dereferencing (tl V1113))))) (cons in (cons (cons if (cons (cons Z (cons is (cons shen.a (cons shen.non-empty (cons list ()))))) (cons shen.then (cons (shen.mu_reduction (cons (cons shen.mu (cons (hd (hd (tl (hd V1113)))) (cons (cons (cons shen.mu (cons (tl (hd (tl (hd V1113)))) (tl (tl (hd V1113))))) (cons (cons shen.the (cons tail (cons shen.of (cons Z ())))) ())) ()))) (cons (cons shen.the (cons head (cons shen.of (cons Z ())))) ())) -) (cons shen.else (cons shen.failed! ())))))) ())))))))) ((and (cons? V1113) (and (cons? (hd V1113)) (and (= shen.mu (hd (hd V1113))) (and (cons? (tl (hd V1113))) (and (cons? (hd (tl (hd V1113)))) (and (cons? (tl (tl (hd V1113)))) (and (= () (tl (tl (tl (hd V1113))))) (and (cons? (tl V1113)) (and (= () (tl (tl V1113))) (= + V1114)))))))))) (let Z (gensym V) (cons let (cons Z (cons shen.be (cons (cons shen.the (cons shen.result (cons shen.of (cons shen.dereferencing (tl V1113))))) (cons in (cons (cons if (cons (cons Z (cons is (cons shen.a (cons shen.non-empty (cons list ()))))) (cons shen.then (cons (shen.mu_reduction (cons (cons shen.mu (cons (hd (hd (tl (hd V1113)))) (cons (cons (cons shen.mu (cons (tl (hd (tl (hd V1113)))) (tl (tl (hd V1113))))) (cons (cons shen.the (cons tail (cons shen.of (cons Z ())))) ())) ()))) (cons (cons shen.the (cons head (cons shen.of (cons Z ())))) ())) +) (cons shen.else (cons (cons if (cons (cons Z (cons is (cons shen.a (cons shen.variable ())))) (cons shen.then (cons (cons shen.rename (cons shen.the (cons shen.variables (cons in (cons (shen.extract_vars (hd (tl (hd V1113)))) (cons and (cons shen.then (cons (cons bind (cons Z (cons shen.to (cons (shen.rcons_form (shen.remove_modes (hd (tl (hd V1113))))) (cons in (cons (shen.mu_reduction (hd (tl (tl (hd V1113)))) +) ())))))) ())))))))) (cons shen.else (cons shen.failed! ())))))) ())))))) ())))))))) (true V1113))) -(defun shen.rcons_form (V1084) (cond ((cons? V1084) (cons cons (cons (shen.rcons_form (hd V1084)) (cons (shen.rcons_form (tl V1084)) ())))) (true V1084))) +(defun shen.rcons_form (V1115) (cond ((cons? V1115) (cons cons (cons (shen.rcons_form (hd V1115)) (cons (shen.rcons_form (tl V1115)) ())))) (true V1115))) -(defun shen.remove_modes (V1085) (cond ((and (cons? V1085) (and (= mode (hd V1085)) (and (cons? (tl V1085)) (and (cons? (tl (tl V1085))) (and (= + (hd (tl (tl V1085)))) (= () (tl (tl (tl V1085))))))))) (shen.remove_modes (hd (tl V1085)))) ((and (cons? V1085) (and (= mode (hd V1085)) (and (cons? (tl V1085)) (and (cons? (tl (tl V1085))) (and (= - (hd (tl (tl V1085)))) (= () (tl (tl (tl V1085))))))))) (shen.remove_modes (hd (tl V1085)))) ((cons? V1085) (cons (shen.remove_modes (hd V1085)) (shen.remove_modes (tl V1085)))) (true V1085))) +(defun shen.remove_modes (V1116) (cond ((and (cons? V1116) (and (= mode (hd V1116)) (and (cons? (tl V1116)) (and (cons? (tl (tl V1116))) (and (= + (hd (tl (tl V1116)))) (= () (tl (tl (tl V1116))))))))) (shen.remove_modes (hd (tl V1116)))) ((and (cons? V1116) (and (= mode (hd V1116)) (and (cons? (tl V1116)) (and (cons? (tl (tl V1116))) (and (= - (hd (tl (tl V1116)))) (= () (tl (tl (tl V1116))))))))) (shen.remove_modes (hd (tl V1116)))) ((cons? V1116) (cons (shen.remove_modes (hd V1116)) (shen.remove_modes (tl V1116)))) (true V1116))) -(defun shen.ephemeral_variable? (V1086 V1087) (and (variable? V1086) (variable? V1087))) +(defun shen.ephemeral_variable? (V1117 V1118) (and (variable? V1117) (variable? V1118))) -(defun shen.prolog_constant? (V1096) (cond ((cons? V1096) false) (true true))) +(defun shen.prolog_constant? (V1127) (cond ((cons? V1127) false) (true true))) -(defun shen.aum_to_shen (V1097) (cond ((and (cons? V1097) (and (= let (hd V1097)) (and (cons? (tl V1097)) (and (cons? (tl (tl V1097))) (and (= shen.be (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (and (cons? (tl (tl (tl (tl V1097))))) (and (= in (hd (tl (tl (tl (tl V1097)))))) (and (cons? (tl (tl (tl (tl (tl V1097)))))) (= () (tl (tl (tl (tl (tl (tl V1097)))))))))))))))) (cons let (cons (hd (tl V1097)) (cons (shen.aum_to_shen (hd (tl (tl (tl V1097))))) (cons (shen.aum_to_shen (hd (tl (tl (tl (tl (tl V1097))))))) ()))))) ((and (cons? V1097) (and (= shen.the (hd V1097)) (and (cons? (tl V1097)) (and (= shen.result (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= shen.of (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (and (= shen.dereferencing (hd (tl (tl (tl V1097))))) (and (cons? (tl (tl (tl (tl V1097))))) (= () (tl (tl (tl (tl (tl V1097))))))))))))))) (cons shen.lazyderef (cons (shen.aum_to_shen (hd (tl (tl (tl (tl V1097)))))) (cons ProcessN ())))) ((and (cons? V1097) (and (= if (hd V1097)) (and (cons? (tl V1097)) (and (cons? (tl (tl V1097))) (and (= shen.then (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (and (cons? (tl (tl (tl (tl V1097))))) (and (= shen.else (hd (tl (tl (tl (tl V1097)))))) (and (cons? (tl (tl (tl (tl (tl V1097)))))) (= () (tl (tl (tl (tl (tl (tl V1097)))))))))))))))) (cons if (cons (shen.aum_to_shen (hd (tl V1097))) (cons (shen.aum_to_shen (hd (tl (tl (tl V1097))))) (cons (shen.aum_to_shen (hd (tl (tl (tl (tl (tl V1097))))))) ()))))) ((and (cons? V1097) (and (cons? (tl V1097)) (and (= is (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= shen.a (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (and (= shen.variable (hd (tl (tl (tl V1097))))) (= () (tl (tl (tl (tl V1097)))))))))))) (cons shen.pvar? (cons (hd V1097) ()))) ((and (cons? V1097) (and (cons? (tl V1097)) (and (= is (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= shen.a (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (and (= shen.non-empty (hd (tl (tl (tl V1097))))) (and (cons? (tl (tl (tl (tl V1097))))) (and (= list (hd (tl (tl (tl (tl V1097)))))) (= () (tl (tl (tl (tl (tl V1097))))))))))))))) (cons cons? (cons (hd V1097) ()))) ((and (cons? V1097) (and (= shen.rename (hd V1097)) (and (cons? (tl V1097)) (and (= shen.the (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= shen.variables (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (and (= in (hd (tl (tl (tl V1097))))) (and (cons? (tl (tl (tl (tl V1097))))) (and (= () (hd (tl (tl (tl (tl V1097)))))) (and (cons? (tl (tl (tl (tl (tl V1097)))))) (and (= and (hd (tl (tl (tl (tl (tl V1097))))))) (and (cons? (tl (tl (tl (tl (tl (tl V1097))))))) (and (= shen.then (hd (tl (tl (tl (tl (tl (tl V1097)))))))) (and (cons? (tl (tl (tl (tl (tl (tl (tl V1097)))))))) (= () (tl (tl (tl (tl (tl (tl (tl (tl V1097)))))))))))))))))))))))) (shen.aum_to_shen (hd (tl (tl (tl (tl (tl (tl (tl V1097)))))))))) ((and (cons? V1097) (and (= shen.rename (hd V1097)) (and (cons? (tl V1097)) (and (= shen.the (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= shen.variables (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (and (= in (hd (tl (tl (tl V1097))))) (and (cons? (tl (tl (tl (tl V1097))))) (and (cons? (hd (tl (tl (tl (tl V1097)))))) (and (cons? (tl (tl (tl (tl (tl V1097)))))) (and (= and (hd (tl (tl (tl (tl (tl V1097))))))) (and (cons? (tl (tl (tl (tl (tl (tl V1097))))))) (and (= shen.then (hd (tl (tl (tl (tl (tl (tl V1097)))))))) (and (cons? (tl (tl (tl (tl (tl (tl (tl V1097)))))))) (= () (tl (tl (tl (tl (tl (tl (tl (tl V1097)))))))))))))))))))))))) (cons let (cons (hd (hd (tl (tl (tl (tl V1097)))))) (cons (cons shen.newpv (cons ProcessN ())) (cons (shen.aum_to_shen (cons shen.rename (cons shen.the (cons shen.variables (cons in (cons (tl (hd (tl (tl (tl (tl V1097)))))) (tl (tl (tl (tl (tl V1097))))))))))) ()))))) ((and (cons? V1097) (and (= bind (hd V1097)) (and (cons? (tl V1097)) (and (cons? (tl (tl V1097))) (and (= shen.to (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (and (cons? (tl (tl (tl (tl V1097))))) (and (= in (hd (tl (tl (tl (tl V1097)))))) (and (cons? (tl (tl (tl (tl (tl V1097)))))) (= () (tl (tl (tl (tl (tl (tl V1097)))))))))))))))) (cons do (cons (cons shen.bindv (cons (hd (tl V1097)) (cons (shen.chwild (hd (tl (tl (tl V1097))))) (cons ProcessN ())))) (cons (cons let (cons Result (cons (shen.aum_to_shen (hd (tl (tl (tl (tl (tl V1097))))))) (cons (cons do (cons (cons shen.unbindv (cons (hd (tl V1097)) (cons ProcessN ()))) (cons Result ()))) ())))) ())))) ((and (cons? V1097) (and (cons? (tl V1097)) (and (= is (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= identical (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (and (= shen.to (hd (tl (tl (tl V1097))))) (and (cons? (tl (tl (tl (tl V1097))))) (= () (tl (tl (tl (tl (tl V1097)))))))))))))) (cons = (cons (hd (tl (tl (tl (tl V1097))))) (cons (hd V1097) ())))) ((= shen.failed! V1097) false) ((and (cons? V1097) (and (= shen.the (hd V1097)) (and (cons? (tl V1097)) (and (= head (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= shen.of (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (= () (tl (tl (tl (tl V1097)))))))))))) (cons hd (tl (tl (tl V1097))))) ((and (cons? V1097) (and (= shen.the (hd V1097)) (and (cons? (tl V1097)) (and (= tail (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= shen.of (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (= () (tl (tl (tl (tl V1097)))))))))))) (cons tl (tl (tl (tl V1097))))) ((and (cons? V1097) (and (= shen.pop (hd V1097)) (and (cons? (tl V1097)) (and (= shen.the (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= shen.stack (hd (tl (tl V1097)))) (= () (tl (tl (tl V1097)))))))))) (cons do (cons (cons shen.incinfs ()) (cons (cons thaw (cons Continuation ())) ())))) ((and (cons? V1097) (and (= call (hd V1097)) (and (cons? (tl V1097)) (and (= shen.the (hd (tl V1097))) (and (cons? (tl (tl V1097))) (and (= shen.continuation (hd (tl (tl V1097)))) (and (cons? (tl (tl (tl V1097)))) (= () (tl (tl (tl (tl V1097)))))))))))) (cons do (cons (cons shen.incinfs ()) (cons (shen.call_the_continuation (shen.chwild (hd (tl (tl (tl V1097))))) ProcessN Continuation) ())))) (true V1097))) +(defun shen.aum_to_shen (V1128) (cond ((and (cons? V1128) (and (= let (hd V1128)) (and (cons? (tl V1128)) (and (cons? (tl (tl V1128))) (and (= shen.be (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (and (cons? (tl (tl (tl (tl V1128))))) (and (= in (hd (tl (tl (tl (tl V1128)))))) (and (cons? (tl (tl (tl (tl (tl V1128)))))) (= () (tl (tl (tl (tl (tl (tl V1128)))))))))))))))) (cons let (cons (hd (tl V1128)) (cons (shen.aum_to_shen (hd (tl (tl (tl V1128))))) (cons (shen.aum_to_shen (hd (tl (tl (tl (tl (tl V1128))))))) ()))))) ((and (cons? V1128) (and (= shen.the (hd V1128)) (and (cons? (tl V1128)) (and (= shen.result (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= shen.of (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (and (= shen.dereferencing (hd (tl (tl (tl V1128))))) (and (cons? (tl (tl (tl (tl V1128))))) (= () (tl (tl (tl (tl (tl V1128))))))))))))))) (cons shen.lazyderef (cons (shen.aum_to_shen (hd (tl (tl (tl (tl V1128)))))) (cons ProcessN ())))) ((and (cons? V1128) (and (= if (hd V1128)) (and (cons? (tl V1128)) (and (cons? (tl (tl V1128))) (and (= shen.then (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (and (cons? (tl (tl (tl (tl V1128))))) (and (= shen.else (hd (tl (tl (tl (tl V1128)))))) (and (cons? (tl (tl (tl (tl (tl V1128)))))) (= () (tl (tl (tl (tl (tl (tl V1128)))))))))))))))) (cons if (cons (shen.aum_to_shen (hd (tl V1128))) (cons (shen.aum_to_shen (hd (tl (tl (tl V1128))))) (cons (shen.aum_to_shen (hd (tl (tl (tl (tl (tl V1128))))))) ()))))) ((and (cons? V1128) (and (cons? (tl V1128)) (and (= is (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= shen.a (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (and (= shen.variable (hd (tl (tl (tl V1128))))) (= () (tl (tl (tl (tl V1128)))))))))))) (cons shen.pvar? (cons (hd V1128) ()))) ((and (cons? V1128) (and (cons? (tl V1128)) (and (= is (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= shen.a (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (and (= shen.non-empty (hd (tl (tl (tl V1128))))) (and (cons? (tl (tl (tl (tl V1128))))) (and (= list (hd (tl (tl (tl (tl V1128)))))) (= () (tl (tl (tl (tl (tl V1128))))))))))))))) (cons cons? (cons (hd V1128) ()))) ((and (cons? V1128) (and (= shen.rename (hd V1128)) (and (cons? (tl V1128)) (and (= shen.the (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= shen.variables (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (and (= in (hd (tl (tl (tl V1128))))) (and (cons? (tl (tl (tl (tl V1128))))) (and (= () (hd (tl (tl (tl (tl V1128)))))) (and (cons? (tl (tl (tl (tl (tl V1128)))))) (and (= and (hd (tl (tl (tl (tl (tl V1128))))))) (and (cons? (tl (tl (tl (tl (tl (tl V1128))))))) (and (= shen.then (hd (tl (tl (tl (tl (tl (tl V1128)))))))) (and (cons? (tl (tl (tl (tl (tl (tl (tl V1128)))))))) (= () (tl (tl (tl (tl (tl (tl (tl (tl V1128)))))))))))))))))))))))) (shen.aum_to_shen (hd (tl (tl (tl (tl (tl (tl (tl V1128)))))))))) ((and (cons? V1128) (and (= shen.rename (hd V1128)) (and (cons? (tl V1128)) (and (= shen.the (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= shen.variables (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (and (= in (hd (tl (tl (tl V1128))))) (and (cons? (tl (tl (tl (tl V1128))))) (and (cons? (hd (tl (tl (tl (tl V1128)))))) (and (cons? (tl (tl (tl (tl (tl V1128)))))) (and (= and (hd (tl (tl (tl (tl (tl V1128))))))) (and (cons? (tl (tl (tl (tl (tl (tl V1128))))))) (and (= shen.then (hd (tl (tl (tl (tl (tl (tl V1128)))))))) (and (cons? (tl (tl (tl (tl (tl (tl (tl V1128)))))))) (= () (tl (tl (tl (tl (tl (tl (tl (tl V1128)))))))))))))))))))))))) (cons let (cons (hd (hd (tl (tl (tl (tl V1128)))))) (cons (cons shen.newpv (cons ProcessN ())) (cons (shen.aum_to_shen (cons shen.rename (cons shen.the (cons shen.variables (cons in (cons (tl (hd (tl (tl (tl (tl V1128)))))) (tl (tl (tl (tl (tl V1128))))))))))) ()))))) ((and (cons? V1128) (and (= bind (hd V1128)) (and (cons? (tl V1128)) (and (cons? (tl (tl V1128))) (and (= shen.to (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (and (cons? (tl (tl (tl (tl V1128))))) (and (= in (hd (tl (tl (tl (tl V1128)))))) (and (cons? (tl (tl (tl (tl (tl V1128)))))) (= () (tl (tl (tl (tl (tl (tl V1128)))))))))))))))) (cons do (cons (cons shen.bindv (cons (hd (tl V1128)) (cons (shen.chwild (hd (tl (tl (tl V1128))))) (cons ProcessN ())))) (cons (cons let (cons Result (cons (shen.aum_to_shen (hd (tl (tl (tl (tl (tl V1128))))))) (cons (cons do (cons (cons shen.unbindv (cons (hd (tl V1128)) (cons ProcessN ()))) (cons Result ()))) ())))) ())))) ((and (cons? V1128) (and (cons? (tl V1128)) (and (= is (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= identical (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (and (= shen.to (hd (tl (tl (tl V1128))))) (and (cons? (tl (tl (tl (tl V1128))))) (= () (tl (tl (tl (tl (tl V1128)))))))))))))) (cons = (cons (hd (tl (tl (tl (tl V1128))))) (cons (hd V1128) ())))) ((= shen.failed! V1128) false) ((and (cons? V1128) (and (= shen.the (hd V1128)) (and (cons? (tl V1128)) (and (= head (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= shen.of (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (= () (tl (tl (tl (tl V1128)))))))))))) (cons hd (tl (tl (tl V1128))))) ((and (cons? V1128) (and (= shen.the (hd V1128)) (and (cons? (tl V1128)) (and (= tail (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= shen.of (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (= () (tl (tl (tl (tl V1128)))))))))))) (cons tl (tl (tl (tl V1128))))) ((and (cons? V1128) (and (= shen.pop (hd V1128)) (and (cons? (tl V1128)) (and (= shen.the (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= shen.stack (hd (tl (tl V1128)))) (= () (tl (tl (tl V1128)))))))))) (cons do (cons (cons shen.incinfs ()) (cons (cons thaw (cons Continuation ())) ())))) ((and (cons? V1128) (and (= call (hd V1128)) (and (cons? (tl V1128)) (and (= shen.the (hd (tl V1128))) (and (cons? (tl (tl V1128))) (and (= shen.continuation (hd (tl (tl V1128)))) (and (cons? (tl (tl (tl V1128)))) (= () (tl (tl (tl (tl V1128)))))))))))) (cons do (cons (cons shen.incinfs ()) (cons (shen.call_the_continuation (shen.chwild (hd (tl (tl (tl V1128))))) ProcessN Continuation) ())))) (true V1128))) -(defun shen.chwild (V1098) (cond ((= V1098 _) (cons shen.newpv (cons ProcessN ()))) ((cons? V1098) (map shen.chwild V1098)) (true V1098))) +(defun shen.chwild (V1129) (cond ((= V1129 _) (cons shen.newpv (cons ProcessN ()))) ((cons? V1129) (map (lambda X932 (shen.chwild X932)) V1129)) (true V1129))) -(defun shen.newpv (V1099) (let Count+1 (+ (<-address (value shen.*varcounter*) V1099) 1) (let IncVar (address-> (value shen.*varcounter*) V1099 Count+1) (let Vector (<-address (value shen.*prologvectors*) V1099) (let ResizeVectorIfNeeded (if (= Count+1 (limit Vector)) (shen.resizeprocessvector V1099 Count+1) shen.skip) (shen.mk-pvar Count+1)))))) +(defun shen.newpv (V1130) (let Count+1 (+ (<-address (value shen.*varcounter*) V1130) 1) (let IncVar (address-> (value shen.*varcounter*) V1130 Count+1) (let Vector (<-address (value shen.*prologvectors*) V1130) (let ResizeVectorIfNeeded (if (= Count+1 (limit Vector)) (shen.resizeprocessvector V1130 Count+1) shen.skip) (shen.mk-pvar Count+1)))))) -(defun shen.resizeprocessvector (V1100 V1101) (let Vector (<-address (value shen.*prologvectors*) V1100) (let BigVector (shen.resize-vector Vector (+ V1101 V1101) shen.-null-) (address-> (value shen.*prologvectors*) V1100 BigVector)))) +(defun shen.resizeprocessvector (V1131 V1132) (let Vector (<-address (value shen.*prologvectors*) V1131) (let BigVector (shen.resize-vector Vector (+ V1132 V1132) shen.-null-) (address-> (value shen.*prologvectors*) V1131 BigVector)))) -(defun shen.resize-vector (V1102 V1103 V1104) (let BigVector (address-> (absvector (+ 1 V1103)) 0 V1103) (shen.copy-vector V1102 BigVector (limit V1102) V1103 V1104))) +(defun shen.resize-vector (V1133 V1134 V1135) (let BigVector (address-> (absvector (+ 1 V1134)) 0 V1134) (shen.copy-vector V1133 BigVector (limit V1133) V1134 V1135))) -(defun shen.copy-vector (V1105 V1106 V1107 V1108 V1109) (shen.copy-vector-stage-2 (+ 1 V1107) (+ V1108 1) V1109 (shen.copy-vector-stage-1 1 V1105 V1106 (+ 1 V1107)))) +(defun shen.copy-vector (V1136 V1137 V1138 V1139 V1140) (shen.copy-vector-stage-2 (+ 1 V1138) (+ V1139 1) V1140 (shen.copy-vector-stage-1 1 V1136 V1137 (+ 1 V1138)))) -(defun shen.copy-vector-stage-1 (V1112 V1113 V1114 V1115) (cond ((= V1115 V1112) V1114) (true (shen.copy-vector-stage-1 (+ 1 V1112) V1113 (address-> V1114 V1112 (<-address V1113 V1112)) V1115)))) +(defun shen.copy-vector-stage-1 (V1143 V1144 V1145 V1146) (cond ((= V1146 V1143) V1145) (true (shen.copy-vector-stage-1 (+ 1 V1143) V1144 (address-> V1145 V1143 (<-address V1144 V1143)) V1146)))) -(defun shen.copy-vector-stage-2 (V1119 V1120 V1121 V1122) (cond ((= V1120 V1119) V1122) (true (shen.copy-vector-stage-2 (+ V1119 1) V1120 V1121 (address-> V1122 V1119 V1121))))) +(defun shen.copy-vector-stage-2 (V1150 V1151 V1152 V1153) (cond ((= V1151 V1150) V1153) (true (shen.copy-vector-stage-2 (+ V1150 1) V1151 V1152 (address-> V1153 V1150 V1152))))) -(defun shen.mk-pvar (V1124) (address-> (address-> (absvector 2) 0 shen.pvar) 1 V1124)) +(defun shen.mk-pvar (V1155) (address-> (address-> (absvector 2) 0 shen.pvar) 1 V1155)) -(defun shen.pvar? (V1125) (and (absvector? V1125) (= (<-address V1125 0) shen.pvar))) +(defun shen.pvar? (V1156) (trap-error (and (absvector? V1156) (= (<-address V1156 0) shen.pvar)) (lambda E false))) -(defun shen.bindv (V1126 V1127 V1128) (let Vector (<-address (value shen.*prologvectors*) V1128) (address-> Vector (<-address V1126 1) V1127))) +(defun shen.bindv (V1157 V1158 V1159) (let Vector (<-address (value shen.*prologvectors*) V1159) (address-> Vector (<-address V1157 1) V1158))) -(defun shen.unbindv (V1129 V1130) (let Vector (<-address (value shen.*prologvectors*) V1130) (address-> Vector (<-address V1129 1) shen.-null-))) +(defun shen.unbindv (V1160 V1161) (let Vector (<-address (value shen.*prologvectors*) V1161) (address-> Vector (<-address V1160 1) shen.-null-))) (defun shen.incinfs () (set shen.*infs* (+ 1 (value shen.*infs*)))) -(defun shen.call_the_continuation (V1131 V1132 V1133) (cond ((and (cons? V1131) (and (cons? (hd V1131)) (= () (tl V1131)))) (cons (hd (hd V1131)) (append (tl (hd V1131)) (cons V1132 (cons V1133 ()))))) ((and (cons? V1131) (cons? (hd V1131))) (let NewContinuation (shen.newcontinuation (tl V1131) V1132 V1133) (cons (hd (hd V1131)) (append (tl (hd V1131)) (cons V1132 (cons NewContinuation ())))))) (true (shen.sys-error shen.call_the_continuation)))) +(defun shen.call_the_continuation (V1162 V1163 V1164) (cond ((and (cons? V1162) (and (cons? (hd V1162)) (= () (tl V1162)))) (cons (hd (hd V1162)) (append (tl (hd V1162)) (cons V1163 (cons V1164 ()))))) ((and (cons? V1162) (cons? (hd V1162))) (let NewContinuation (shen.newcontinuation (tl V1162) V1163 V1164) (cons (hd (hd V1162)) (append (tl (hd V1162)) (cons V1163 (cons NewContinuation ())))))) (true (shen.sys-error shen.call_the_continuation)))) -(defun shen.newcontinuation (V1134 V1135 V1136) (cond ((= () V1134) V1136) ((and (cons? V1134) (cons? (hd V1134))) (cons freeze (cons (cons (hd (hd V1134)) (append (tl (hd V1134)) (cons V1135 (cons (shen.newcontinuation (tl V1134) V1135 V1136) ())))) ()))) (true (shen.sys-error shen.newcontinuation)))) +(defun shen.newcontinuation (V1165 V1166 V1167) (cond ((= () V1165) V1167) ((and (cons? V1165) (cons? (hd V1165))) (cons freeze (cons (cons (hd (hd V1165)) (append (tl (hd V1165)) (cons V1166 (cons (shen.newcontinuation (tl V1165) V1166 V1167) ())))) ()))) (true (shen.sys-error shen.newcontinuation)))) -(defun return (V1141 V1142 V1143) (shen.deref V1141 V1142)) +(defun return (V1172 V1173 V1174) (shen.deref V1172 V1173)) -(defun shen.measure&return (V1148 V1149 V1150) (do (shen.prhush (shen.app (value shen.*infs*) " inferences -" shen.a) (stoutput)) (shen.deref V1148 V1149))) +(defun shen.measure&return (V1179 V1180 V1181) (do (shen.prhush (shen.app (value shen.*infs*) " inferences +" shen.a) (stoutput)) (shen.deref V1179 V1180))) -(defun unify (V1151 V1152 V1153 V1154) (shen.lzy= (shen.lazyderef V1151 V1153) (shen.lazyderef V1152 V1153) V1153 V1154)) +(defun unify (V1182 V1183 V1184 V1185) (shen.lzy= (shen.lazyderef V1182 V1184) (shen.lazyderef V1183 V1184) V1184 V1185)) -(defun shen.lzy= (V1171 V1172 V1173 V1174) (cond ((= V1172 V1171) (thaw V1174)) ((shen.pvar? V1171) (bind V1171 V1172 V1173 V1174)) ((shen.pvar? V1172) (bind V1172 V1171 V1173 V1174)) ((and (cons? V1171) (cons? V1172)) (shen.lzy= (shen.lazyderef (hd V1171) V1173) (shen.lazyderef (hd V1172) V1173) V1173 (freeze (shen.lzy= (shen.lazyderef (tl V1171) V1173) (shen.lazyderef (tl V1172) V1173) V1173 V1174)))) (true false))) +(defun shen.lzy= (V1202 V1203 V1204 V1205) (cond ((= V1203 V1202) (thaw V1205)) ((shen.pvar? V1202) (bind V1202 V1203 V1204 V1205)) ((shen.pvar? V1203) (bind V1203 V1202 V1204 V1205)) ((and (cons? V1202) (cons? V1203)) (shen.lzy= (shen.lazyderef (hd V1202) V1204) (shen.lazyderef (hd V1203) V1204) V1204 (freeze (shen.lzy= (shen.lazyderef (tl V1202) V1204) (shen.lazyderef (tl V1203) V1204) V1204 V1205)))) (true false))) -(defun shen.deref (V1176 V1177) (cond ((cons? V1176) (cons (shen.deref (hd V1176) V1177) (shen.deref (tl V1176) V1177))) (true (if (shen.pvar? V1176) (let Value (shen.valvector V1176 V1177) (if (= Value shen.-null-) V1176 (shen.deref Value V1177))) V1176)))) +(defun shen.deref (V1207 V1208) (cond ((cons? V1207) (cons (shen.deref (hd V1207) V1208) (shen.deref (tl V1207) V1208))) (true (if (shen.pvar? V1207) (let Value (shen.valvector V1207 V1208) (if (= Value shen.-null-) V1207 (shen.deref Value V1208))) V1207)))) -(defun shen.lazyderef (V1178 V1179) (if (shen.pvar? V1178) (let Value (shen.valvector V1178 V1179) (if (= Value shen.-null-) V1178 (shen.lazyderef Value V1179))) V1178)) +(defun shen.lazyderef (V1209 V1210) (if (shen.pvar? V1209) (let Value (shen.valvector V1209 V1210) (if (= Value shen.-null-) V1209 (shen.lazyderef Value V1210))) V1209)) -(defun shen.valvector (V1180 V1181) (<-address (<-address (value shen.*prologvectors*) V1181) (<-address V1180 1))) +(defun shen.valvector (V1211 V1212) (<-address (<-address (value shen.*prologvectors*) V1212) (<-address V1211 1))) -(defun unify! (V1182 V1183 V1184 V1185) (shen.lzy=! (shen.lazyderef V1182 V1184) (shen.lazyderef V1183 V1184) V1184 V1185)) +(defun unify! (V1213 V1214 V1215 V1216) (shen.lzy=! (shen.lazyderef V1213 V1215) (shen.lazyderef V1214 V1215) V1215 V1216)) -(defun shen.lzy=! (V1202 V1203 V1204 V1205) (cond ((= V1203 V1202) (thaw V1205)) ((and (shen.pvar? V1202) (not (shen.occurs? V1202 (shen.deref V1203 V1204)))) (bind V1202 V1203 V1204 V1205)) ((and (shen.pvar? V1203) (not (shen.occurs? V1203 (shen.deref V1202 V1204)))) (bind V1203 V1202 V1204 V1205)) ((and (cons? V1202) (cons? V1203)) (shen.lzy=! (shen.lazyderef (hd V1202) V1204) (shen.lazyderef (hd V1203) V1204) V1204 (freeze (shen.lzy=! (shen.lazyderef (tl V1202) V1204) (shen.lazyderef (tl V1203) V1204) V1204 V1205)))) (true false))) +(defun shen.lzy=! (V1233 V1234 V1235 V1236) (cond ((= V1234 V1233) (thaw V1236)) ((and (shen.pvar? V1233) (not (shen.occurs? V1233 (shen.deref V1234 V1235)))) (bind V1233 V1234 V1235 V1236)) ((and (shen.pvar? V1234) (not (shen.occurs? V1234 (shen.deref V1233 V1235)))) (bind V1234 V1233 V1235 V1236)) ((and (cons? V1233) (cons? V1234)) (shen.lzy=! (shen.lazyderef (hd V1233) V1235) (shen.lazyderef (hd V1234) V1235) V1235 (freeze (shen.lzy=! (shen.lazyderef (tl V1233) V1235) (shen.lazyderef (tl V1234) V1235) V1235 V1236)))) (true false))) -(defun shen.occurs? (V1215 V1216) (cond ((= V1216 V1215) true) ((cons? V1216) (or (shen.occurs? V1215 (hd V1216)) (shen.occurs? V1215 (tl V1216)))) (true false))) +(defun shen.occurs? (V1246 V1247) (cond ((= V1247 V1246) true) ((cons? V1247) (or (shen.occurs? V1246 (hd V1247)) (shen.occurs? V1246 (tl V1247)))) (true false))) -(defun identical (V1218 V1219 V1220 V1221) (shen.lzy== (shen.lazyderef V1218 V1220) (shen.lazyderef V1219 V1220) V1220 V1221)) +(defun identical (V1249 V1250 V1251 V1252) (shen.lzy== (shen.lazyderef V1249 V1251) (shen.lazyderef V1250 V1251) V1251 V1252)) -(defun shen.lzy== (V1238 V1239 V1240 V1241) (cond ((= V1239 V1238) (thaw V1241)) ((and (cons? V1238) (cons? V1239)) (shen.lzy== (shen.lazyderef (hd V1238) V1240) (shen.lazyderef (hd V1239) V1240) V1240 (freeze (shen.lzy== (tl V1238) (tl V1239) V1240 V1241)))) (true false))) +(defun shen.lzy== (V1269 V1270 V1271 V1272) (cond ((= V1270 V1269) (thaw V1272)) ((and (cons? V1269) (cons? V1270)) (shen.lzy== (shen.lazyderef (hd V1269) V1271) (shen.lazyderef (hd V1270) V1271) V1271 (freeze (shen.lzy== (tl V1269) (tl V1270) V1271 V1272)))) (true false))) -(defun shen.pvar (V1243) (cn "Var" (shen.app (<-address V1243 1) "" shen.a))) +(defun shen.pvar (V1274) (cn "Var" (shen.app (<-address V1274 1) "" shen.a))) -(defun bind (V1244 V1245 V1246 V1247) (do (shen.bindv V1244 V1245 V1246) (let Result (thaw V1247) (do (shen.unbindv V1244 V1246) Result)))) +(defun bind (V1275 V1276 V1277 V1278) (do (shen.bindv V1275 V1276 V1277) (let Result (thaw V1278) (do (shen.unbindv V1275 V1277) Result)))) -(defun fwhen (V1262 V1263 V1264) (cond ((= true V1262) (thaw V1264)) ((= false V1262) false) (true (simple-error (cn "fwhen expects a boolean: not " (shen.app V1262 "%" shen.s)))))) +(defun fwhen (V1293 V1294 V1295) (cond ((= true V1293) (thaw V1295)) ((= false V1293) false) (true (simple-error (cn "fwhen expects a boolean: not " (shen.app V1293 "%" shen.s)))))) -(defun call (V1277 V1278 V1279) (cond ((cons? V1277) (shen.call-help (shen.m_prolog_to_s-prolog_predicate (shen.lazyderef (hd V1277) V1278)) (tl V1277) V1278 V1279)) (true false))) +(defun call (V1308 V1309 V1310) (cond ((cons? V1308) (shen.call-help (shen.m_prolog_to_s-prolog_predicate (shen.lazyderef (hd V1308) V1309)) (tl V1308) V1309 V1310)) (true false))) -(defun shen.call-help (V1280 V1281 V1282 V1283) (cond ((= () V1281) (V1280 V1282 V1283)) ((cons? V1281) (shen.call-help (V1280 (hd V1281)) (tl V1281) V1282 V1283)) (true (shen.sys-error shen.call-help)))) +(defun shen.call-help (V1311 V1312 V1313 V1314) (cond ((= () V1312) (V1311 V1313 V1314)) ((cons? V1312) (shen.call-help (V1311 (hd V1312)) (tl V1312) V1313 V1314)) (true (shen.sys-error shen.call-help)))) -(defun shen.intprolog (V1284) (cond ((and (cons? V1284) (cons? (hd V1284))) (let ProcessN (shen.start-new-prolog-process) (shen.intprolog-help (hd (hd V1284)) (shen.insert-prolog-variables (cons (tl (hd V1284)) (cons (tl V1284) ())) ProcessN) ProcessN))) (true (shen.sys-error shen.intprolog)))) +(defun shen.intprolog (V1315) (cond ((and (cons? V1315) (cons? (hd V1315))) (let ProcessN (shen.start-new-prolog-process) (shen.intprolog-help (hd (hd V1315)) (shen.insert-prolog-variables (cons (tl (hd V1315)) (cons (tl V1315) ())) ProcessN) ProcessN))) (true (shen.sys-error shen.intprolog)))) -(defun shen.intprolog-help (V1285 V1286 V1287) (cond ((and (cons? V1286) (and (cons? (tl V1286)) (= () (tl (tl V1286))))) (shen.intprolog-help-help V1285 (hd V1286) (hd (tl V1286)) V1287)) (true (shen.sys-error shen.intprolog-help)))) +(defun shen.intprolog-help (V1316 V1317 V1318) (cond ((and (cons? V1317) (and (cons? (tl V1317)) (= () (tl (tl V1317))))) (shen.intprolog-help-help V1316 (hd V1317) (hd (tl V1317)) V1318)) (true (shen.sys-error shen.intprolog-help)))) -(defun shen.intprolog-help-help (V1288 V1289 V1290 V1291) (cond ((= () V1289) (V1288 V1291 (freeze (shen.call-rest V1290 V1291)))) ((cons? V1289) (shen.intprolog-help-help (V1288 (hd V1289)) (tl V1289) V1290 V1291)) (true (shen.sys-error shen.intprolog-help-help)))) +(defun shen.intprolog-help-help (V1319 V1320 V1321 V1322) (cond ((= () V1320) (V1319 V1322 (freeze (shen.call-rest V1321 V1322)))) ((cons? V1320) (shen.intprolog-help-help (V1319 (hd V1320)) (tl V1320) V1321 V1322)) (true (shen.sys-error shen.intprolog-help-help)))) -(defun shen.call-rest (V1294 V1295) (cond ((= () V1294) true) ((and (cons? V1294) (and (cons? (hd V1294)) (cons? (tl (hd V1294))))) (shen.call-rest (cons (cons ((hd (hd V1294)) (hd (tl (hd V1294)))) (tl (tl (hd V1294)))) (tl V1294)) V1295)) ((and (cons? V1294) (and (cons? (hd V1294)) (= () (tl (hd V1294))))) ((hd (hd V1294)) V1295 (freeze (shen.call-rest (tl V1294) V1295)))) (true (shen.sys-error shen.call-rest)))) +(defun shen.call-rest (V1325 V1326) (cond ((= () V1325) true) ((and (cons? V1325) (and (cons? (hd V1325)) (cons? (tl (hd V1325))))) (shen.call-rest (cons (cons ((hd (hd V1325)) (hd (tl (hd V1325)))) (tl (tl (hd V1325)))) (tl V1325)) V1326)) ((and (cons? V1325) (and (cons? (hd V1325)) (= () (tl (hd V1325))))) ((hd (hd V1325)) V1326 (freeze (shen.call-rest (tl V1325) V1326)))) (true (shen.sys-error shen.call-rest)))) (defun shen.start-new-prolog-process () (let IncrementProcessCounter (set shen.*process-counter* (+ 1 (value shen.*process-counter*))) (shen.initialise-prolog IncrementProcessCounter))) -(defun shen.insert-prolog-variables (V1296 V1297) (shen.insert-prolog-variables-help V1296 (shen.flatten V1296) V1297)) +(defun shen.insert-prolog-variables (V1327 V1328) (shen.insert-prolog-variables-help V1327 (shen.flatten V1327) V1328)) -(defun shen.insert-prolog-variables-help (V1302 V1303 V1304) (cond ((= () V1303) V1302) ((and (cons? V1303) (variable? (hd V1303))) (let V (shen.newpv V1304) (let XV/Y (subst V (hd V1303) V1302) (let Z-Y (remove (hd V1303) (tl V1303)) (shen.insert-prolog-variables-help XV/Y Z-Y V1304))))) ((cons? V1303) (shen.insert-prolog-variables-help V1302 (tl V1303) V1304)) (true (shen.sys-error shen.insert-prolog-variables-help)))) +(defun shen.insert-prolog-variables-help (V1333 V1334 V1335) (cond ((= () V1334) V1333) ((and (cons? V1334) (variable? (hd V1334))) (let V (shen.newpv V1335) (let XV/Y (subst V (hd V1334) V1333) (let Z-Y (remove (hd V1334) (tl V1334)) (shen.insert-prolog-variables-help XV/Y Z-Y V1335))))) ((cons? V1334) (shen.insert-prolog-variables-help V1333 (tl V1334) V1335)) (true (shen.sys-error shen.insert-prolog-variables-help)))) -(defun shen.initialise-prolog (V1305) (let Vector (address-> (value shen.*prologvectors*) V1305 (shen.fillvector (vector 10) 1 10 shen.-null-)) (let Counter (address-> (value shen.*varcounter*) V1305 1) V1305))) +(defun shen.initialise-prolog (V1336) (let Vector (address-> (value shen.*prologvectors*) V1336 (shen.fillvector (vector 10) 1 10 shen.-null-)) (let Counter (address-> (value shen.*varcounter*) V1336 1) V1336))) diff --git a/shen/klambda/reader.kl b/shen/klambda/reader.kl index 0314995..eec450f 100644 --- a/shen/klambda/reader.kl +++ b/shen/klambda/reader.kl @@ -47,166 +47,176 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun read-file-as-bytelist (V1307) (let Stream (open V1307 in) (let Byte (read-byte Stream) (let Bytes (shen.read-file-as-bytelist-help Stream Byte ()) (let Close (close Stream) (reverse Bytes)))))) +"(defun read-file-as-bytelist (V1348) (let Stream (open V1348 in) (let Byte (read-byte Stream) (let Bytes (shen.read-file-as-bytelist-help Stream Byte ()) (let Close (close Stream) (reverse Bytes)))))) -(defun shen.read-file-as-bytelist-help (V1308 V1309 V1310) (cond ((= -1 V1309) V1310) (true (shen.read-file-as-bytelist-help V1308 (read-byte V1308) (cons V1309 V1310))))) +(defun shen.read-file-as-bytelist-help (V1349 V1350 V1351) (cond ((= -1 V1350) V1351) (true (shen.read-file-as-bytelist-help V1349 (read-byte V1349) (cons V1350 V1351))))) -(defun read-file-as-string (V1311) (let Stream (open V1311 in) (shen.rfas-h Stream (read-byte Stream) ""))) +(defun read-file-as-string (V1352) (let Stream (open V1352 in) (shen.rfas-h Stream (read-byte Stream) ""))) -(defun shen.rfas-h (V1312 V1313 V1314) (cond ((= -1 V1313) (do (close V1312) V1314)) (true (shen.rfas-h V1312 (read-byte V1312) (cn V1314 (n->string V1313)))))) +(defun shen.rfas-h (V1353 V1354 V1355) (cond ((= -1 V1354) (do (close V1353) V1355)) (true (shen.rfas-h V1353 (read-byte V1353) (cn V1355 (n->string V1354)))))) -(defun input (V1315) (eval-kl (read V1315))) +(defun input (V1356) (eval-kl (read V1356))) -(defun input+ (V1316 V1317) (let Mono? (shen.monotype V1316) (let Input (read V1317) (if (= false (shen.typecheck Input V1316)) (simple-error (cn "type error: " (shen.app Input (cn " is not of type " (shen.app V1316 " +(defun input+ (V1357 V1358) (let Mono? (shen.monotype V1357) (let Input (read V1358) (if (= false (shen.typecheck Input (shen.demodulate V1357))) (simple-error (cn "type error: " (shen.app Input (cn " is not of type " (shen.app V1357 " " shen.r)) shen.r))) (eval-kl Input))))) -(defun shen.monotype (V1318) (cond ((cons? V1318) (map shen.monotype V1318)) (true (if (variable? V1318) (simple-error (cn "input+ expects a monotype: not " (shen.app V1318 " -" shen.a))) V1318)))) +(defun shen.monotype (V1359) (cond ((cons? V1359) (map (lambda X1337 (shen.monotype X1337)) V1359)) (true (if (variable? V1359) (simple-error (cn "input+ expects a monotype: not " (shen.app V1359 " +" shen.a))) V1359)))) -(defun read (V1319) (hd (shen.read-loop V1319 (read-byte V1319) ()))) +(defun read (V1360) (hd (shen.read-loop V1360 (read-byte V1360) ()))) -(defun shen.read-loop (V1322 V1323 V1324) (cond ((= -1 V1323) (if (empty? V1324) (simple-error "error: empty stream") (compile shen. V1324 (lambda E E)))) ((shen.terminator? V1323) (let AllBytes (append V1324 (cons V1323 ())) (let Read (compile shen. AllBytes (lambda E shen.nextbyte)) (if (or (= Read shen.nextbyte) (empty? Read)) (shen.read-loop V1322 (read-byte V1322) AllBytes) Read)))) (true (shen.read-loop V1322 (read-byte V1322) (append V1324 (cons V1323 ())))))) +(defun it () (value shen.*it*)) -(defun shen.terminator? (V1325) (element? V1325 (cons 9 (cons 10 (cons 13 (cons 32 (cons 34 (cons 41 (cons 93 ()))))))))) +(defun shen.read-loop (V1365 V1366 V1367) (cond ((= 94 V1366) (simple-error "read aborted")) ((= -1 V1366) (if (empty? V1367) (simple-error "error: empty stream") (compile (lambda X1338 (shen. X1338)) V1367 (lambda E E)))) ((shen.terminator? V1366) (let AllBytes (append V1367 (cons V1366 ())) (let It (shen.record-it AllBytes) (let Read (compile (lambda X1339 (shen. X1339)) AllBytes (lambda E shen.nextbyte)) (if (or (= Read shen.nextbyte) (empty? Read)) (shen.read-loop V1365 (read-byte V1365) AllBytes) Read))))) (true (shen.read-loop V1365 (read-byte V1365) (append V1367 (cons V1366 ())))))) -(defun lineread (V1326) (shen.lineread-loop (read-byte V1326) () V1326)) +(defun shen.terminator? (V1368) (element? V1368 (cons 9 (cons 10 (cons 13 (cons 32 (cons 34 (cons 41 (cons 93 ()))))))))) -(defun shen.lineread-loop (V1328 V1329 V1330) (cond ((= -1 V1328) (if (empty? V1329) (simple-error "empty stream") (compile shen. V1329 (lambda E E)))) ((= V1328 (shen.hat)) (simple-error "line read aborted")) ((element? V1328 (cons (shen.newline) (cons (shen.carriage-return) ()))) (let Line (compile shen. V1329 (lambda E shen.nextline)) (if (or (= Line shen.nextline) (empty? Line)) (shen.lineread-loop (read-byte V1330) (append V1329 (cons V1328 ())) V1330) Line))) (true (shen.lineread-loop (read-byte V1330) (append V1329 (cons V1328 ())) V1330)))) +(defun lineread (V1369) (shen.lineread-loop (read-byte V1369) () V1369)) -(defun read-file (V1331) (let Bytelist (read-file-as-bytelist V1331) (compile shen. Bytelist shen.read-error))) +(defun shen.lineread-loop (V1371 V1372 V1373) (cond ((= -1 V1371) (if (empty? V1372) (simple-error "empty stream") (compile (lambda X1340 (shen. X1340)) V1372 (lambda E E)))) ((= V1371 (shen.hat)) (simple-error "line read aborted")) ((element? V1371 (cons (shen.newline) (cons (shen.carriage-return) ()))) (let Line (compile (lambda X1341 (shen. X1341)) V1372 (lambda E shen.nextline)) (let It (shen.record-it V1372) (if (or (= Line shen.nextline) (empty? Line)) (shen.lineread-loop (read-byte V1373) (append V1372 (cons V1371 ())) V1373) Line)))) (true (shen.lineread-loop (read-byte V1373) (append V1372 (cons V1371 ())) V1373)))) -(defun read-from-string (V1332) (let Ns (map (lambda V1306 (string->n V1306)) (explode V1332)) (compile shen. Ns shen.read-error))) +(defun shen.record-it (V1374) (let TrimLeft (shen.trim-whitespace V1374) (let TrimRight (shen.trim-whitespace (reverse TrimLeft)) (let Trimmed (reverse TrimRight) (shen.record-it-h Trimmed))))) -(defun shen.read-error (V1339) (cond ((and (cons? V1339) (and (cons? (hd V1339)) (and (cons? (tl V1339)) (= () (tl (tl V1339)))))) (simple-error (cn "read error here: +(defun shen.trim-whitespace (V1375) (cond ((and (cons? V1375) (element? (hd V1375) (cons 9 (cons 10 (cons 13 (cons 32 ())))))) (shen.trim-whitespace (tl V1375))) (true V1375))) - " (shen.app (shen.compress-50 50 (hd V1339)) " +(defun shen.record-it-h (V1376) (do (set shen.*it* (shen.cn-all (map (lambda X1342 (n->string X1342)) V1376))) V1376)) + +(defun shen.cn-all (V1377) (cond ((= () V1377) "") ((cons? V1377) (cn (hd V1377) (shen.cn-all (tl V1377)))) (true (shen.sys-error shen.cn-all)))) + +(defun read-file (V1378) (let Bytelist (read-file-as-bytelist V1378) (compile (lambda X1343 (shen. X1343)) Bytelist (lambda X1344 (shen.read-error X1344))))) + +(defun read-from-string (V1379) (let Ns (map (lambda X1345 (string->n X1345)) (explode V1379)) (compile (lambda X1346 (shen. X1346)) Ns (lambda X1347 (shen.read-error X1347))))) + +(defun shen.read-error (V1386) (cond ((and (cons? V1386) (and (cons? (hd V1386)) (and (cons? (tl V1386)) (= () (tl (tl V1386)))))) (simple-error (cn "read error here: + + " (shen.app (shen.compress-50 50 (hd V1386)) " " shen.a)))) (true (simple-error "read error ")))) -(defun shen.compress-50 (V1344 V1345) (cond ((= () V1345) "") ((= 0 V1344) "") ((cons? V1345) (cn (n->string (hd V1345)) (shen.compress-50 (- V1344 1) (tl V1345)))) (true (shen.sys-error shen.compress-50)))) +(defun shen.compress-50 (V1391 V1392) (cond ((= () V1392) "") ((= 0 V1391) "") ((cons? V1392) (cn (n->string (hd V1392)) (shen.compress-50 (- V1391 1) (tl V1392)))) (true (shen.sys-error shen.compress-50)))) -(defun shen. (V1350) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (macroexpand (shen.cons_form (shen.hdtl Parse_shen.))) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.package-macro (macroexpand (shen.hdtl Parse_shen.)) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons { (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons } (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons bar! (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons ; (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons := (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons :- (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons : (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (intern ",") (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (macroexpand (shen.hdtl Parse_shen.)) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1350) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1350) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result))) +(defun shen. (V1397) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (macroexpand (shen.cons_form (shen.hdtl Parse_shen.))) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.package-macro (macroexpand (shen.hdtl Parse_shen.)) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons { (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons } (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons bar! (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons ; (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons := (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons :- (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons : (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (intern ",") (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (macroexpand (shen.hdtl Parse_shen.)) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1397) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1397) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result)) Result))) -(defun shen. (V1355) (let Result (if (and (cons? (hd V1355)) (= 91 (hd (hd V1355)))) (shen.pair (hd (shen.pair (tl (hd V1355)) (shen.hdtl V1355))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1402) (let Result (if (and (cons? (hd V1402)) (= 91 (hd (hd V1402)))) (shen.pair (hd (shen.pair (tl (hd V1402)) (shen.hdtl V1402))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1360) (let Result (if (and (cons? (hd V1360)) (= 93 (hd (hd V1360)))) (shen.pair (hd (shen.pair (tl (hd V1360)) (shen.hdtl V1360))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1407) (let Result (if (and (cons? (hd V1407)) (= 93 (hd (hd V1407)))) (shen.pair (hd (shen.pair (tl (hd V1407)) (shen.hdtl V1407))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1365) (let Result (if (and (cons? (hd V1365)) (= 123 (hd (hd V1365)))) (shen.pair (hd (shen.pair (tl (hd V1365)) (shen.hdtl V1365))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1412) (let Result (if (and (cons? (hd V1412)) (= 123 (hd (hd V1412)))) (shen.pair (hd (shen.pair (tl (hd V1412)) (shen.hdtl V1412))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1370) (let Result (if (and (cons? (hd V1370)) (= 125 (hd (hd V1370)))) (shen.pair (hd (shen.pair (tl (hd V1370)) (shen.hdtl V1370))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1417) (let Result (if (and (cons? (hd V1417)) (= 125 (hd (hd V1417)))) (shen.pair (hd (shen.pair (tl (hd V1417)) (shen.hdtl V1417))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1375) (let Result (if (and (cons? (hd V1375)) (= 124 (hd (hd V1375)))) (shen.pair (hd (shen.pair (tl (hd V1375)) (shen.hdtl V1375))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1422) (let Result (if (and (cons? (hd V1422)) (= 124 (hd (hd V1422)))) (shen.pair (hd (shen.pair (tl (hd V1422)) (shen.hdtl V1422))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1380) (let Result (if (and (cons? (hd V1380)) (= 59 (hd (hd V1380)))) (shen.pair (hd (shen.pair (tl (hd V1380)) (shen.hdtl V1380))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1427) (let Result (if (and (cons? (hd V1427)) (= 59 (hd (hd V1427)))) (shen.pair (hd (shen.pair (tl (hd V1427)) (shen.hdtl V1427))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1385) (let Result (if (and (cons? (hd V1385)) (= 58 (hd (hd V1385)))) (shen.pair (hd (shen.pair (tl (hd V1385)) (shen.hdtl V1385))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1432) (let Result (if (and (cons? (hd V1432)) (= 58 (hd (hd V1432)))) (shen.pair (hd (shen.pair (tl (hd V1432)) (shen.hdtl V1432))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1390) (let Result (if (and (cons? (hd V1390)) (= 44 (hd (hd V1390)))) (shen.pair (hd (shen.pair (tl (hd V1390)) (shen.hdtl V1390))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1437) (let Result (if (and (cons? (hd V1437)) (= 44 (hd (hd V1437)))) (shen.pair (hd (shen.pair (tl (hd V1437)) (shen.hdtl V1437))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1395) (let Result (if (and (cons? (hd V1395)) (= 61 (hd (hd V1395)))) (shen.pair (hd (shen.pair (tl (hd V1395)) (shen.hdtl V1395))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1442) (let Result (if (and (cons? (hd V1442)) (= 61 (hd (hd V1442)))) (shen.pair (hd (shen.pair (tl (hd V1442)) (shen.hdtl V1442))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1400) (let Result (if (and (cons? (hd V1400)) (= 45 (hd (hd V1400)))) (shen.pair (hd (shen.pair (tl (hd V1400)) (shen.hdtl V1400))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1447) (let Result (if (and (cons? (hd V1447)) (= 45 (hd (hd V1447)))) (shen.pair (hd (shen.pair (tl (hd V1447)) (shen.hdtl V1447))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1405) (let Result (if (and (cons? (hd V1405)) (= 40 (hd (hd V1405)))) (shen.pair (hd (shen.pair (tl (hd V1405)) (shen.hdtl V1405))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1452) (let Result (if (and (cons? (hd V1452)) (= 40 (hd (hd V1452)))) (shen.pair (hd (shen.pair (tl (hd V1452)) (shen.hdtl V1452))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1410) (let Result (if (and (cons? (hd V1410)) (= 41 (hd (hd V1410)))) (shen.pair (hd (shen.pair (tl (hd V1410)) (shen.hdtl V1410))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1457) (let Result (if (and (cons? (hd V1457)) (= 41 (hd (hd V1457)))) (shen.pair (hd (shen.pair (tl (hd V1457)) (shen.hdtl V1457))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1415) (let Result (let Parse_shen. (shen. V1415) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.control-chars (shen.hdtl Parse_shen.))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1415) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1415) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (if (= (shen.hdtl Parse_shen.) "<>") (cons vector (cons 0 ())) (intern (shen.hdtl Parse_shen.)))) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result))) +(defun shen. (V1462) (let Result (let Parse_shen. (shen. V1462) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.control-chars (shen.hdtl Parse_shen.))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1462) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1462) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (if (= (shen.hdtl Parse_shen.) "<>") (cons vector (cons 0 ())) (intern (shen.hdtl Parse_shen.)))) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result))) -(defun shen.control-chars (V1416) (cond ((= () V1416) "") ((and (cons? V1416) (and (= "c" (hd V1416)) (and (cons? (tl V1416)) (= "#" (hd (tl V1416)))))) (let CodePoint (shen.code-point (tl (tl V1416))) (let AfterCodePoint (shen.after-codepoint (tl (tl V1416))) (@s (n->string (shen.decimalise CodePoint)) (shen.control-chars AfterCodePoint))))) ((cons? V1416) (@s (hd V1416) (shen.control-chars (tl V1416)))) (true (shen.sys-error shen.control-chars)))) +(defun shen.control-chars (V1463) (cond ((= () V1463) "") ((and (cons? V1463) (and (= "c" (hd V1463)) (and (cons? (tl V1463)) (= "#" (hd (tl V1463)))))) (let CodePoint (shen.code-point (tl (tl V1463))) (let AfterCodePoint (shen.after-codepoint (tl (tl V1463))) (@s (n->string (shen.decimalise CodePoint)) (shen.control-chars AfterCodePoint))))) ((cons? V1463) (@s (hd V1463) (shen.control-chars (tl V1463)))) (true (shen.sys-error shen.control-chars)))) -(defun shen.code-point (V1419) (cond ((and (cons? V1419) (= ";" (hd V1419))) "") ((and (cons? V1419) (element? (hd V1419) (cons "0" (cons "1" (cons "2" (cons "3" (cons "4" (cons "5" (cons "6" (cons "7" (cons "8" (cons "9" (cons "0" ()))))))))))))) (cons (hd V1419) (shen.code-point (tl V1419)))) (true (simple-error (cn "code point parse error " (shen.app V1419 " +(defun shen.code-point (V1466) (cond ((and (cons? V1466) (= ";" (hd V1466))) "") ((and (cons? V1466) (element? (hd V1466) (cons "0" (cons "1" (cons "2" (cons "3" (cons "4" (cons "5" (cons "6" (cons "7" (cons "8" (cons "9" (cons "0" ()))))))))))))) (cons (hd V1466) (shen.code-point (tl V1466)))) (true (simple-error (cn "code point parse error " (shen.app V1466 " " shen.a)))))) -(defun shen.after-codepoint (V1424) (cond ((= () V1424) ()) ((and (cons? V1424) (= ";" (hd V1424))) (tl V1424)) ((cons? V1424) (shen.after-codepoint (tl V1424))) (true (shen.sys-error shen.after-codepoint)))) +(defun shen.after-codepoint (V1471) (cond ((= () V1471) ()) ((and (cons? V1471) (= ";" (hd V1471))) (tl V1471)) ((cons? V1471) (shen.after-codepoint (tl V1471))) (true (shen.sys-error shen.after-codepoint)))) -(defun shen.decimalise (V1425) (shen.pre (reverse (shen.digits->integers V1425)) 0)) +(defun shen.decimalise (V1472) (shen.pre (reverse (shen.digits->integers V1472)) 0)) -(defun shen.digits->integers (V1430) (cond ((and (cons? V1430) (= "0" (hd V1430))) (cons 0 (shen.digits->integers (tl V1430)))) ((and (cons? V1430) (= "1" (hd V1430))) (cons 1 (shen.digits->integers (tl V1430)))) ((and (cons? V1430) (= "2" (hd V1430))) (cons 2 (shen.digits->integers (tl V1430)))) ((and (cons? V1430) (= "3" (hd V1430))) (cons 3 (shen.digits->integers (tl V1430)))) ((and (cons? V1430) (= "4" (hd V1430))) (cons 4 (shen.digits->integers (tl V1430)))) ((and (cons? V1430) (= "5" (hd V1430))) (cons 5 (shen.digits->integers (tl V1430)))) ((and (cons? V1430) (= "6" (hd V1430))) (cons 6 (shen.digits->integers (tl V1430)))) ((and (cons? V1430) (= "7" (hd V1430))) (cons 7 (shen.digits->integers (tl V1430)))) ((and (cons? V1430) (= "8" (hd V1430))) (cons 8 (shen.digits->integers (tl V1430)))) ((and (cons? V1430) (= "9" (hd V1430))) (cons 9 (shen.digits->integers (tl V1430)))) (true ()))) +(defun shen.digits->integers (V1477) (cond ((and (cons? V1477) (= "0" (hd V1477))) (cons 0 (shen.digits->integers (tl V1477)))) ((and (cons? V1477) (= "1" (hd V1477))) (cons 1 (shen.digits->integers (tl V1477)))) ((and (cons? V1477) (= "2" (hd V1477))) (cons 2 (shen.digits->integers (tl V1477)))) ((and (cons? V1477) (= "3" (hd V1477))) (cons 3 (shen.digits->integers (tl V1477)))) ((and (cons? V1477) (= "4" (hd V1477))) (cons 4 (shen.digits->integers (tl V1477)))) ((and (cons? V1477) (= "5" (hd V1477))) (cons 5 (shen.digits->integers (tl V1477)))) ((and (cons? V1477) (= "6" (hd V1477))) (cons 6 (shen.digits->integers (tl V1477)))) ((and (cons? V1477) (= "7" (hd V1477))) (cons 7 (shen.digits->integers (tl V1477)))) ((and (cons? V1477) (= "8" (hd V1477))) (cons 8 (shen.digits->integers (tl V1477)))) ((and (cons? V1477) (= "9" (hd V1477))) (cons 9 (shen.digits->integers (tl V1477)))) (true ()))) -(defun shen. (V1435) (let Result (let Parse_shen. (shen. V1435) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (@s (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1482) (let Result (let Parse_shen. (shen. V1482) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (@s (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1440) (let Result (let Parse_shen. (shen. V1440) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (@s (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1440) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) "") (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1487) (let Result (let Parse_shen. (shen. V1487) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (@s (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1487) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) "") (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1445) (let Result (let Parse_shen. (shen. V1445) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1445) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1492) (let Result (let Parse_shen. (shen. V1492) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1492) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1450) (let Result (if (cons? (hd V1450)) (let Parse_Byte (hd (hd V1450)) (if (shen.numbyte? Parse_Byte) (shen.pair (hd (shen.pair (tl (hd V1450)) (shen.hdtl V1450))) (n->string Parse_Byte)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1497) (let Result (if (cons? (hd V1497)) (let Parse_Byte (hd (hd V1497)) (if (shen.numbyte? Parse_Byte) (shen.pair (hd (shen.pair (tl (hd V1497)) (shen.hdtl V1497))) (n->string Parse_Byte)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen.numbyte? (V1455) (cond ((= 48 V1455) true) ((= 49 V1455) true) ((= 50 V1455) true) ((= 51 V1455) true) ((= 52 V1455) true) ((= 53 V1455) true) ((= 54 V1455) true) ((= 55 V1455) true) ((= 56 V1455) true) ((= 57 V1455) true) (true false))) +(defun shen.numbyte? (V1502) (cond ((= 48 V1502) true) ((= 49 V1502) true) ((= 50 V1502) true) ((= 51 V1502) true) ((= 52 V1502) true) ((= 53 V1502) true) ((= 54 V1502) true) ((= 55 V1502) true) ((= 56 V1502) true) ((= 57 V1502) true) (true false))) -(defun shen. (V1460) (let Result (if (cons? (hd V1460)) (let Parse_Byte (hd (hd V1460)) (if (shen.symbol-code? Parse_Byte) (shen.pair (hd (shen.pair (tl (hd V1460)) (shen.hdtl V1460))) (n->string Parse_Byte)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1507) (let Result (if (cons? (hd V1507)) (let Parse_Byte (hd (hd V1507)) (if (shen.symbol-code? Parse_Byte) (shen.pair (hd (shen.pair (tl (hd V1507)) (shen.hdtl V1507))) (n->string Parse_Byte)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen.symbol-code? (V1461) (or (= V1461 126) (or (and (> V1461 94) (< V1461 123)) (or (and (> V1461 59) (< V1461 91)) (or (and (> V1461 41) (and (< V1461 58) (not (= V1461 44)))) (or (and (> V1461 34) (< V1461 40)) (= V1461 33))))))) +(defun shen.symbol-code? (V1508) (or (= V1508 126) (or (and (> V1508 94) (< V1508 123)) (or (and (> V1508 59) (< V1508 91)) (or (and (> V1508 41) (and (< V1508 58) (not (= V1508 44)))) (or (and (> V1508 34) (< V1508 40)) (= V1508 33))))))) -(defun shen. (V1466) (let Result (let Parse_shen. (shen. V1466) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1513) (let Result (let Parse_shen. (shen. V1513) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1471) (let Result (if (cons? (hd V1471)) (let Parse_Byte (hd (hd V1471)) (if (= Parse_Byte 34) (shen.pair (hd (shen.pair (tl (hd V1471)) (shen.hdtl V1471))) Parse_Byte) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1518) (let Result (if (cons? (hd V1518)) (let Parse_Byte (hd (hd V1518)) (if (= Parse_Byte 34) (shen.pair (hd (shen.pair (tl (hd V1518)) (shen.hdtl V1518))) Parse_Byte) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1476) (let Result (let Parse_shen. (shen. V1476) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1476) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1523) (let Result (let Parse_shen. (shen. V1523) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1523) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1481) (let Result (if (cons? (hd V1481)) (let Parse_Byte (hd (hd V1481)) (shen.pair (hd (shen.pair (tl (hd V1481)) (shen.hdtl V1481))) (n->string Parse_Byte))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1528) (let Result (if (cons? (hd V1528)) (let Parse_Byte (hd (hd V1528)) (shen.pair (hd (shen.pair (tl (hd V1528)) (shen.hdtl V1528))) (n->string Parse_Byte))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1486) (let Result (if (cons? (hd V1486)) (let Parse_Byte (hd (hd V1486)) (if (not (= Parse_Byte 34)) (shen.pair (hd (shen.pair (tl (hd V1486)) (shen.hdtl V1486))) (n->string Parse_Byte)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1533) (let Result (if (cons? (hd V1533)) (let Parse_Byte (hd (hd V1533)) (if (not (= Parse_Byte 34)) (shen.pair (hd (shen.pair (tl (hd V1533)) (shen.hdtl V1533))) (n->string Parse_Byte)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1491) (let Result (let Parse_shen. (shen. V1491) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (- 0 (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1491) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1491) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (* (shen.expt 10 (shen.hdtl Parse_shen.)) (+ (shen.pre (reverse (shen.hdtl Parse_shen.)) 0) (shen.post (shen.hdtl Parse_shen.) 1)))) (fail))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1491) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (* (shen.expt 10 (shen.hdtl Parse_shen.)) (shen.pre (reverse (shen.hdtl Parse_shen.)) 0))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1491) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (+ (shen.pre (reverse (shen.hdtl Parse_shen.)) 0) (shen.post (shen.hdtl Parse_shen.) 1))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1491) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pre (reverse (shen.hdtl Parse_shen.)) 0)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)) Result)) Result))) +(defun shen. (V1538) (let Result (let Parse_shen. (shen. V1538) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (- 0 (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1538) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1538) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (* (shen.expt 10 (shen.hdtl Parse_shen.)) (+ (shen.pre (reverse (shen.hdtl Parse_shen.)) 0) (shen.post (shen.hdtl Parse_shen.) 1)))) (fail))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1538) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (* (shen.expt 10 (shen.hdtl Parse_shen.)) (shen.pre (reverse (shen.hdtl Parse_shen.)) 0))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1538) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (+ (shen.pre (reverse (shen.hdtl Parse_shen.)) 0) (shen.post (shen.hdtl Parse_shen.) 1))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1538) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pre (reverse (shen.hdtl Parse_shen.)) 0)) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result)) Result)) Result)) Result))) -(defun shen. (V1496) (let Result (if (and (cons? (hd V1496)) (= 101 (hd (hd V1496)))) (shen.pair (hd (shen.pair (tl (hd V1496)) (shen.hdtl V1496))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1543) (let Result (if (and (cons? (hd V1543)) (= 101 (hd (hd V1543)))) (shen.pair (hd (shen.pair (tl (hd V1543)) (shen.hdtl V1543))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1501) (let Result (let Parse_shen. (shen. V1501) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (- 0 (shen.pre (reverse (shen.hdtl Parse_shen.)) 0))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1501) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pre (reverse (shen.hdtl Parse_shen.)) 0)) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1548) (let Result (let Parse_shen. (shen. V1548) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (- 0 (shen.pre (reverse (shen.hdtl Parse_shen.)) 0))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1548) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.pre (reverse (shen.hdtl Parse_shen.)) 0)) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1506) (let Result (if (cons? (hd V1506)) (let Parse_Byte (hd (hd V1506)) (if (= Parse_Byte 43) (shen.pair (hd (shen.pair (tl (hd V1506)) (shen.hdtl V1506))) Parse_Byte) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1553) (let Result (if (cons? (hd V1553)) (let Parse_Byte (hd (hd V1553)) (if (= Parse_Byte 43) (shen.pair (hd (shen.pair (tl (hd V1553)) (shen.hdtl V1553))) Parse_Byte) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1511) (let Result (if (cons? (hd V1511)) (let Parse_Byte (hd (hd V1511)) (if (= Parse_Byte 46) (shen.pair (hd (shen.pair (tl (hd V1511)) (shen.hdtl V1511))) Parse_Byte) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1558) (let Result (if (cons? (hd V1558)) (let Parse_Byte (hd (hd V1558)) (if (= Parse_Byte 46) (shen.pair (hd (shen.pair (tl (hd V1558)) (shen.hdtl V1558))) Parse_Byte) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1516) (let Result (let Parse_shen. (shen. V1516) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1516) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1563) (let Result (let Parse_shen. (shen. V1563) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1563) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1521) (let Result (let Parse_shen. (shen. V1521) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1568) (let Result (let Parse_shen. (shen. V1568) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1526) (let Result (let Parse_shen. (shen. V1526) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1526) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1573) (let Result (let Parse_shen. (shen. V1573) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1573) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) ())) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1531) (let Result (if (cons? (hd V1531)) (let Parse_X (hd (hd V1531)) (if (shen.numbyte? Parse_X) (shen.pair (hd (shen.pair (tl (hd V1531)) (shen.hdtl V1531))) (shen.byte->digit Parse_X)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1578) (let Result (if (cons? (hd V1578)) (let Parse_X (hd (hd V1578)) (if (shen.numbyte? Parse_X) (shen.pair (hd (shen.pair (tl (hd V1578)) (shen.hdtl V1578))) (shen.byte->digit Parse_X)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen.byte->digit (V1532) (cond ((= 48 V1532) 0) ((= 49 V1532) 1) ((= 50 V1532) 2) ((= 51 V1532) 3) ((= 52 V1532) 4) ((= 53 V1532) 5) ((= 54 V1532) 6) ((= 55 V1532) 7) ((= 56 V1532) 8) ((= 57 V1532) 9) (true (shen.sys-error shen.byte->digit)))) +(defun shen.byte->digit (V1579) (cond ((= 48 V1579) 0) ((= 49 V1579) 1) ((= 50 V1579) 2) ((= 51 V1579) 3) ((= 52 V1579) 4) ((= 53 V1579) 5) ((= 54 V1579) 6) ((= 55 V1579) 7) ((= 56 V1579) 8) ((= 57 V1579) 9) (true (shen.sys-error shen.byte->digit)))) -(defun shen.pre (V1535 V1536) (cond ((= () V1535) 0) ((cons? V1535) (+ (* (shen.expt 10 V1536) (hd V1535)) (shen.pre (tl V1535) (+ V1536 1)))) (true (shen.sys-error shen.pre)))) +(defun shen.pre (V1582 V1583) (cond ((= () V1582) 0) ((cons? V1582) (+ (* (shen.expt 10 V1583) (hd V1582)) (shen.pre (tl V1582) (+ V1583 1)))) (true (shen.sys-error shen.pre)))) -(defun shen.post (V1539 V1540) (cond ((= () V1539) 0) ((cons? V1539) (+ (* (shen.expt 10 (- 0 V1540)) (hd V1539)) (shen.post (tl V1539) (+ V1540 1)))) (true (shen.sys-error shen.post)))) +(defun shen.post (V1586 V1587) (cond ((= () V1586) 0) ((cons? V1586) (+ (* (shen.expt 10 (- 0 V1587)) (hd V1586)) (shen.post (tl V1586) (+ V1587 1)))) (true (shen.sys-error shen.post)))) -(defun shen.expt (V1543 V1544) (cond ((= 0 V1544) 1) ((> V1544 0) (* V1543 (shen.expt V1543 (- V1544 1)))) (true (* 1 (/ (shen.expt V1543 (+ V1544 1)) V1543))))) +(defun shen.expt (V1590 V1591) (cond ((= 0 V1591) 1) ((> V1591 0) (* V1590 (shen.expt V1590 (- V1591 1)))) (true (* 1 (/ (shen.expt V1590 (+ V1591 1)) V1590))))) -(defun shen. (V1549) (let Result (let Parse_shen. (shen. V1549) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1596) (let Result (let Parse_shen. (shen. V1596) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1554) (let Result (let Parse_shen. (shen. V1554) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1601) (let Result (let Parse_shen. (shen. V1601) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1559) (let Result (let Parse_shen. (shen. V1559) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1559) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1606) (let Result (let Parse_shen. (shen. V1606) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1606) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1564) (let Result (let Parse_shen. (shen. V1564) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1611) (let Result (let Parse_shen. (shen. V1611) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1569) (let Result (if (and (cons? (hd V1569)) (= 92 (hd (hd V1569)))) (shen.pair (hd (shen.pair (tl (hd V1569)) (shen.hdtl V1569))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1616) (let Result (if (and (cons? (hd V1616)) (= 92 (hd (hd V1616)))) (shen.pair (hd (shen.pair (tl (hd V1616)) (shen.hdtl V1616))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1574) (let Result (let Parse_shen. (shen. V1574) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1574) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) shen.skip) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1621) (let Result (let Parse_shen. (shen. V1621) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1621) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) shen.skip) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1579) (let Result (if (cons? (hd V1579)) (let Parse_X (hd (hd V1579)) (if (not (element? Parse_X (cons 10 (cons 13 ())))) (shen.pair (hd (shen.pair (tl (hd V1579)) (shen.hdtl V1579))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1626) (let Result (if (cons? (hd V1626)) (let Parse_X (hd (hd V1626)) (if (not (element? Parse_X (cons 10 (cons 13 ())))) (shen.pair (hd (shen.pair (tl (hd V1626)) (shen.hdtl V1626))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1584) (let Result (if (cons? (hd V1584)) (let Parse_X (hd (hd V1584)) (if (element? Parse_X (cons 10 (cons 13 ()))) (shen.pair (hd (shen.pair (tl (hd V1584)) (shen.hdtl V1584))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1631) (let Result (if (cons? (hd V1631)) (let Parse_X (hd (hd V1631)) (if (element? Parse_X (cons 10 (cons 13 ()))) (shen.pair (hd (shen.pair (tl (hd V1631)) (shen.hdtl V1631))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1589) (let Result (let Parse_shen. (shen. V1589) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1636) (let Result (let Parse_shen. (shen. V1636) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1594) (let Result (if (and (cons? (hd V1594)) (= 42 (hd (hd V1594)))) (shen.pair (hd (shen.pair (tl (hd V1594)) (shen.hdtl V1594))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1641) (let Result (if (and (cons? (hd V1641)) (= 42 (hd (hd V1641)))) (shen.pair (hd (shen.pair (tl (hd V1641)) (shen.hdtl V1641))) shen.skip) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1599) (let Result (let Parse_shen. (shen. V1599) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1599) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= Result (fail)) (let Result (if (cons? (hd V1599)) (let Parse_X (hd (hd V1599)) (let Parse_shen. (shen. (shen.pair (tl (hd V1599)) (shen.hdtl V1599))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail)))) (fail)) (if (= Result (fail)) (fail) Result)) Result)) Result))) +(defun shen. (V1646) (let Result (let Parse_shen. (shen. V1646) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1646) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= Result (fail)) (let Result (if (cons? (hd V1646)) (let Parse_X (hd (hd V1646)) (let Parse_shen. (shen. (shen.pair (tl (hd V1646)) (shen.hdtl V1646))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail)))) (fail)) (if (= Result (fail)) (fail) Result)) Result)) Result))) -(defun shen. (V1604) (let Result (let Parse_shen. (shen. V1604) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1604) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1651) (let Result (let Parse_shen. (shen. V1651) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1651) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) shen.skip) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1609) (let Result (if (cons? (hd V1609)) (let Parse_X (hd (hd V1609)) (if (let Parse_Case Parse_X (or (= Parse_Case 32) (or (= Parse_Case 13) (or (= Parse_Case 10) (= Parse_Case 9))))) (shen.pair (hd (shen.pair (tl (hd V1609)) (shen.hdtl V1609))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1656) (let Result (if (cons? (hd V1656)) (let Parse_X (hd (hd V1656)) (if (let Parse_Case Parse_X (or (= Parse_Case 32) (or (= Parse_Case 13) (or (= Parse_Case 10) (= Parse_Case 9))))) (shen.pair (hd (shen.pair (tl (hd V1656)) (shen.hdtl V1656))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen.cons_form (V1610) (cond ((= () V1610) ()) ((and (cons? V1610) (and (cons? (tl V1610)) (and (cons? (tl (tl V1610))) (and (= () (tl (tl (tl V1610)))) (= (hd (tl V1610)) bar!))))) (cons cons (cons (hd V1610) (tl (tl V1610))))) ((cons? V1610) (cons cons (cons (hd V1610) (cons (shen.cons_form (tl V1610)) ())))) (true (shen.sys-error shen.cons_form)))) +(defun shen.cons_form (V1657) (cond ((= () V1657) ()) ((and (cons? V1657) (and (cons? (tl V1657)) (and (cons? (tl (tl V1657))) (and (= () (tl (tl (tl V1657)))) (= (hd (tl V1657)) bar!))))) (cons cons (cons (hd V1657) (tl (tl V1657))))) ((cons? V1657) (cons cons (cons (hd V1657) (cons (shen.cons_form (tl V1657)) ())))) (true (shen.sys-error shen.cons_form)))) -(defun shen.package-macro (V1613 V1614) (cond ((and (cons? V1613) (and (= $ (hd V1613)) (and (cons? (tl V1613)) (= () (tl (tl V1613)))))) (append (explode (hd (tl V1613))) V1614)) ((and (cons? V1613) (and (= package (hd V1613)) (and (cons? (tl V1613)) (and (= null (hd (tl V1613))) (cons? (tl (tl V1613))))))) (append (tl (tl (tl V1613))) V1614)) ((and (cons? V1613) (and (= package (hd V1613)) (and (cons? (tl V1613)) (cons? (tl (tl V1613)))))) (let ListofExceptions (shen.eval-without-macros (hd (tl (tl V1613)))) (let Record (shen.record-exceptions ListofExceptions (hd (tl V1613))) (let PackageNameDot (intern (cn (str (hd (tl V1613))) ".")) (append (shen.packageh PackageNameDot ListofExceptions (tl (tl (tl V1613)))) V1614))))) (true (cons V1613 V1614)))) +(defun shen.package-macro (V1660 V1661) (cond ((and (cons? V1660) (and (= $ (hd V1660)) (and (cons? (tl V1660)) (= () (tl (tl V1660)))))) (append (explode (hd (tl V1660))) V1661)) ((and (cons? V1660) (and (= package (hd V1660)) (and (cons? (tl V1660)) (and (= null (hd (tl V1660))) (cons? (tl (tl V1660))))))) (append (tl (tl (tl V1660))) V1661)) ((and (cons? V1660) (and (= package (hd V1660)) (and (cons? (tl V1660)) (cons? (tl (tl V1660)))))) (let ListofExceptions (shen.eval-without-macros (hd (tl (tl V1660)))) (let Record (shen.record-exceptions ListofExceptions (hd (tl V1660))) (let PackageNameDot (intern (cn (str (hd (tl V1660))) ".")) (append (shen.packageh PackageNameDot ListofExceptions (tl (tl (tl V1660)))) V1661))))) (true (cons V1660 V1661)))) -(defun shen.record-exceptions (V1615 V1616) (let CurrExceptions (trap-error (get V1616 shen.external-symbols (value *property-vector*)) (lambda E ())) (let AllExceptions (union V1615 CurrExceptions) (put V1616 shen.external-symbols AllExceptions (value *property-vector*))))) +(defun shen.record-exceptions (V1662 V1663) (let CurrExceptions (trap-error (get V1663 shen.external-symbols (value *property-vector*)) (lambda E ())) (let AllExceptions (union V1662 CurrExceptions) (put V1663 shen.external-symbols AllExceptions (value *property-vector*))))) -(defun shen.packageh (V1625 V1626 V1627) (cond ((cons? V1627) (cons (shen.packageh V1625 V1626 (hd V1627)) (shen.packageh V1625 V1626 (tl V1627)))) ((or (shen.sysfunc? V1627) (or (variable? V1627) (or (element? V1627 V1626) (or (shen.doubleunderline? V1627) (shen.singleunderline? V1627))))) V1627) ((and (symbol? V1627) (not (shen.prefix? (cons "s" (cons "h" (cons "e" (cons "n" (cons "." ()))))) (explode V1627)))) (concat V1625 V1627)) (true V1627))) +(defun shen.packageh (V1672 V1673 V1674) (cond ((cons? V1674) (cons (shen.packageh V1672 V1673 (hd V1674)) (shen.packageh V1672 V1673 (tl V1674)))) ((or (shen.sysfunc? V1674) (or (variable? V1674) (or (element? V1674 V1673) (or (shen.doubleunderline? V1674) (shen.singleunderline? V1674))))) V1674) ((and (symbol? V1674) (not (shen.prefix? (cons "s" (cons "h" (cons "e" (cons "n" (cons "." ()))))) (explode V1674)))) (concat V1672 V1674)) (true V1674))) diff --git a/shen/klambda/sequent.kl b/shen/klambda/sequent.kl index 4283a82..5be3183 100644 --- a/shen/klambda/sequent.kl +++ b/shen/klambda/sequent.kl @@ -47,114 +47,120 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun shen.datatype-error (V1632) (cond ((and (cons? V1632) (and (cons? (tl V1632)) (= () (tl (tl V1632))))) (simple-error (cn "datatype syntax error here: +"(defun shen.datatype-error (V1686) (cond ((and (cons? V1686) (and (cons? (tl V1686)) (= () (tl (tl V1686))))) (simple-error (cn "datatype syntax error here: - " (shen.app (shen.next-50 50 (hd V1632)) " + " (shen.app (shen.next-50 50 (hd V1686)) " " shen.a)))) (true (shen.sys-error shen.datatype-error)))) -(defun shen. (V1637) (let Result (let Parse_shen. (shen. V1637) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1637) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1691) (let Result (let Parse_shen. (shen. V1691) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1691) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1642) (let Result (let Parse_shen. (shen. V1642) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent shen.single (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1642) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent shen.double (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1696) (let Result (let Parse_shen. (shen. V1696) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent shen.single (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1696) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent shen.double (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ()))))) (fail))) (fail))) (fail))) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1647) (let Result (let Parse_shen. (shen. V1647) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1647) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1701) (let Result (let Parse_shen. (shen. V1701) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1701) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1652) (let Result (if (and (cons? (hd V1652)) (= if (hd (hd V1652)))) (let Parse_shen. (shen. (shen.pair (tl (hd V1652)) (shen.hdtl V1652))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons if (cons (shen.hdtl Parse_shen.) ()))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V1652)) (= let (hd (hd V1652)))) (let Parse_shen. (shen. (shen.pair (tl (hd V1652)) (shen.hdtl V1652))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons let (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ())))) (fail))) (fail))) (fail)) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1706) (let Result (if (and (cons? (hd V1706)) (= if (hd (hd V1706)))) (let Parse_shen. (shen. (shen.pair (tl (hd V1706)) (shen.hdtl V1706))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons if (cons (shen.hdtl Parse_shen.) ()))) (fail))) (fail)) (if (= Result (fail)) (let Result (if (and (cons? (hd V1706)) (= let (hd (hd V1706)))) (let Parse_shen. (shen. (shen.pair (tl (hd V1706)) (shen.hdtl V1706))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons let (cons (shen.hdtl Parse_shen.) (cons (shen.hdtl Parse_shen.) ())))) (fail))) (fail))) (fail)) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1657) (let Result (if (cons? (hd V1657)) (let Parse_X (hd (hd V1657)) (if (variable? Parse_X) (shen.pair (hd (shen.pair (tl (hd V1657)) (shen.hdtl V1657))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1711) (let Result (if (cons? (hd V1711)) (let Parse_X (hd (hd V1711)) (if (variable? Parse_X) (shen.pair (hd (shen.pair (tl (hd V1711)) (shen.hdtl V1711))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1662) (let Result (if (cons? (hd V1662)) (let Parse_X (hd (hd V1662)) (if (not (or (element? Parse_X (cons >> (cons ; ()))) (or (shen.singleunderline? Parse_X) (shen.doubleunderline? Parse_X)))) (shen.pair (hd (shen.pair (tl (hd V1662)) (shen.hdtl V1662))) (shen.remove-bar Parse_X)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1716) (let Result (if (cons? (hd V1716)) (let Parse_X (hd (hd V1716)) (if (not (or (element? Parse_X (cons >> (cons ; ()))) (or (shen.singleunderline? Parse_X) (shen.doubleunderline? Parse_X)))) (shen.pair (hd (shen.pair (tl (hd V1716)) (shen.hdtl V1716))) (shen.remove-bar Parse_X)) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen.remove-bar (V1663) (cond ((and (cons? V1663) (and (cons? (tl V1663)) (and (cons? (tl (tl V1663))) (and (= () (tl (tl (tl V1663)))) (= (hd (tl V1663)) bar!))))) (cons (hd V1663) (hd (tl (tl V1663))))) ((cons? V1663) (cons (shen.remove-bar (hd V1663)) (shen.remove-bar (tl V1663)))) (true V1663))) +(defun shen.remove-bar (V1717) (cond ((and (cons? V1717) (and (cons? (tl V1717)) (and (cons? (tl (tl V1717))) (and (= () (tl (tl (tl V1717)))) (= (hd (tl V1717)) bar!))))) (cons (hd V1717) (hd (tl (tl V1717))))) ((cons? V1717) (cons (shen.remove-bar (hd V1717)) (shen.remove-bar (tl V1717)))) (true V1717))) -(defun shen. (V1668) (let Result (let Parse_shen. (shen. V1668) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1668) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1722) (let Result (let Parse_shen. (shen. V1722) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1722) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1673) (let Result (if (cons? (hd V1673)) (let Parse_X (hd (hd V1673)) (if (= Parse_X ;) (shen.pair (hd (shen.pair (tl (hd V1673)) (shen.hdtl V1673))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1727) (let Result (if (cons? (hd V1727)) (let Parse_X (hd (hd V1727)) (if (= Parse_X ;) (shen.pair (hd (shen.pair (tl (hd V1727)) (shen.hdtl V1727))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1678) (let Result (if (and (cons? (hd V1678)) (= ! (hd (hd V1678)))) (shen.pair (hd (shen.pair (tl (hd V1678)) (shen.hdtl V1678))) !) (fail)) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1678) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= >> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1678) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent () (shen.hdtl Parse_shen.))) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result))) +(defun shen. (V1732) (let Result (if (and (cons? (hd V1732)) (= ! (hd (hd V1732)))) (shen.pair (hd (shen.pair (tl (hd V1732)) (shen.hdtl V1732))) !) (fail)) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1732) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= >> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1732) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent () (shen.hdtl Parse_shen.))) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result))) -(defun shen. (V1683) (let Result (let Parse_shen. (shen. V1683) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= >> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1683) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent () (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1737) (let Result (let Parse_shen. (shen. V1737) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= >> (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1737) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.sequent () (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen.sequent (V1684 V1685) (@p V1684 V1685)) +(defun shen.sequent (V1738 V1739) (@p V1738 V1739)) -(defun shen. (V1690) (let Result (let Parse_shen. (shen. V1690) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1690) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) ())) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1690) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result))) +(defun shen. (V1744) (let Result (let Parse_shen. (shen. V1744) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1744) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) ())) (fail))) (if (= Result (fail)) (let Result (let Parse_ ( V1744) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) ()) (fail))) (if (= Result (fail)) (fail) Result)) Result)) Result))) -(defun shen. (V1695) (let Result (if (cons? (hd V1695)) (let Parse_X (hd (hd V1695)) (if (= Parse_X (intern ",")) (shen.pair (hd (shen.pair (tl (hd V1695)) (shen.hdtl V1695))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1749) (let Result (if (cons? (hd V1749)) (let Parse_X (hd (hd V1749)) (if (= Parse_X (intern ",")) (shen.pair (hd (shen.pair (tl (hd V1749)) (shen.hdtl V1749))) shen.skip) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1700) (let Result (let Parse_shen. (shen. V1700) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= : (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.curry (shen.hdtl Parse_shen.)) (cons : (cons (shen.demodulate (shen.hdtl Parse_shen.)) ())))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1700) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result)) Result))) +(defun shen. (V1754) (let Result (let Parse_shen. (shen. V1754) (if (not (= (fail) Parse_shen.)) (if (and (cons? (hd Parse_shen.)) (= : (hd (hd Parse_shen.)))) (let Parse_shen. (shen. (shen.pair (tl (hd Parse_shen.)) (shen.hdtl Parse_shen.))) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.curry (shen.hdtl Parse_shen.)) (cons : (cons (shen.demodulate (shen.hdtl Parse_shen.)) ())))) (fail))) (fail)) (fail))) (if (= Result (fail)) (let Result (let Parse_shen. (shen. V1754) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.hdtl Parse_shen.)) (fail))) (if (= Result (fail)) (fail) Result)) Result))) -(defun shen. (V1705) (let Result (let Parse_shen. (shen. V1705) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.curry-type (shen.hdtl Parse_shen.))) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1759) (let Result (let Parse_shen. (shen. V1759) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (shen.curry-type (shen.hdtl Parse_shen.))) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1710) (let Result (if (cons? (hd V1710)) (let Parse_X (hd (hd V1710)) (if (shen.doubleunderline? Parse_X) (shen.pair (hd (shen.pair (tl (hd V1710)) (shen.hdtl V1710))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1764) (let Result (if (cons? (hd V1764)) (let Parse_X (hd (hd V1764)) (if (shen.doubleunderline? Parse_X) (shen.pair (hd (shen.pair (tl (hd V1764)) (shen.hdtl V1764))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen. (V1715) (let Result (if (cons? (hd V1715)) (let Parse_X (hd (hd V1715)) (if (shen.singleunderline? Parse_X) (shen.pair (hd (shen.pair (tl (hd V1715)) (shen.hdtl V1715))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) +(defun shen. (V1769) (let Result (if (cons? (hd V1769)) (let Parse_X (hd (hd V1769)) (if (shen.singleunderline? Parse_X) (shen.pair (hd (shen.pair (tl (hd V1769)) (shen.hdtl V1769))) Parse_X) (fail))) (fail)) (if (= Result (fail)) (fail) Result))) -(defun shen.singleunderline? (V1716) (and (symbol? V1716) (shen.sh? (str V1716)))) +(defun shen.singleunderline? (V1770) (and (symbol? V1770) (shen.sh? (str V1770)))) -(defun shen.sh? (V1717) (cond ((= "_" V1717) true) (true (and (= (pos V1717 0) "_") (shen.sh? (tlstr V1717)))))) +(defun shen.sh? (V1771) (cond ((= "_" V1771) true) (true (and (= (pos V1771 0) "_") (shen.sh? (tlstr V1771)))))) -(defun shen.doubleunderline? (V1718) (and (symbol? V1718) (shen.dh? (str V1718)))) +(defun shen.doubleunderline? (V1772) (and (symbol? V1772) (shen.dh? (str V1772)))) -(defun shen.dh? (V1719) (cond ((= "=" V1719) true) (true (and (= (pos V1719 0) "=") (shen.dh? (tlstr V1719)))))) +(defun shen.dh? (V1773) (cond ((= "=" V1773) true) (true (and (= (pos V1773 0) "=") (shen.dh? (tlstr V1773)))))) -(defun shen.process-datatype (V1720 V1721) (shen.remember-datatype (shen.s-prolog (shen.rules->horn-clauses V1720 V1721)))) +(defun shen.process-datatype (V1774 V1775) (shen.remember-datatype (shen.s-prolog (shen.rules->horn-clauses V1774 V1775)))) -(defun shen.remember-datatype (V1726) (cond ((cons? V1726) (do (set shen.*datatypes* (adjoin (hd V1726) (value shen.*datatypes*))) (do (set shen.*alldatatypes* (adjoin (hd V1726) (value shen.*alldatatypes*))) (hd V1726)))) (true (shen.sys-error shen.remember-datatype)))) +(defun shen.remember-datatype (V1780) (cond ((cons? V1780) (do (set shen.*datatypes* (adjoin (hd V1780) (value shen.*datatypes*))) (do (set shen.*alldatatypes* (adjoin (hd V1780) (value shen.*alldatatypes*))) (hd V1780)))) (true (shen.sys-error shen.remember-datatype)))) -(defun shen.rules->horn-clauses (V1729 V1730) (cond ((= () V1730) ()) ((and (cons? V1730) (and (tuple? (hd V1730)) (= shen.single (fst (hd V1730))))) (cons (shen.rule->horn-clause V1729 (snd (hd V1730))) (shen.rules->horn-clauses V1729 (tl V1730)))) ((and (cons? V1730) (and (tuple? (hd V1730)) (= shen.double (fst (hd V1730))))) (shen.rules->horn-clauses V1729 (append (shen.double->singles (snd (hd V1730))) (tl V1730)))) (true (shen.sys-error shen.rules->horn-clauses)))) +(defun shen.rules->horn-clauses (V1783 V1784) (cond ((= () V1784) ()) ((and (cons? V1784) (and (tuple? (hd V1784)) (= shen.single (fst (hd V1784))))) (cons (shen.rule->horn-clause V1783 (snd (hd V1784))) (shen.rules->horn-clauses V1783 (tl V1784)))) ((and (cons? V1784) (and (tuple? (hd V1784)) (= shen.double (fst (hd V1784))))) (shen.rules->horn-clauses V1783 (append (shen.double->singles (snd (hd V1784))) (tl V1784)))) (true (shen.sys-error shen.rules->horn-clauses)))) -(defun shen.double->singles (V1731) (cons (shen.right-rule V1731) (cons (shen.left-rule V1731) ()))) +(defun shen.double->singles (V1785) (cons (shen.right-rule V1785) (cons (shen.left-rule V1785) ()))) -(defun shen.right-rule (V1732) (@p shen.single V1732)) +(defun shen.right-rule (V1786) (@p shen.single V1786)) -(defun shen.left-rule (V1733) (cond ((and (cons? V1733) (and (cons? (tl V1733)) (and (cons? (tl (tl V1733))) (and (tuple? (hd (tl (tl V1733)))) (and (= () (fst (hd (tl (tl V1733))))) (= () (tl (tl (tl V1733))))))))) (let Q (gensym Qv) (let NewConclusion (@p (cons (snd (hd (tl (tl V1733)))) ()) Q) (let NewPremises (cons (@p (map shen.right->left (hd (tl V1733))) Q) ()) (@p shen.single (cons (hd V1733) (cons NewPremises (cons NewConclusion ())))))))) (true (shen.sys-error shen.left-rule)))) +(defun shen.left-rule (V1787) (cond ((and (cons? V1787) (and (cons? (tl V1787)) (and (cons? (tl (tl V1787))) (and (tuple? (hd (tl (tl V1787)))) (and (= () (fst (hd (tl (tl V1787))))) (= () (tl (tl (tl V1787))))))))) (let Q (gensym Qv) (let NewConclusion (@p (cons (snd (hd (tl (tl V1787)))) ()) Q) (let NewPremises (cons (@p (map (lambda X1675 (shen.right->left X1675)) (hd (tl V1787))) Q) ()) (@p shen.single (cons (hd V1787) (cons NewPremises (cons NewConclusion ())))))))) (true (shen.sys-error shen.left-rule)))) -(defun shen.right->left (V1738) (cond ((and (tuple? V1738) (= () (fst V1738))) (snd V1738)) (true (simple-error "syntax error with ========== +(defun shen.right->left (V1792) (cond ((and (tuple? V1792) (= () (fst V1792))) (snd V1792)) (true (simple-error "syntax error with ========== ")))) -(defun shen.rule->horn-clause (V1739 V1740) (cond ((and (cons? V1740) (and (cons? (tl V1740)) (and (cons? (tl (tl V1740))) (and (tuple? (hd (tl (tl V1740)))) (= () (tl (tl (tl V1740)))))))) (cons (shen.rule->horn-clause-head V1739 (snd (hd (tl (tl V1740))))) (cons :- (cons (shen.rule->horn-clause-body (hd V1740) (hd (tl V1740)) (fst (hd (tl (tl V1740))))) ())))) (true (shen.sys-error shen.rule->horn-clause)))) +(defun shen.rule->horn-clause (V1793 V1794) (cond ((and (cons? V1794) (and (cons? (tl V1794)) (and (cons? (tl (tl V1794))) (and (tuple? (hd (tl (tl V1794)))) (= () (tl (tl (tl V1794)))))))) (cons (shen.rule->horn-clause-head V1793 (snd (hd (tl (tl V1794))))) (cons :- (cons (shen.rule->horn-clause-body (hd V1794) (hd (tl V1794)) (fst (hd (tl (tl V1794))))) ())))) (true (shen.sys-error shen.rule->horn-clause)))) -(defun shen.rule->horn-clause-head (V1741 V1742) (cons V1741 (cons (shen.mode-ify V1742) (cons Context_1957 ())))) +(defun shen.rule->horn-clause-head (V1795 V1796) (cons V1795 (cons (shen.mode-ify V1796) (cons Context_1957 ())))) -(defun shen.mode-ify (V1743) (cond ((and (cons? V1743) (and (cons? (tl V1743)) (and (= : (hd (tl V1743))) (and (cons? (tl (tl V1743))) (= () (tl (tl (tl V1743)))))))) (cons mode (cons (cons (hd V1743) (cons : (cons (cons mode (cons (hd (tl (tl V1743))) (cons + ()))) ()))) (cons - ())))) (true V1743))) +(defun shen.mode-ify (V1797) (cond ((and (cons? V1797) (and (cons? (tl V1797)) (and (= : (hd (tl V1797))) (and (cons? (tl (tl V1797))) (= () (tl (tl (tl V1797)))))))) (cons mode (cons (cons (hd V1797) (cons : (cons (cons mode (cons (hd (tl (tl V1797))) (cons + ()))) ()))) (cons - ())))) (true V1797))) -(defun shen.rule->horn-clause-body (V1744 V1745 V1746) (let Variables (map shen.extract_vars V1746) (let Predicates (map (lambda X (gensym shen.cl)) V1746) (let SearchLiterals (shen.construct-search-literals Predicates Variables Context_1957 Context1_1957) (let SearchClauses (shen.construct-search-clauses Predicates V1746 Variables) (let SideLiterals (shen.construct-side-literals V1744) (let PremissLiterals (map (lambda X (shen.construct-premiss-literal X (empty? V1746))) V1745) (append SearchLiterals (append SideLiterals PremissLiterals))))))))) +(defun shen.rule->horn-clause-body (V1798 V1799 V1800) (let Variables (map (lambda X1676 (shen.extract_vars X1676)) V1800) (let Predicates (map (lambda X (gensym shen.cl)) V1800) (let SearchLiterals (shen.construct-search-literals Predicates Variables Context_1957 Context1_1957) (let SearchClauses (shen.construct-search-clauses Predicates V1800 Variables) (let SideLiterals (shen.construct-side-literals V1798) (let PremissLiterals (map (lambda X (shen.construct-premiss-literal X (empty? V1800))) V1799) (append SearchLiterals (append SideLiterals PremissLiterals))))))))) -(defun shen.construct-search-literals (V1751 V1752 V1753 V1754) (cond ((and (= () V1751) (= () V1752)) ()) (true (shen.csl-help V1751 V1752 V1753 V1754)))) +(defun shen.construct-search-literals (V1805 V1806 V1807 V1808) (cond ((and (= () V1805) (= () V1806)) ()) (true (shen.csl-help V1805 V1806 V1807 V1808)))) -(defun shen.csl-help (V1757 V1758 V1759 V1760) (cond ((and (= () V1757) (= () V1758)) (cons (cons bind (cons ContextOut_1957 (cons V1759 ()))) ())) ((and (cons? V1757) (cons? V1758)) (cons (cons (hd V1757) (cons V1759 (cons V1760 (hd V1758)))) (shen.csl-help (tl V1757) (tl V1758) V1760 (gensym Context)))) (true (shen.sys-error shen.csl-help)))) +(defun shen.csl-help (V1811 V1812 V1813 V1814) (cond ((and (= () V1811) (= () V1812)) (cons (cons bind (cons ContextOut_1957 (cons V1813 ()))) ())) ((and (cons? V1811) (cons? V1812)) (cons (cons (hd V1811) (cons V1813 (cons V1814 (hd V1812)))) (shen.csl-help (tl V1811) (tl V1812) V1814 (gensym Context)))) (true (shen.sys-error shen.csl-help)))) -(defun shen.construct-search-clauses (V1761 V1762 V1763) (cond ((and (= () V1761) (and (= () V1762) (= () V1763))) shen.skip) ((and (cons? V1761) (and (cons? V1762) (cons? V1763))) (do (shen.construct-search-clause (hd V1761) (hd V1762) (hd V1763)) (shen.construct-search-clauses (tl V1761) (tl V1762) (tl V1763)))) (true (shen.sys-error shen.construct-search-clauses)))) +(defun shen.construct-search-clauses (V1815 V1816 V1817) (cond ((and (= () V1815) (and (= () V1816) (= () V1817))) shen.skip) ((and (cons? V1815) (and (cons? V1816) (cons? V1817))) (do (shen.construct-search-clause (hd V1815) (hd V1816) (hd V1817)) (shen.construct-search-clauses (tl V1815) (tl V1816) (tl V1817)))) (true (shen.sys-error shen.construct-search-clauses)))) -(defun shen.construct-search-clause (V1764 V1765 V1766) (shen.s-prolog (cons (shen.construct-base-search-clause V1764 V1765 V1766) (cons (shen.construct-recursive-search-clause V1764 V1765 V1766) ())))) +(defun shen.construct-search-clause (V1818 V1819 V1820) (shen.s-prolog (cons (shen.construct-base-search-clause V1818 V1819 V1820) (cons (shen.construct-recursive-search-clause V1818 V1819 V1820) ())))) -(defun shen.construct-base-search-clause (V1767 V1768 V1769) (cons (cons V1767 (cons (cons (shen.mode-ify V1768) In_1957) (cons In_1957 V1769))) (cons :- (cons () ())))) +(defun shen.construct-base-search-clause (V1821 V1822 V1823) (cons (cons V1821 (cons (cons (shen.mode-ify V1822) In_1957) (cons In_1957 V1823))) (cons :- (cons () ())))) -(defun shen.construct-recursive-search-clause (V1770 V1771 V1772) (cons (cons V1770 (cons (cons Assumption_1957 Assumptions_1957) (cons (cons Assumption_1957 Out_1957) V1772))) (cons :- (cons (cons (cons V1770 (cons Assumptions_1957 (cons Out_1957 V1772))) ()) ())))) +(defun shen.construct-recursive-search-clause (V1824 V1825 V1826) (cons (cons V1824 (cons (cons Assumption_1957 Assumptions_1957) (cons (cons Assumption_1957 Out_1957) V1826))) (cons :- (cons (cons (cons V1824 (cons Assumptions_1957 (cons Out_1957 V1826))) ()) ())))) -(defun shen.construct-side-literals (V1777) (cond ((= () V1777) ()) ((and (cons? V1777) (and (cons? (hd V1777)) (and (= if (hd (hd V1777))) (and (cons? (tl (hd V1777))) (= () (tl (tl (hd V1777)))))))) (cons (cons when (tl (hd V1777))) (shen.construct-side-literals (tl V1777)))) ((and (cons? V1777) (and (cons? (hd V1777)) (and (= let (hd (hd V1777))) (and (cons? (tl (hd V1777))) (and (cons? (tl (tl (hd V1777)))) (= () (tl (tl (tl (hd V1777)))))))))) (cons (cons is (tl (hd V1777))) (shen.construct-side-literals (tl V1777)))) ((cons? V1777) (shen.construct-side-literals (tl V1777))) (true (shen.sys-error shen.construct-side-literals)))) +(defun shen.construct-side-literals (V1831) (cond ((= () V1831) ()) ((and (cons? V1831) (and (cons? (hd V1831)) (and (= if (hd (hd V1831))) (and (cons? (tl (hd V1831))) (= () (tl (tl (hd V1831)))))))) (cons (cons when (tl (hd V1831))) (shen.construct-side-literals (tl V1831)))) ((and (cons? V1831) (and (cons? (hd V1831)) (and (= let (hd (hd V1831))) (and (cons? (tl (hd V1831))) (and (cons? (tl (tl (hd V1831)))) (= () (tl (tl (tl (hd V1831)))))))))) (cons (cons is (tl (hd V1831))) (shen.construct-side-literals (tl V1831)))) ((cons? V1831) (shen.construct-side-literals (tl V1831))) (true (shen.sys-error shen.construct-side-literals)))) -(defun shen.construct-premiss-literal (V1782 V1783) (cond ((tuple? V1782) (cons shen.t* (cons (shen.recursive_cons_form (snd V1782)) (cons (shen.construct-context V1783 (fst V1782)) ())))) ((= ! V1782) (cons cut (cons Throwcontrol ()))) (true (shen.sys-error shen.construct-premiss-literal)))) +(defun shen.construct-premiss-literal (V1836 V1837) (cond ((tuple? V1836) (cons shen.t* (cons (shen.recursive_cons_form (snd V1836)) (cons (shen.construct-context V1837 (fst V1836)) ())))) ((= ! V1836) (cons cut (cons Throwcontrol ()))) (true (shen.sys-error shen.construct-premiss-literal)))) -(defun shen.construct-context (V1784 V1785) (cond ((and (= true V1784) (= () V1785)) Context_1957) ((and (= false V1784) (= () V1785)) ContextOut_1957) ((cons? V1785) (cons cons (cons (shen.recursive_cons_form (hd V1785)) (cons (shen.construct-context V1784 (tl V1785)) ())))) (true (shen.sys-error shen.construct-context)))) +(defun shen.construct-context (V1838 V1839) (cond ((and (= true V1838) (= () V1839)) Context_1957) ((and (= false V1838) (= () V1839)) ContextOut_1957) ((cons? V1839) (cons cons (cons (shen.recursive_cons_form (hd V1839)) (cons (shen.construct-context V1838 (tl V1839)) ())))) (true (shen.sys-error shen.construct-context)))) -(defun shen.recursive_cons_form (V1786) (cond ((cons? V1786) (cons cons (cons (shen.recursive_cons_form (hd V1786)) (cons (shen.recursive_cons_form (tl V1786)) ())))) (true V1786))) +(defun shen.recursive_cons_form (V1840) (cond ((cons? V1840) (cons cons (cons (shen.recursive_cons_form (hd V1840)) (cons (shen.recursive_cons_form (tl V1840)) ())))) (true V1840))) -(defun preclude (V1787) (shen.preclude-h (map shen.intern-type V1787))) +(defun preclude (V1841) (shen.preclude-h (map (lambda X1677 (shen.intern-type X1677)) V1841))) -(defun shen.preclude-h (V1788) (let FilterDatatypes (set shen.*datatypes* (difference (value shen.*datatypes*) V1788)) (value shen.*datatypes*))) +(defun shen.preclude-h (V1842) (let FilterDatatypes (set shen.*datatypes* (difference (value shen.*datatypes*) V1842)) (value shen.*datatypes*))) -(defun include (V1789) (shen.include-h (map shen.intern-type V1789))) +(defun include (V1843) (shen.include-h (map (lambda X1678 (shen.intern-type X1678)) V1843))) -(defun shen.include-h (V1790) (let ValidTypes (intersection V1790 (value shen.*alldatatypes*)) (let NewDatatypes (set shen.*datatypes* (union ValidTypes (value shen.*datatypes*))) (value shen.*datatypes*)))) +(defun shen.include-h (V1844) (let ValidTypes (intersection V1844 (value shen.*alldatatypes*)) (let NewDatatypes (set shen.*datatypes* (union ValidTypes (value shen.*datatypes*))) (value shen.*datatypes*)))) -(defun preclude-all-but (V1791) (shen.preclude-h (difference (value shen.*alldatatypes*) (map shen.intern-type V1791)))) +(defun preclude-all-but (V1845) (shen.preclude-h (difference (value shen.*alldatatypes*) (map (lambda X1679 (shen.intern-type X1679)) V1845)))) -(defun include-all-but (V1792) (shen.include-h (difference (value shen.*alldatatypes*) (map shen.intern-type V1792)))) +(defun include-all-but (V1846) (shen.include-h (difference (value shen.*alldatatypes*) (map (lambda X1680 (shen.intern-type X1680)) V1846)))) -(defun shen.synonyms-help (V1797) (cond ((= () V1797) synonyms) ((and (cons? V1797) (cons? (tl V1797))) (do (shen.pushnew (cons (hd V1797) (shen.curry-type (hd (tl V1797)))) shen.*synonyms*) (shen.synonyms-help (tl (tl V1797))))) (true (simple-error (cn "odd number of synonyms -" ""))))) +(defun shen.synonyms-help (V1851) (cond ((= () V1851) (shen.demodulation-function (value shen.*tc*) (mapcan (lambda X1681 (shen.demod-rule X1681)) (value shen.*synonyms*)))) ((and (cons? V1851) (cons? (tl V1851))) (let Vs (difference (shen.extract_vars (hd (tl V1851))) (shen.extract_vars (hd V1851))) (if (empty? Vs) (do (shen.pushnew (cons (hd V1851) (cons (hd (tl V1851)) ())) shen.*synonyms*) (shen.synonyms-help (tl (tl V1851)))) (shen.free_variable_warnings (hd (tl V1851)) Vs)))) (true (simple-error "odd number of synonyms +")))) + +(defun shen.pushnew (V1852 V1853) (if (element? V1852 (value V1853)) (value V1853) (set V1853 (cons V1852 (value V1853))))) + +(defun shen.demod-rule (V1854) (cond ((and (cons? V1854) (and (cons? (tl V1854)) (= () (tl (tl V1854))))) (cons (shen.rcons_form (hd V1854)) (cons -> (cons (shen.rcons_form (hd (tl V1854))) ())))) (true (shen.sys-error shen.demod-rule)))) + +(defun shen.demodulation-function (V1855 V1856) (do (tc -) (do (eval (cons define (cons shen.demod (append V1856 (shen.default-rule))))) (do (if V1855 (tc +) shen.skip) synonyms)))) -(defun shen.pushnew (V1798 V1799) (if (element? V1798 (value V1799)) (value V1799) (set V1799 (cons V1798 (value V1799))))) +(defun shen.default-rule () (cons X (cons -> (cons X ())))) diff --git a/shen/klambda/sys.kl b/shen/klambda/sys.kl index 6803e1f..a3a64cb 100644 --- a/shen/klambda/sys.kl +++ b/shen/klambda/sys.kl @@ -47,211 +47,225 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun thaw (V1802) (V1802)) +"(defun thaw (V1862) (V1862)) -(defun eval (V1803) (let Macroexpand (shen.walk (lambda V1800 (macroexpand V1800)) V1803) (if (shen.packaged? Macroexpand) (map shen.eval-without-macros (shen.package-contents Macroexpand)) (shen.eval-without-macros Macroexpand)))) +(defun eval (V1863) (let Macroexpand (shen.walk (lambda X1857 (macroexpand X1857)) V1863) (if (shen.packaged? Macroexpand) (map (lambda X1858 (shen.eval-without-macros X1858)) (shen.package-contents Macroexpand)) (shen.eval-without-macros Macroexpand)))) -(defun shen.eval-without-macros (V1804) (eval-kl (shen.elim-def (shen.proc-input+ V1804)))) +(defun shen.eval-without-macros (V1864) (eval-kl (shen.elim-def (shen.proc-input+ V1864)))) -(defun shen.proc-input+ (V1805) (cond ((and (cons? V1805) (and (= input+ (hd V1805)) (and (cons? (tl V1805)) (and (cons? (tl (tl V1805))) (= () (tl (tl (tl V1805)))))))) (cons input+ (cons (shen.rcons_form (hd (tl V1805))) (tl (tl V1805))))) ((and (cons? V1805) (and (= read+ (hd V1805)) (and (cons? (tl V1805)) (and (cons? (tl (tl V1805))) (= () (tl (tl (tl V1805)))))))) (cons read+ (cons (shen.rcons_form (hd (tl V1805))) (tl (tl V1805))))) ((cons? V1805) (map shen.proc-input+ V1805)) (true V1805))) +(defun shen.proc-input+ (V1865) (cond ((and (cons? V1865) (and (= input+ (hd V1865)) (and (cons? (tl V1865)) (and (cons? (tl (tl V1865))) (= () (tl (tl (tl V1865)))))))) (cons input+ (cons (shen.rcons_form (hd (tl V1865))) (tl (tl V1865))))) ((and (cons? V1865) (and (= read+ (hd V1865)) (and (cons? (tl V1865)) (and (cons? (tl (tl V1865))) (= () (tl (tl (tl V1865)))))))) (cons read+ (cons (shen.rcons_form (hd (tl V1865))) (tl (tl V1865))))) ((cons? V1865) (map (lambda X1859 (shen.proc-input+ X1859)) V1865)) (true V1865))) -(defun shen.elim-def (V1806) (cond ((and (cons? V1806) (and (= define (hd V1806)) (cons? (tl V1806)))) (shen.shen->kl (hd (tl V1806)) (tl (tl V1806)))) ((and (cons? V1806) (and (= defmacro (hd V1806)) (cons? (tl V1806)))) (let Default (cons X (cons -> (cons X ()))) (let Def (shen.elim-def (cons define (cons (hd (tl V1806)) (append (tl (tl V1806)) Default)))) (let MacroAdd (shen.add-macro (hd (tl V1806))) Def)))) ((and (cons? V1806) (and (= defcc (hd V1806)) (cons? (tl V1806)))) (shen.elim-def (shen.yacc V1806))) ((cons? V1806) (map shen.elim-def V1806)) (true V1806))) +(defun shen.elim-def (V1866) (cond ((and (cons? V1866) (and (= define (hd V1866)) (cons? (tl V1866)))) (shen.shen->kl (hd (tl V1866)) (tl (tl V1866)))) ((and (cons? V1866) (and (= defmacro (hd V1866)) (cons? (tl V1866)))) (let Default (cons X (cons -> (cons X ()))) (let Def (shen.elim-def (cons define (cons (hd (tl V1866)) (append (tl (tl V1866)) Default)))) (let MacroAdd (shen.add-macro (hd (tl V1866))) Def)))) ((and (cons? V1866) (and (= defcc (hd V1866)) (cons? (tl V1866)))) (shen.elim-def (shen.yacc V1866))) ((cons? V1866) (map (lambda X1860 (shen.elim-def X1860)) V1866)) (true V1866))) -(defun shen.add-macro (V1807) (set *macros* (adjoin V1807 (value *macros*)))) +(defun shen.add-macro (V1867) (set *macros* (adjoin V1867 (value *macros*)))) -(defun shen.packaged? (V1814) (cond ((and (cons? V1814) (and (= package (hd V1814)) (and (cons? (tl V1814)) (cons? (tl (tl V1814)))))) true) (true false))) +(defun shen.packaged? (V1874) (cond ((and (cons? V1874) (and (= package (hd V1874)) (and (cons? (tl V1874)) (cons? (tl (tl V1874)))))) true) (true false))) -(defun external (V1815) (trap-error (get V1815 shen.external-symbols (value *property-vector*)) (lambda E (simple-error (cn "package " (shen.app V1815 " has not been used. +(defun external (V1875) (trap-error (get V1875 shen.external-symbols (value *property-vector*)) (lambda E (simple-error (cn "package " (shen.app V1875 " has not been used. " shen.a)))))) -(defun shen.package-contents (V1818) (cond ((and (cons? V1818) (and (= package (hd V1818)) (and (cons? (tl V1818)) (and (= null (hd (tl V1818))) (cons? (tl (tl V1818))))))) (tl (tl (tl V1818)))) ((and (cons? V1818) (and (= package (hd V1818)) (and (cons? (tl V1818)) (cons? (tl (tl V1818)))))) (shen.packageh (hd (tl V1818)) (hd (tl (tl V1818))) (tl (tl (tl V1818))))) (true (shen.sys-error shen.package-contents)))) +(defun shen.package-contents (V1878) (cond ((and (cons? V1878) (and (= package (hd V1878)) (and (cons? (tl V1878)) (and (= null (hd (tl V1878))) (cons? (tl (tl V1878))))))) (tl (tl (tl V1878)))) ((and (cons? V1878) (and (= package (hd V1878)) (and (cons? (tl V1878)) (cons? (tl (tl V1878)))))) (shen.packageh (hd (tl V1878)) (hd (tl (tl V1878))) (tl (tl (tl V1878))))) (true (shen.sys-error shen.package-contents)))) -(defun shen.walk (V1819 V1820) (cond ((cons? V1820) (V1819 (map (lambda Z (shen.walk V1819 Z)) V1820))) (true (V1819 V1820)))) +(defun shen.walk (V1879 V1880) (cond ((cons? V1880) (V1879 (map (lambda Z (shen.walk V1879 Z)) V1880))) (true (V1879 V1880)))) -(defun compile (V1821 V1822 V1823) (let O (V1821 (cons V1822 (cons () ()))) (if (or (= (fail) O) (not (empty? (hd O)))) (V1823 O) (shen.hdtl O)))) +(defun compile (V1881 V1882 V1883) (let O (V1881 (cons V1882 (cons () ()))) (if (or (= (fail) O) (not (empty? (hd O)))) (V1883 O) (shen.hdtl O)))) -(defun fail-if (V1824 V1825) (if (V1824 V1825) (fail) V1825)) +(defun fail-if (V1884 V1885) (if (V1884 V1885) (fail) V1885)) -(defun @s (V1826 V1827) (cn V1826 V1827)) +(defun @s (V1886 V1887) (cn V1886 V1887)) (defun tc? () (value shen.*tc*)) -(defun ps (V1828) (trap-error (get V1828 shen.source (value *property-vector*)) (lambda E (simple-error (shen.app V1828 " not found. +(defun ps (V1888) (trap-error (get V1888 shen.source (value *property-vector*)) (lambda E (simple-error (shen.app V1888 " not found. " shen.a))))) (defun stinput () (value *stinput*)) -(defun shen.+vector? (V1829) (and (absvector? V1829) (> (<-address V1829 0) 0))) +(defun shen.+vector? (V1889) (and (absvector? V1889) (> (<-address V1889 0) 0))) -(defun vector (V1830) (let Vector (absvector (+ V1830 1)) (let ZeroStamp (address-> Vector 0 V1830) (let Standard (if (= V1830 0) ZeroStamp (shen.fillvector ZeroStamp 1 V1830 (fail))) Standard)))) +(defun vector (V1890) (let Vector (absvector (+ V1890 1)) (let ZeroStamp (address-> Vector 0 V1890) (let Standard (if (= V1890 0) ZeroStamp (shen.fillvector ZeroStamp 1 V1890 (fail))) Standard)))) -(defun shen.fillvector (V1831 V1832 V1833 V1834) (cond ((= V1833 V1832) (address-> V1831 V1833 V1834)) (true (shen.fillvector (address-> V1831 V1832 V1834) (+ 1 V1832) V1833 V1834)))) +(defun shen.fillvector (V1891 V1892 V1893 V1894) (cond ((= V1893 V1892) (address-> V1891 V1893 V1894)) (true (shen.fillvector (address-> V1891 V1892 V1894) (+ 1 V1892) V1893 V1894)))) -(defun vector? (V1836) (and (absvector? V1836) (trap-error (>= (<-address V1836 0) 0) (lambda E false)))) +(defun vector? (V1896) (and (absvector? V1896) (trap-error (>= (<-address V1896 0) 0) (lambda E false)))) -(defun vector-> (V1837 V1838 V1839) (if (= V1838 0) (simple-error "cannot access 0th element of a vector -") (address-> V1837 V1838 V1839))) +(defun vector-> (V1897 V1898 V1899) (if (= V1898 0) (simple-error "cannot access 0th element of a vector +") (address-> V1897 V1898 V1899))) -(defun <-vector (V1840 V1841) (if (= V1841 0) (simple-error "cannot access 0th element of a vector -") (let VectorElement (<-address V1840 V1841) (if (= VectorElement (fail)) (simple-error "vector element not found +(defun <-vector (V1900 V1901) (if (= V1901 0) (simple-error "cannot access 0th element of a vector +") (let VectorElement (<-address V1900 V1901) (if (= VectorElement (fail)) (simple-error "vector element not found ") VectorElement)))) -(defun shen.posint? (V1842) (and (integer? V1842) (>= V1842 0))) +(defun shen.posint? (V1902) (and (integer? V1902) (>= V1902 0))) -(defun limit (V1843) (<-address V1843 0)) +(defun limit (V1903) (<-address V1903 0)) -(defun symbol? (V1844) (cond ((or (boolean? V1844) (or (number? V1844) (string? V1844))) false) (true (trap-error (let String (str V1844) (shen.analyse-symbol? String)) (lambda E false))))) +(defun symbol? (V1904) (cond ((or (boolean? V1904) (or (number? V1904) (string? V1904))) false) (true (trap-error (let String (str V1904) (shen.analyse-symbol? String)) (lambda E false))))) -(defun shen.analyse-symbol? (V1845) (cond ((shen.+string? V1845) (and (shen.alpha? (pos V1845 0)) (shen.alphanums? (tlstr V1845)))) (true (shen.sys-error shen.analyse-symbol?)))) +(defun shen.analyse-symbol? (V1905) (cond ((shen.+string? V1905) (and (shen.alpha? (pos V1905 0)) (shen.alphanums? (tlstr V1905)))) (true (shen.sys-error shen.analyse-symbol?)))) -(defun shen.alpha? (V1846) (element? V1846 (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" (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" (cons "=" (cons "*" (cons "/" (cons "+" (cons "-" (cons "_" (cons "?" (cons "$" (cons "!" (cons "@" (cons "~" (cons ">" (cons "<" (cons "&" (cons "%" (cons "{" (cons "}" (cons ":" (cons ";" (cons "`" (cons "#" (cons "'" (cons "." ()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) +(defun shen.alpha? (V1906) (element? V1906 (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" (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" (cons "=" (cons "*" (cons "/" (cons "+" (cons "-" (cons "_" (cons "?" (cons "$" (cons "!" (cons "@" (cons "~" (cons ">" (cons "<" (cons "&" (cons "%" (cons "{" (cons "}" (cons ":" (cons ";" (cons "`" (cons "#" (cons "'" (cons "." ()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) -(defun shen.alphanums? (V1847) (cond ((= "" V1847) true) ((shen.+string? V1847) (and (shen.alphanum? (pos V1847 0)) (shen.alphanums? (tlstr V1847)))) (true (shen.sys-error shen.alphanums?)))) +(defun shen.alphanums? (V1907) (cond ((= "" V1907) true) ((shen.+string? V1907) (and (shen.alphanum? (pos V1907 0)) (shen.alphanums? (tlstr V1907)))) (true (shen.sys-error shen.alphanums?)))) -(defun shen.alphanum? (V1848) (or (shen.alpha? V1848) (shen.digit? V1848))) +(defun shen.alphanum? (V1908) (or (shen.alpha? V1908) (shen.digit? V1908))) -(defun shen.digit? (V1849) (element? V1849 (cons "1" (cons "2" (cons "3" (cons "4" (cons "5" (cons "6" (cons "7" (cons "8" (cons "9" (cons "0" ())))))))))))) +(defun shen.digit? (V1909) (element? V1909 (cons "1" (cons "2" (cons "3" (cons "4" (cons "5" (cons "6" (cons "7" (cons "8" (cons "9" (cons "0" ())))))))))))) -(defun variable? (V1850) (cond ((or (boolean? V1850) (or (number? V1850) (string? V1850))) false) (true (trap-error (let String (str V1850) (shen.analyse-variable? String)) (lambda E false))))) +(defun variable? (V1910) (cond ((or (boolean? V1910) (or (number? V1910) (string? V1910))) false) (true (trap-error (let String (str V1910) (shen.analyse-variable? String)) (lambda E false))))) -(defun shen.analyse-variable? (V1851) (cond ((shen.+string? V1851) (and (shen.uppercase? (pos V1851 0)) (shen.alphanums? (tlstr V1851)))) (true (shen.sys-error shen.analyse-variable?)))) +(defun shen.analyse-variable? (V1911) (cond ((shen.+string? V1911) (and (shen.uppercase? (pos V1911 0)) (shen.alphanums? (tlstr V1911)))) (true (shen.sys-error shen.analyse-variable?)))) -(defun shen.uppercase? (V1852) (element? V1852 (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" ())))))))))))))))))))))))))))) +(defun shen.uppercase? (V1912) (element? V1912 (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" ())))))))))))))))))))))))))))) -(defun gensym (V1853) (concat V1853 (set shen.*gensym* (+ 1 (value shen.*gensym*))))) +(defun gensym (V1913) (concat V1913 (set shen.*gensym* (+ 1 (value shen.*gensym*))))) -(defun concat (V1854 V1855) (intern (cn (str V1854) (str V1855)))) +(defun concat (V1914 V1915) (intern (cn (str V1914) (str V1915)))) -(defun @p (V1856 V1857) (let Vector (absvector 3) (let Tag (address-> Vector 0 shen.tuple) (let Fst (address-> Vector 1 V1856) (let Snd (address-> Vector 2 V1857) Vector))))) +(defun @p (V1916 V1917) (let Vector (absvector 3) (let Tag (address-> Vector 0 shen.tuple) (let Fst (address-> Vector 1 V1916) (let Snd (address-> Vector 2 V1917) Vector))))) -(defun fst (V1858) (<-address V1858 1)) +(defun fst (V1918) (<-address V1918 1)) -(defun snd (V1859) (<-address V1859 2)) +(defun snd (V1919) (<-address V1919 2)) -(defun tuple? (V1860) (trap-error (and (absvector? V1860) (= shen.tuple (<-address V1860 0))) (lambda E false))) +(defun tuple? (V1920) (trap-error (and (absvector? V1920) (= shen.tuple (<-address V1920 0))) (lambda E false))) -(defun append (V1861 V1862) (cond ((= () V1861) V1862) ((cons? V1861) (cons (hd V1861) (append (tl V1861) V1862))) (true (shen.sys-error append)))) +(defun append (V1921 V1922) (cond ((= () V1921) V1922) ((cons? V1921) (cons (hd V1921) (append (tl V1921) V1922))) (true (shen.sys-error append)))) -(defun @v (V1863 V1864) (let Limit (limit V1864) (let NewVector (vector (+ Limit 1)) (let X+NewVector (vector-> NewVector 1 V1863) (if (= Limit 0) X+NewVector (shen.@v-help V1864 1 Limit X+NewVector)))))) +(defun @v (V1923 V1924) (let Limit (limit V1924) (let NewVector (vector (+ Limit 1)) (let X+NewVector (vector-> NewVector 1 V1923) (if (= Limit 0) X+NewVector (shen.@v-help V1924 1 Limit X+NewVector)))))) -(defun shen.@v-help (V1865 V1866 V1867 V1868) (cond ((= V1867 V1866) (shen.copyfromvector V1865 V1868 V1867 (+ V1867 1))) (true (shen.@v-help V1865 (+ V1866 1) V1867 (shen.copyfromvector V1865 V1868 V1866 (+ V1866 1)))))) +(defun shen.@v-help (V1925 V1926 V1927 V1928) (cond ((= V1927 V1926) (shen.copyfromvector V1925 V1928 V1927 (+ V1927 1))) (true (shen.@v-help V1925 (+ V1926 1) V1927 (shen.copyfromvector V1925 V1928 V1926 (+ V1926 1)))))) -(defun shen.copyfromvector (V1870 V1871 V1872 V1873) (trap-error (vector-> V1871 V1873 (<-vector V1870 V1872)) (lambda E V1871))) +(defun shen.copyfromvector (V1930 V1931 V1932 V1933) (trap-error (vector-> V1931 V1933 (<-vector V1930 V1932)) (lambda E V1931))) -(defun hdv (V1874) (trap-error (<-vector V1874 1) (lambda E (simple-error (cn "hdv needs a non-empty vector as an argument; not " (shen.app V1874 " +(defun hdv (V1934) (trap-error (<-vector V1934 1) (lambda E (simple-error (cn "hdv needs a non-empty vector as an argument; not " (shen.app V1934 " " shen.s)))))) -(defun tlv (V1875) (let Limit (limit V1875) (if (= Limit 0) (simple-error "cannot take the tail of the empty vector -") (if (= Limit 1) (vector 0) (let NewVector (vector (- Limit 1)) (shen.tlv-help V1875 2 Limit (vector (- Limit 1)))))))) +(defun tlv (V1935) (let Limit (limit V1935) (if (= Limit 0) (simple-error "cannot take the tail of the empty vector +") (if (= Limit 1) (vector 0) (let NewVector (vector (- Limit 1)) (shen.tlv-help V1935 2 Limit (vector (- Limit 1)))))))) -(defun shen.tlv-help (V1876 V1877 V1878 V1879) (cond ((= V1878 V1877) (shen.copyfromvector V1876 V1879 V1878 (- V1878 1))) (true (shen.tlv-help V1876 (+ V1877 1) V1878 (shen.copyfromvector V1876 V1879 V1877 (- V1877 1)))))) +(defun shen.tlv-help (V1936 V1937 V1938 V1939) (cond ((= V1938 V1937) (shen.copyfromvector V1936 V1939 V1938 (- V1938 1))) (true (shen.tlv-help V1936 (+ V1937 1) V1938 (shen.copyfromvector V1936 V1939 V1937 (- V1937 1)))))) -(defun assoc (V1889 V1890) (cond ((= () V1890) ()) ((and (cons? V1890) (and (cons? (hd V1890)) (= (hd (hd V1890)) V1889))) (hd V1890)) ((cons? V1890) (assoc V1889 (tl V1890))) (true (shen.sys-error assoc)))) +(defun assoc (V1949 V1950) (cond ((= () V1950) ()) ((and (cons? V1950) (and (cons? (hd V1950)) (= (hd (hd V1950)) V1949))) (hd V1950)) ((cons? V1950) (assoc V1949 (tl V1950))) (true (shen.sys-error assoc)))) -(defun boolean? (V1896) (cond ((= true V1896) true) ((= false V1896) true) (true false))) +(defun boolean? (V1956) (cond ((= true V1956) true) ((= false V1956) true) (true false))) -(defun nl (V1897) (cond ((= 0 V1897) 0) (true (do (shen.prhush " -" (stoutput)) (nl (- V1897 1)))))) +(defun nl (V1957) (cond ((= 0 V1957) 0) (true (do (shen.prhush " +" (stoutput)) (nl (- V1957 1)))))) -(defun difference (V1900 V1901) (cond ((= () V1900) ()) ((cons? V1900) (if (element? (hd V1900) V1901) (difference (tl V1900) V1901) (cons (hd V1900) (difference (tl V1900) V1901)))) (true (shen.sys-error difference)))) +(defun difference (V1960 V1961) (cond ((= () V1960) ()) ((cons? V1960) (if (element? (hd V1960) V1961) (difference (tl V1960) V1961) (cons (hd V1960) (difference (tl V1960) V1961)))) (true (shen.sys-error difference)))) -(defun do (V1902 V1903) V1903) +(defun do (V1962 V1963) V1963) -(defun element? (V1912 V1913) (cond ((= () V1913) false) ((and (cons? V1913) (= (hd V1913) V1912)) true) ((cons? V1913) (element? V1912 (tl V1913))) (true (shen.sys-error element?)))) +(defun element? (V1972 V1973) (cond ((= () V1973) false) ((and (cons? V1973) (= (hd V1973) V1972)) true) ((cons? V1973) (element? V1972 (tl V1973))) (true (shen.sys-error element?)))) -(defun empty? (V1919) (cond ((= () V1919) true) (true false))) +(defun empty? (V1979) (cond ((= () V1979) true) (true false))) -(defun fix (V1920 V1921) (shen.fix-help V1920 V1921 (V1920 V1921))) +(defun fix (V1980 V1981) (shen.fix-help V1980 V1981 (V1980 V1981))) -(defun shen.fix-help (V1928 V1929 V1930) (cond ((= V1930 V1929) V1930) (true (shen.fix-help V1928 V1930 (V1928 V1930))))) +(defun shen.fix-help (V1988 V1989 V1990) (cond ((= V1990 V1989) V1990) (true (shen.fix-help V1988 V1990 (V1988 V1990))))) -(defun put (V1932 V1933 V1934 V1935) (let N (hash V1932 (limit V1935)) (let Entry (trap-error (<-vector V1935 N) (lambda E ())) (let Change (vector-> V1935 N (shen.change-pointer-value V1932 V1933 V1934 Entry)) V1934)))) +(defun put (V1992 V1993 V1994 V1995) (let N (hash V1992 (limit V1995)) (let Entry (trap-error (<-vector V1995 N) (lambda E ())) (let Change (vector-> V1995 N (shen.change-pointer-value V1992 V1993 V1994 Entry)) V1994)))) -(defun shen.change-pointer-value (V1938 V1939 V1940 V1941) (cond ((= () V1941) (cons (cons (cons V1938 (cons V1939 ())) V1940) ())) ((and (cons? V1941) (and (cons? (hd V1941)) (and (cons? (hd (hd V1941))) (and (cons? (tl (hd (hd V1941)))) (and (= () (tl (tl (hd (hd V1941))))) (and (= (hd (tl (hd (hd V1941)))) V1939) (= (hd (hd (hd V1941))) V1938))))))) (cons (cons (hd (hd V1941)) V1940) (tl V1941))) ((cons? V1941) (cons (hd V1941) (shen.change-pointer-value V1938 V1939 V1940 (tl V1941)))) (true (shen.sys-error shen.change-pointer-value)))) +(defun shen.change-pointer-value (V1998 V1999 V2000 V2001) (cond ((= () V2001) (cons (cons (cons V1998 (cons V1999 ())) V2000) ())) ((and (cons? V2001) (and (cons? (hd V2001)) (and (cons? (hd (hd V2001))) (and (cons? (tl (hd (hd V2001)))) (and (= () (tl (tl (hd (hd V2001))))) (and (= (hd (tl (hd (hd V2001)))) V1999) (= (hd (hd (hd V2001))) V1998))))))) (cons (cons (hd (hd V2001)) V2000) (tl V2001))) ((cons? V2001) (cons (hd V2001) (shen.change-pointer-value V1998 V1999 V2000 (tl V2001)))) (true (shen.sys-error shen.change-pointer-value)))) -(defun get (V1944 V1945 V1946) (let N (hash V1944 (limit V1946)) (let Entry (trap-error (<-vector V1946 N) (lambda E (simple-error "pointer not found -"))) (let Result (assoc (cons V1944 (cons V1945 ())) Entry) (if (empty? Result) (simple-error "value not found +(defun get (V2004 V2005 V2006) (let N (hash V2004 (limit V2006)) (let Entry (trap-error (<-vector V2006 N) (lambda E (simple-error "pointer not found +"))) (let Result (assoc (cons V2004 (cons V2005 ())) Entry) (if (empty? Result) (simple-error "value not found ") (tl Result)))))) -(defun hash (V1947 V1948) (let Hash (shen.mod (shen.sum (map (lambda V1801 (string->n V1801)) (explode V1947))) V1948) (if (= 0 Hash) 1 Hash))) +(defun hash (V2007 V2008) (let Hash (shen.mod (sum (map (lambda X1861 (string->n X1861)) (explode V2007))) V2008) (if (= 0 Hash) 1 Hash))) -(defun shen.mod (V1949 V1950) (shen.modh V1949 (shen.multiples V1949 (cons V1950 ())))) +(defun shen.mod (V2009 V2010) (shen.modh V2009 (shen.multiples V2009 (cons V2010 ())))) -(defun shen.multiples (V1951 V1952) (cond ((and (cons? V1952) (> (hd V1952) V1951)) (tl V1952)) ((cons? V1952) (shen.multiples V1951 (cons (* 2 (hd V1952)) V1952))) (true (shen.sys-error shen.multiples)))) +(defun shen.multiples (V2011 V2012) (cond ((and (cons? V2012) (> (hd V2012) V2011)) (tl V2012)) ((cons? V2012) (shen.multiples V2011 (cons (* 2 (hd V2012)) V2012))) (true (shen.sys-error shen.multiples)))) -(defun shen.modh (V1955 V1956) (cond ((= 0 V1955) 0) ((= () V1956) V1955) ((and (cons? V1956) (> (hd V1956) V1955)) (if (empty? (tl V1956)) V1955 (shen.modh V1955 (tl V1956)))) ((cons? V1956) (shen.modh (- V1955 (hd V1956)) V1956)) (true (shen.sys-error shen.modh)))) +(defun shen.modh (V2015 V2016) (cond ((= 0 V2015) 0) ((= () V2016) V2015) ((and (cons? V2016) (> (hd V2016) V2015)) (if (empty? (tl V2016)) V2015 (shen.modh V2015 (tl V2016)))) ((cons? V2016) (shen.modh (- V2015 (hd V2016)) V2016)) (true (shen.sys-error shen.modh)))) -(defun shen.sum (V1957) (cond ((= () V1957) 0) ((cons? V1957) (+ (hd V1957) (shen.sum (tl V1957)))) (true (shen.sys-error shen.sum)))) +(defun sum (V2017) (cond ((= () V2017) 0) ((cons? V2017) (+ (hd V2017) (sum (tl V2017)))) (true (shen.sys-error sum)))) -(defun head (V1964) (cond ((cons? V1964) (hd V1964)) (true (simple-error "head expects a non-empty list")))) +(defun head (V2024) (cond ((cons? V2024) (hd V2024)) (true (simple-error "head expects a non-empty list")))) -(defun tail (V1971) (cond ((cons? V1971) (tl V1971)) (true (simple-error "tail expects a non-empty list")))) +(defun tail (V2031) (cond ((cons? V2031) (tl V2031)) (true (simple-error "tail expects a non-empty list")))) -(defun hdstr (V1972) (pos V1972 0)) +(defun hdstr (V2032) (pos V2032 0)) -(defun intersection (V1975 V1976) (cond ((= () V1975) ()) ((cons? V1975) (if (element? (hd V1975) V1976) (cons (hd V1975) (intersection (tl V1975) V1976)) (intersection (tl V1975) V1976))) (true (shen.sys-error intersection)))) +(defun intersection (V2035 V2036) (cond ((= () V2035) ()) ((cons? V2035) (if (element? (hd V2035) V2036) (cons (hd V2035) (intersection (tl V2035) V2036)) (intersection (tl V2035) V2036))) (true (shen.sys-error intersection)))) -(defun reverse (V1977) (shen.reverse_help V1977 ())) +(defun reverse (V2037) (shen.reverse_help V2037 ())) -(defun shen.reverse_help (V1978 V1979) (cond ((= () V1978) V1979) ((cons? V1978) (shen.reverse_help (tl V1978) (cons (hd V1978) V1979))) (true (shen.sys-error shen.reverse_help)))) +(defun shen.reverse_help (V2038 V2039) (cond ((= () V2038) V2039) ((cons? V2038) (shen.reverse_help (tl V2038) (cons (hd V2038) V2039))) (true (shen.sys-error shen.reverse_help)))) -(defun union (V1980 V1981) (cond ((= () V1980) V1981) ((cons? V1980) (if (element? (hd V1980) V1981) (union (tl V1980) V1981) (cons (hd V1980) (union (tl V1980) V1981)))) (true (shen.sys-error union)))) +(defun union (V2040 V2041) (cond ((= () V2040) V2041) ((cons? V2040) (if (element? (hd V2040) V2041) (union (tl V2040) V2041) (cons (hd V2040) (union (tl V2040) V2041)))) (true (shen.sys-error union)))) -(defun y-or-n? (V1982) (let Message (shen.prhush (shen.proc-nl V1982) (stoutput)) (let Y-or-N (shen.prhush " (y/n) " (stoutput)) (let Input (shen.app (read (stinput)) "" shen.s) (if (= "y" Input) true (if (= "n" Input) false (do (shen.prhush "please answer y or n -" (stoutput)) (y-or-n? V1982)))))))) +(defun y-or-n? (V2042) (let Message (shen.prhush (shen.proc-nl V2042) (stoutput)) (let Y-or-N (shen.prhush " (y/n) " (stoutput)) (let Input (shen.app (read (stinput)) "" shen.s) (if (= "y" Input) true (if (= "n" Input) false (do (shen.prhush "please answer y or n +" (stoutput)) (y-or-n? V2042)))))))) -(defun not (V1983) (if V1983 false true)) +(defun not (V2043) (if V2043 false true)) -(defun subst (V1992 V1993 V1994) (cond ((= V1994 V1993) V1992) ((cons? V1994) (cons (subst V1992 V1993 (hd V1994)) (subst V1992 V1993 (tl V1994)))) (true V1994))) +(defun subst (V2052 V2053 V2054) (cond ((= V2054 V2053) V2052) ((cons? V2054) (map (lambda W (subst V2052 V2053 W)) V2054)) (true V2054))) -(defun explode (V1996) (shen.explode-h (shen.app V1996 "" shen.a))) +(defun explode (V2056) (shen.explode-h (shen.app V2056 "" shen.a))) -(defun shen.explode-h (V1997) (cond ((= "" V1997) ()) ((shen.+string? V1997) (cons (pos V1997 0) (shen.explode-h (tlstr V1997)))) (true (shen.sys-error shen.explode-h)))) +(defun shen.explode-h (V2057) (cond ((= "" V2057) ()) ((shen.+string? V2057) (cons (pos V2057 0) (shen.explode-h (tlstr V2057)))) (true (shen.sys-error shen.explode-h)))) -(defun cd (V1998) (set *home-directory* (if (= V1998 "") "" (shen.app V1998 "/" shen.a)))) +(defun cd (V2058) (set *home-directory* (if (= V2058 "") "" (shen.app V2058 "/" shen.a)))) -(defun map (V1999 V2000) (shen.map-h V1999 V2000 ())) +(defun map (V2059 V2060) (shen.map-h V2059 V2060 ())) -(defun shen.map-h (V2003 V2004 V2005) (cond ((= () V2004) (reverse V2005)) ((cons? V2004) (shen.map-h V2003 (tl V2004) (cons (V2003 (hd V2004)) V2005))) (true (shen.sys-error shen.map-h)))) +(defun shen.map-h (V2063 V2064 V2065) (cond ((= () V2064) (reverse V2065)) ((cons? V2064) (shen.map-h V2063 (tl V2064) (cons (V2063 (hd V2064)) V2065))) (true (shen.sys-error shen.map-h)))) -(defun length (V2006) (shen.length-h V2006 0)) +(defun length (V2066) (shen.length-h V2066 0)) -(defun shen.length-h (V2007 V2008) (cond ((= () V2007) V2008) (true (shen.length-h (tl V2007) (+ V2008 1))))) +(defun shen.length-h (V2067 V2068) (cond ((= () V2067) V2068) (true (shen.length-h (tl V2067) (+ V2068 1))))) -(defun occurrences (V2017 V2018) (cond ((= V2018 V2017) 1) ((cons? V2018) (+ (occurrences V2017 (hd V2018)) (occurrences V2017 (tl V2018)))) (true 0))) +(defun occurrences (V2077 V2078) (cond ((= V2078 V2077) 1) ((cons? V2078) (+ (occurrences V2077 (hd V2078)) (occurrences V2077 (tl V2078)))) (true 0))) -(defun nth (V2026 V2027) (cond ((and (= 1 V2026) (cons? V2027)) (hd V2027)) ((cons? V2027) (nth (- V2026 1) (tl V2027))) (true (shen.sys-error nth)))) +(defun nth (V2086 V2087) (cond ((and (= 1 V2086) (cons? V2087)) (hd V2087)) ((cons? V2087) (nth (- V2086 1) (tl V2087))) (true (shen.sys-error nth)))) -(defun integer? (V2028) (and (number? V2028) (let Abs (shen.abs V2028) (shen.integer-test? Abs (shen.magless Abs 1))))) +(defun integer? (V2088) (and (number? V2088) (let Abs (shen.abs V2088) (shen.integer-test? Abs (shen.magless Abs 1))))) -(defun shen.abs (V2029) (if (> V2029 0) V2029 (- 0 V2029))) +(defun shen.abs (V2089) (if (> V2089 0) V2089 (- 0 V2089))) -(defun shen.magless (V2030 V2031) (let Nx2 (* V2031 2) (if (> Nx2 V2030) V2031 (shen.magless V2030 Nx2)))) +(defun shen.magless (V2090 V2091) (let Nx2 (* V2091 2) (if (> Nx2 V2090) V2091 (shen.magless V2090 Nx2)))) -(defun shen.integer-test? (V2035 V2036) (cond ((= 0 V2035) true) ((> 1 V2035) false) (true (let Abs-N (- V2035 V2036) (if (> 0 Abs-N) (integer? V2035) (shen.integer-test? Abs-N V2036)))))) +(defun shen.integer-test? (V2095 V2096) (cond ((= 0 V2095) true) ((> 1 V2095) false) (true (let Abs-N (- V2095 V2096) (if (> 0 Abs-N) (integer? V2095) (shen.integer-test? Abs-N V2096)))))) -(defun mapcan (V2039 V2040) (cond ((= () V2040) ()) ((cons? V2040) (append (V2039 (hd V2040)) (mapcan V2039 (tl V2040)))) (true (shen.sys-error mapcan)))) +(defun mapcan (V2099 V2100) (cond ((= () V2100) ()) ((cons? V2100) (append (V2099 (hd V2100)) (mapcan V2099 (tl V2100)))) (true (shen.sys-error mapcan)))) -(defun == (V2049 V2050) (cond ((= V2050 V2049) true) (true false))) +(defun == (V2109 V2110) (cond ((= V2110 V2109) true) (true false))) (defun abort () (simple-error "")) -(defun bound? (V2052) (and (symbol? V2052) (let Val (trap-error (value V2052) (lambda E shen.this-symbol-is-unbound)) (if (= Val shen.this-symbol-is-unbound) false true)))) +(defun bound? (V2112) (and (symbol? V2112) (let Val (trap-error (value V2112) (lambda E shen.this-symbol-is-unbound)) (if (= Val shen.this-symbol-is-unbound) false true)))) -(defun shen.string->bytes (V2053) (cond ((= "" V2053) ()) (true (cons (string->n (pos V2053 0)) (shen.string->bytes (tlstr V2053)))))) +(defun shen.string->bytes (V2113) (cond ((= "" V2113) ()) (true (cons (string->n (pos V2113 0)) (shen.string->bytes (tlstr V2113)))))) -(defun maxinferences (V2054) (set shen.*maxinferences* V2054)) +(defun maxinferences (V2114) (set shen.*maxinferences* V2114)) (defun inferences () (value shen.*infs*)) -(defun protect (V2055) V2055) +(defun protect (V2115) V2115) (defun stoutput () (value *stoutput*)) -(defun string->symbol (V2056) (let Symbol (intern V2056) (if (symbol? Symbol) Symbol (simple-error (cn "cannot intern " (shen.app V2056 " to a symbol" shen.s)))))) +(defun string->symbol (V2116) (let Symbol (intern V2116) (if (symbol? Symbol) Symbol (simple-error (cn "cannot intern " (shen.app V2116 " to a symbol" shen.s)))))) -(defun shen.optimise (V2061) (cond ((= + V2061) (set shen.*optimise* true)) ((= - V2061) (set shen.*optimise* false)) (true (simple-error "optimise expects a + or a -. +(defun shen.optimise (V2121) (cond ((= + V2121) (set shen.*optimise* true)) ((= - V2121) (set shen.*optimise* false)) (true (simple-error "optimise expects a + or a -. ")))) +(defun os () (value *os*)) + +(defun language () (value *language*)) + +(defun version () (value *version*)) + +(defun port () (value *port*)) + +(defun porters () (value *porters*)) + +(defun implementation () (value *implementation*)) + +(defun release () (value *release*)) + diff --git a/shen/klambda/t-star.kl b/shen/klambda/t-star.kl index 3c36736..6d6e494 100644 --- a/shen/klambda/t-star.kl +++ b/shen/klambda/t-star.kl @@ -47,115 +47,93 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun shen.typecheck (V2829 V2830) (let Curry (shen.curry V2829) (let ProcessN (shen.start-new-prolog-process) (let Type (shen.insert-prolog-variables (shen.demodulate (shen.curry-type V2830)) ProcessN) (let Continuation (freeze (return Type ProcessN shen.void)) (shen.t* (cons Curry (cons : (cons Type ()))) () ProcessN Continuation)))))) +"(defun shen.typecheck (V2790 V2791) (let Curry (shen.curry V2790) (let ProcessN (shen.start-new-prolog-process) (let Type (shen.insert-prolog-variables (shen.demodulate (shen.curry-type V2791)) ProcessN) (let Continuation (freeze (return Type ProcessN shen.void)) (shen.t* (cons Curry (cons : (cons Type ()))) () ProcessN Continuation)))))) -(defun shen.curry (V2831) (cond ((and (cons? V2831) (shen.special? (hd V2831))) (cons (hd V2831) (map shen.curry (tl V2831)))) ((and (cons? V2831) (and (cons? (tl V2831)) (shen.extraspecial? (hd V2831)))) V2831) ((and (cons? V2831) (and (cons? (tl V2831)) (cons? (tl (tl V2831))))) (shen.curry (cons (cons (hd V2831) (cons (hd (tl V2831)) ())) (tl (tl V2831))))) ((and (cons? V2831) (and (cons? (tl V2831)) (= () (tl (tl V2831))))) (cons (shen.curry (hd V2831)) (cons (shen.curry (hd (tl V2831))) ()))) (true V2831))) +(defun shen.curry (V2792) (cond ((and (cons? V2792) (shen.special? (hd V2792))) (cons (hd V2792) (map (lambda X2786 (shen.curry X2786)) (tl V2792)))) ((and (cons? V2792) (and (cons? (tl V2792)) (shen.extraspecial? (hd V2792)))) V2792) ((and (cons? V2792) (and (= type (hd V2792)) (and (cons? (tl V2792)) (and (cons? (tl (tl V2792))) (= () (tl (tl (tl V2792)))))))) (cons type (cons (shen.curry (hd (tl V2792))) (tl (tl V2792))))) ((and (cons? V2792) (and (cons? (tl V2792)) (cons? (tl (tl V2792))))) (shen.curry (cons (cons (hd V2792) (cons (hd (tl V2792)) ())) (tl (tl V2792))))) ((and (cons? V2792) (and (cons? (tl V2792)) (= () (tl (tl V2792))))) (cons (shen.curry (hd V2792)) (cons (shen.curry (hd (tl V2792))) ()))) (true V2792))) -(defun shen.special? (V2832) (element? V2832 (value shen.*special*))) +(defun shen.special? (V2793) (element? V2793 (value shen.*special*))) -(defun shen.extraspecial? (V2833) (element? V2833 (value shen.*extraspecial*))) +(defun shen.extraspecial? (V2794) (element? V2794 (value shen.*extraspecial*))) -(defun shen.t* (V2834 V2835 V2836 V2837) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let Error (shen.newpv V2836) (do (shen.incinfs) (fwhen (shen.maxinfexceeded?) V2836 (freeze (bind Error (shen.errormaxinfs) V2836 V2837))))) (if (= Case false) (let Case (let V2823 (shen.lazyderef V2834 V2836) (if (= fail V2823) (do (shen.incinfs) (cut Throwcontrol V2836 (freeze (shen.prolog-failure V2836 V2837)))) false)) (if (= Case false) (let Case (let V2824 (shen.lazyderef V2834 V2836) (if (cons? V2824) (let X (hd V2824) (let V2825 (shen.lazyderef (tl V2824) V2836) (if (cons? V2825) (let V2826 (shen.lazyderef (hd V2825) V2836) (if (= : V2826) (let V2827 (shen.lazyderef (tl V2825) V2836) (if (cons? V2827) (let A (hd V2827) (let V2828 (shen.lazyderef (tl V2827) V2836) (if (= () V2828) (do (shen.incinfs) (fwhen (shen.type-theory-enabled?) V2836 (freeze (cut Throwcontrol V2836 (freeze (shen.th* X A V2835 V2836 V2837)))))) false))) false)) false)) false))) false)) (if (= Case false) (let Datatypes (shen.newpv V2836) (do (shen.incinfs) (shen.show V2834 V2835 V2836 (freeze (bind Datatypes (value shen.*datatypes*) V2836 (freeze (shen.udefs* V2834 V2835 Datatypes V2836 V2837))))))) Case)) Case)) Case))))) +(defun shen.t* (V2795 V2796 V2797 V2798) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let Error (shen.newpv V2797) (do (shen.incinfs) (fwhen (shen.maxinfexceeded?) V2797 (freeze (bind Error (shen.errormaxinfs) V2797 V2798))))) (if (= Case false) (let Case (let V2780 (shen.lazyderef V2795 V2797) (if (= fail V2780) (do (shen.incinfs) (cut Throwcontrol V2797 (freeze (shen.prolog-failure V2797 V2798)))) false)) (if (= Case false) (let Case (let V2781 (shen.lazyderef V2795 V2797) (if (cons? V2781) (let X (hd V2781) (let V2782 (shen.lazyderef (tl V2781) V2797) (if (cons? V2782) (let V2783 (shen.lazyderef (hd V2782) V2797) (if (= : V2783) (let V2784 (shen.lazyderef (tl V2782) V2797) (if (cons? V2784) (let A (hd V2784) (let V2785 (shen.lazyderef (tl V2784) V2797) (if (= () V2785) (do (shen.incinfs) (fwhen (shen.type-theory-enabled?) V2797 (freeze (cut Throwcontrol V2797 (freeze (shen.th* X A V2796 V2797 V2798)))))) false))) false)) false)) false))) false)) (if (= Case false) (let Datatypes (shen.newpv V2797) (do (shen.incinfs) (shen.show V2795 V2796 V2797 (freeze (bind Datatypes (value shen.*datatypes*) V2797 (freeze (shen.udefs* V2795 V2796 Datatypes V2797 V2798))))))) Case)) Case)) Case))))) (defun shen.type-theory-enabled? () (value shen.*shen-type-theory-enabled?*)) -(defun enable-type-theory (V2842) (cond ((= + V2842) (set shen.*shen-type-theory-enabled?* true)) ((= - V2842) (set shen.*shen-type-theory-enabled?* false)) (true (simple-error "enable-type-theory expects a + or a - +(defun enable-type-theory (V2803) (cond ((= + V2803) (set shen.*shen-type-theory-enabled?* true)) ((= - V2803) (set shen.*shen-type-theory-enabled?* false)) (true (simple-error "enable-type-theory expects a + or a - ")))) -(defun shen.prolog-failure (V2851 V2852) false) +(defun shen.prolog-failure (V2812 V2813) false) (defun shen.maxinfexceeded? () (> (inferences) (value shen.*maxinferences*))) (defun shen.errormaxinfs () (simple-error "maximum inferences exceeded~%")) -(defun shen.udefs* (V2853 V2854 V2855 V2856 V2857) (let Case (let V2819 (shen.lazyderef V2855 V2856) (if (cons? V2819) (let D (hd V2819) (do (shen.incinfs) (call (cons D (cons V2853 (cons V2854 ()))) V2856 V2857))) false)) (if (= Case false) (let V2820 (shen.lazyderef V2855 V2856) (if (cons? V2820) (let Ds (tl V2820) (do (shen.incinfs) (shen.udefs* V2853 V2854 Ds V2856 V2857))) false)) Case))) +(defun shen.udefs* (V2814 V2815 V2816 V2817 V2818) (let Case (let V2776 (shen.lazyderef V2816 V2817) (if (cons? V2776) (let D (hd V2776) (do (shen.incinfs) (call (cons D (cons V2814 (cons V2815 ()))) V2817 V2818))) false)) (if (= Case false) (let V2777 (shen.lazyderef V2816 V2817) (if (cons? V2777) (let Ds (tl V2777) (do (shen.incinfs) (shen.udefs* V2814 V2815 Ds V2817 V2818))) false)) Case))) -(defun shen.th* (V2858 V2859 V2860 V2861 V2862) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (do (shen.incinfs) (shen.show (cons V2858 (cons : (cons V2859 ()))) V2860 V2861 (freeze (fwhen false V2861 V2862)))) (if (= Case false) (let Case (let F (shen.newpv V2861) (do (shen.incinfs) (fwhen (shen.typedf? (shen.lazyderef V2858 V2861)) V2861 (freeze (bind F (shen.sigf (shen.lazyderef V2858 V2861)) V2861 (freeze (call (cons F (cons V2859 ())) V2861 V2862))))))) (if (= Case false) (let Case (do (shen.incinfs) (shen.base V2858 V2859 V2861 V2862)) (if (= Case false) (let Case (do (shen.incinfs) (shen.by_hypothesis V2858 V2859 V2860 V2861 V2862)) (if (= Case false) (let Case (let V2697 (shen.lazyderef V2858 V2861) (if (cons? V2697) (let F (hd V2697) (let V2698 (shen.lazyderef (tl V2697) V2861) (if (= () V2698) (do (shen.incinfs) (shen.th* F (cons --> (cons V2859 ())) V2860 V2861 V2862)) false))) false)) (if (= Case false) (let Case (let V2699 (shen.lazyderef V2858 V2861) (if (cons? V2699) (let F (hd V2699) (let V2700 (shen.lazyderef (tl V2699) V2861) (if (cons? V2700) (let X (hd V2700) (let V2701 (shen.lazyderef (tl V2700) V2861) (if (= () V2701) (let B (shen.newpv V2861) (do (shen.incinfs) (shen.th* F (cons B (cons --> (cons V2859 ()))) V2860 V2861 (freeze (shen.th* X B V2860 V2861 V2862))))) false))) false))) false)) (if (= Case false) (let Case (let V2702 (shen.lazyderef V2858 V2861) (if (cons? V2702) (let V2703 (shen.lazyderef (hd V2702) V2861) (if (= cons V2703) (let V2704 (shen.lazyderef (tl V2702) V2861) (if (cons? V2704) (let X (hd V2704) (let V2705 (shen.lazyderef (tl V2704) V2861) (if (cons? V2705) (let Y (hd V2705) (let V2706 (shen.lazyderef (tl V2705) V2861) (if (= () V2706) (let V2707 (shen.lazyderef V2859 V2861) (if (cons? V2707) (let V2708 (shen.lazyderef (hd V2707) V2861) (if (= list V2708) (let V2709 (shen.lazyderef (tl V2707) V2861) (if (cons? V2709) (let A (hd V2709) (let V2710 (shen.lazyderef (tl V2709) V2861) (if (= () V2710) (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons list (cons A ())) V2860 V2861 V2862)))) (if (shen.pvar? V2710) (do (shen.bindv V2710 () V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons list (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2710 V2861) Result))) false)))) (if (shen.pvar? V2709) (let A (shen.newpv V2861) (do (shen.bindv V2709 (cons A ()) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons list (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2709 V2861) Result)))) false))) (if (shen.pvar? V2708) (do (shen.bindv V2708 list V2861) (let Result (let V2711 (shen.lazyderef (tl V2707) V2861) (if (cons? V2711) (let A (hd V2711) (let V2712 (shen.lazyderef (tl V2711) V2861) (if (= () V2712) (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons list (cons A ())) V2860 V2861 V2862)))) (if (shen.pvar? V2712) (do (shen.bindv V2712 () V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons list (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2712 V2861) Result))) false)))) (if (shen.pvar? V2711) (let A (shen.newpv V2861) (do (shen.bindv V2711 (cons A ()) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons list (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2711 V2861) Result)))) false))) (do (shen.unbindv V2708 V2861) Result))) false))) (if (shen.pvar? V2707) (let A (shen.newpv V2861) (do (shen.bindv V2707 (cons list (cons A ())) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons list (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2707 V2861) Result)))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2713 (shen.lazyderef V2858 V2861) (if (cons? V2713) (let V2714 (shen.lazyderef (hd V2713) V2861) (if (= @p V2714) (let V2715 (shen.lazyderef (tl V2713) V2861) (if (cons? V2715) (let X (hd V2715) (let V2716 (shen.lazyderef (tl V2715) V2861) (if (cons? V2716) (let Y (hd V2716) (let V2717 (shen.lazyderef (tl V2716) V2861) (if (= () V2717) (let V2718 (shen.lazyderef V2859 V2861) (if (cons? V2718) (let A (hd V2718) (let V2719 (shen.lazyderef (tl V2718) V2861) (if (cons? V2719) (let V2720 (shen.lazyderef (hd V2719) V2861) (if (= * V2720) (let V2721 (shen.lazyderef (tl V2719) V2861) (if (cons? V2721) (let B (hd V2721) (let V2722 (shen.lazyderef (tl V2721) V2861) (if (= () V2722) (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y B V2860 V2861 V2862)))) (if (shen.pvar? V2722) (do (shen.bindv V2722 () V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y B V2860 V2861 V2862)))) (do (shen.unbindv V2722 V2861) Result))) false)))) (if (shen.pvar? V2721) (let B (shen.newpv V2861) (do (shen.bindv V2721 (cons B ()) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y B V2860 V2861 V2862)))) (do (shen.unbindv V2721 V2861) Result)))) false))) (if (shen.pvar? V2720) (do (shen.bindv V2720 * V2861) (let Result (let V2723 (shen.lazyderef (tl V2719) V2861) (if (cons? V2723) (let B (hd V2723) (let V2724 (shen.lazyderef (tl V2723) V2861) (if (= () V2724) (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y B V2860 V2861 V2862)))) (if (shen.pvar? V2724) (do (shen.bindv V2724 () V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y B V2860 V2861 V2862)))) (do (shen.unbindv V2724 V2861) Result))) false)))) (if (shen.pvar? V2723) (let B (shen.newpv V2861) (do (shen.bindv V2723 (cons B ()) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y B V2860 V2861 V2862)))) (do (shen.unbindv V2723 V2861) Result)))) false))) (do (shen.unbindv V2720 V2861) Result))) false))) (if (shen.pvar? V2719) (let B (shen.newpv V2861) (do (shen.bindv V2719 (cons * (cons B ())) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y B V2860 V2861 V2862)))) (do (shen.unbindv V2719 V2861) Result)))) false)))) (if (shen.pvar? V2718) (let A (shen.newpv V2861) (let B (shen.newpv V2861) (do (shen.bindv V2718 (cons A (cons * (cons B ()))) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y B V2860 V2861 V2862)))) (do (shen.unbindv V2718 V2861) Result))))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2725 (shen.lazyderef V2858 V2861) (if (cons? V2725) (let V2726 (shen.lazyderef (hd V2725) V2861) (if (= @v V2726) (let V2727 (shen.lazyderef (tl V2725) V2861) (if (cons? V2727) (let X (hd V2727) (let V2728 (shen.lazyderef (tl V2727) V2861) (if (cons? V2728) (let Y (hd V2728) (let V2729 (shen.lazyderef (tl V2728) V2861) (if (= () V2729) (let V2730 (shen.lazyderef V2859 V2861) (if (cons? V2730) (let V2731 (shen.lazyderef (hd V2730) V2861) (if (= vector V2731) (let V2732 (shen.lazyderef (tl V2730) V2861) (if (cons? V2732) (let A (hd V2732) (let V2733 (shen.lazyderef (tl V2732) V2861) (if (= () V2733) (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons vector (cons A ())) V2860 V2861 V2862)))) (if (shen.pvar? V2733) (do (shen.bindv V2733 () V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons vector (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2733 V2861) Result))) false)))) (if (shen.pvar? V2732) (let A (shen.newpv V2861) (do (shen.bindv V2732 (cons A ()) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons vector (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2732 V2861) Result)))) false))) (if (shen.pvar? V2731) (do (shen.bindv V2731 vector V2861) (let Result (let V2734 (shen.lazyderef (tl V2730) V2861) (if (cons? V2734) (let A (hd V2734) (let V2735 (shen.lazyderef (tl V2734) V2861) (if (= () V2735) (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons vector (cons A ())) V2860 V2861 V2862)))) (if (shen.pvar? V2735) (do (shen.bindv V2735 () V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons vector (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2735 V2861) Result))) false)))) (if (shen.pvar? V2734) (let A (shen.newpv V2861) (do (shen.bindv V2734 (cons A ()) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons vector (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2734 V2861) Result)))) false))) (do (shen.unbindv V2731 V2861) Result))) false))) (if (shen.pvar? V2730) (let A (shen.newpv V2861) (do (shen.bindv V2730 (cons vector (cons A ())) V2861) (let Result (do (shen.incinfs) (shen.th* X A V2860 V2861 (freeze (shen.th* Y (cons vector (cons A ())) V2860 V2861 V2862)))) (do (shen.unbindv V2730 V2861) Result)))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2736 (shen.lazyderef V2858 V2861) (if (cons? V2736) (let V2737 (shen.lazyderef (hd V2736) V2861) (if (= @s V2737) (let V2738 (shen.lazyderef (tl V2736) V2861) (if (cons? V2738) (let X (hd V2738) (let V2739 (shen.lazyderef (tl V2738) V2861) (if (cons? V2739) (let Y (hd V2739) (let V2740 (shen.lazyderef (tl V2739) V2861) (if (= () V2740) (let V2741 (shen.lazyderef V2859 V2861) (if (= string V2741) (do (shen.incinfs) (shen.th* X string V2860 V2861 (freeze (shen.th* Y string V2860 V2861 V2862)))) (if (shen.pvar? V2741) (do (shen.bindv V2741 string V2861) (let Result (do (shen.incinfs) (shen.th* X string V2860 V2861 (freeze (shen.th* Y string V2860 V2861 V2862)))) (do (shen.unbindv V2741 V2861) Result))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2742 (shen.lazyderef V2858 V2861) (if (cons? V2742) (let V2743 (shen.lazyderef (hd V2742) V2861) (if (= lambda V2743) (let V2744 (shen.lazyderef (tl V2742) V2861) (if (cons? V2744) (let X (hd V2744) (let V2745 (shen.lazyderef (tl V2744) V2861) (if (cons? V2745) (let Y (hd V2745) (let V2746 (shen.lazyderef (tl V2745) V2861) (if (= () V2746) (let V2747 (shen.lazyderef V2859 V2861) (if (cons? V2747) (let A (hd V2747) (let V2748 (shen.lazyderef (tl V2747) V2861) (if (cons? V2748) (let V2749 (shen.lazyderef (hd V2748) V2861) (if (= --> V2749) (let V2750 (shen.lazyderef (tl V2748) V2861) (if (cons? V2750) (let B (hd V2750) (let V2751 (shen.lazyderef (tl V2750) V2861) (if (= () V2751) (let Z (shen.newpv V2861) (let X&& (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (bind X&& (shen.placeholder) V2861 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2861) (shen.lazyderef X V2861) (shen.lazyderef Y V2861)) V2861 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2860) V2861 V2862)))))))))) (if (shen.pvar? V2751) (do (shen.bindv V2751 () V2861) (let Result (let Z (shen.newpv V2861) (let X&& (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (bind X&& (shen.placeholder) V2861 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2861) (shen.lazyderef X V2861) (shen.lazyderef Y V2861)) V2861 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2860) V2861 V2862)))))))))) (do (shen.unbindv V2751 V2861) Result))) false)))) (if (shen.pvar? V2750) (let B (shen.newpv V2861) (do (shen.bindv V2750 (cons B ()) V2861) (let Result (let Z (shen.newpv V2861) (let X&& (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (bind X&& (shen.placeholder) V2861 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2861) (shen.lazyderef X V2861) (shen.lazyderef Y V2861)) V2861 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2860) V2861 V2862)))))))))) (do (shen.unbindv V2750 V2861) Result)))) false))) (if (shen.pvar? V2749) (do (shen.bindv V2749 --> V2861) (let Result (let V2752 (shen.lazyderef (tl V2748) V2861) (if (cons? V2752) (let B (hd V2752) (let V2753 (shen.lazyderef (tl V2752) V2861) (if (= () V2753) (let Z (shen.newpv V2861) (let X&& (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (bind X&& (shen.placeholder) V2861 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2861) (shen.lazyderef X V2861) (shen.lazyderef Y V2861)) V2861 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2860) V2861 V2862)))))))))) (if (shen.pvar? V2753) (do (shen.bindv V2753 () V2861) (let Result (let Z (shen.newpv V2861) (let X&& (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (bind X&& (shen.placeholder) V2861 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2861) (shen.lazyderef X V2861) (shen.lazyderef Y V2861)) V2861 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2860) V2861 V2862)))))))))) (do (shen.unbindv V2753 V2861) Result))) false)))) (if (shen.pvar? V2752) (let B (shen.newpv V2861) (do (shen.bindv V2752 (cons B ()) V2861) (let Result (let Z (shen.newpv V2861) (let X&& (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (bind X&& (shen.placeholder) V2861 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2861) (shen.lazyderef X V2861) (shen.lazyderef Y V2861)) V2861 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2860) V2861 V2862)))))))))) (do (shen.unbindv V2752 V2861) Result)))) false))) (do (shen.unbindv V2749 V2861) Result))) false))) (if (shen.pvar? V2748) (let B (shen.newpv V2861) (do (shen.bindv V2748 (cons --> (cons B ())) V2861) (let Result (let Z (shen.newpv V2861) (let X&& (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (bind X&& (shen.placeholder) V2861 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2861) (shen.lazyderef X V2861) (shen.lazyderef Y V2861)) V2861 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2860) V2861 V2862)))))))))) (do (shen.unbindv V2748 V2861) Result)))) false)))) (if (shen.pvar? V2747) (let A (shen.newpv V2861) (let B (shen.newpv V2861) (do (shen.bindv V2747 (cons A (cons --> (cons B ()))) V2861) (let Result (let Z (shen.newpv V2861) (let X&& (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (bind X&& (shen.placeholder) V2861 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2861) (shen.lazyderef X V2861) (shen.lazyderef Y V2861)) V2861 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2860) V2861 V2862)))))))))) (do (shen.unbindv V2747 V2861) Result))))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2754 (shen.lazyderef V2858 V2861) (if (cons? V2754) (let V2755 (shen.lazyderef (hd V2754) V2861) (if (= let V2755) (let V2756 (shen.lazyderef (tl V2754) V2861) (if (cons? V2756) (let X (hd V2756) (let V2757 (shen.lazyderef (tl V2756) V2861) (if (cons? V2757) (let Y (hd V2757) (let V2758 (shen.lazyderef (tl V2757) V2861) (if (cons? V2758) (let Z (hd V2758) (let V2759 (shen.lazyderef (tl V2758) V2861) (if (= () V2759) (let W (shen.newpv V2861) (let X&& (shen.newpv V2861) (let B (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (shen.th* Y B V2860 V2861 (freeze (bind X&& (shen.placeholder) V2861 (freeze (bind W (shen.ebr (shen.lazyderef X&& V2861) (shen.lazyderef X V2861) (shen.lazyderef Z V2861)) V2861 (freeze (shen.th* W V2859 (cons (cons X&& (cons : (cons B ()))) V2860) V2861 V2862))))))))))))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2760 (shen.lazyderef V2858 V2861) (if (cons? V2760) (let V2761 (shen.lazyderef (hd V2760) V2861) (if (= open V2761) (let V2762 (shen.lazyderef (tl V2760) V2861) (if (cons? V2762) (let FileName (hd V2762) (let V2763 (shen.lazyderef (tl V2762) V2861) (if (cons? V2763) (let Direction2693 (hd V2763) (let V2764 (shen.lazyderef (tl V2763) V2861) (if (= () V2764) (let V2765 (shen.lazyderef V2859 V2861) (if (cons? V2765) (let V2766 (shen.lazyderef (hd V2765) V2861) (if (= stream V2766) (let V2767 (shen.lazyderef (tl V2765) V2861) (if (cons? V2767) (let Direction (hd V2767) (let V2768 (shen.lazyderef (tl V2767) V2861) (if (= () V2768) (do (shen.incinfs) (unify! Direction Direction2693 V2861 (freeze (cut Throwcontrol V2861 (freeze (shen.th* FileName string V2860 V2861 V2862)))))) (if (shen.pvar? V2768) (do (shen.bindv V2768 () V2861) (let Result (do (shen.incinfs) (unify! Direction Direction2693 V2861 (freeze (cut Throwcontrol V2861 (freeze (shen.th* FileName string V2860 V2861 V2862)))))) (do (shen.unbindv V2768 V2861) Result))) false)))) (if (shen.pvar? V2767) (let Direction (shen.newpv V2861) (do (shen.bindv V2767 (cons Direction ()) V2861) (let Result (do (shen.incinfs) (unify! Direction Direction2693 V2861 (freeze (cut Throwcontrol V2861 (freeze (shen.th* FileName string V2860 V2861 V2862)))))) (do (shen.unbindv V2767 V2861) Result)))) false))) (if (shen.pvar? V2766) (do (shen.bindv V2766 stream V2861) (let Result (let V2769 (shen.lazyderef (tl V2765) V2861) (if (cons? V2769) (let Direction (hd V2769) (let V2770 (shen.lazyderef (tl V2769) V2861) (if (= () V2770) (do (shen.incinfs) (unify! Direction Direction2693 V2861 (freeze (cut Throwcontrol V2861 (freeze (shen.th* FileName string V2860 V2861 V2862)))))) (if (shen.pvar? V2770) (do (shen.bindv V2770 () V2861) (let Result (do (shen.incinfs) (unify! Direction Direction2693 V2861 (freeze (cut Throwcontrol V2861 (freeze (shen.th* FileName string V2860 V2861 V2862)))))) (do (shen.unbindv V2770 V2861) Result))) false)))) (if (shen.pvar? V2769) (let Direction (shen.newpv V2861) (do (shen.bindv V2769 (cons Direction ()) V2861) (let Result (do (shen.incinfs) (unify! Direction Direction2693 V2861 (freeze (cut Throwcontrol V2861 (freeze (shen.th* FileName string V2860 V2861 V2862)))))) (do (shen.unbindv V2769 V2861) Result)))) false))) (do (shen.unbindv V2766 V2861) Result))) false))) (if (shen.pvar? V2765) (let Direction (shen.newpv V2861) (do (shen.bindv V2765 (cons stream (cons Direction ())) V2861) (let Result (do (shen.incinfs) (unify! Direction Direction2693 V2861 (freeze (cut Throwcontrol V2861 (freeze (shen.th* FileName string V2860 V2861 V2862)))))) (do (shen.unbindv V2765 V2861) Result)))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2771 (shen.lazyderef V2858 V2861) (if (cons? V2771) (let V2772 (shen.lazyderef (hd V2771) V2861) (if (= type V2772) (let V2773 (shen.lazyderef (tl V2771) V2861) (if (cons? V2773) (let X (hd V2773) (let V2774 (shen.lazyderef (tl V2773) V2861) (if (cons? V2774) (let A (hd V2774) (let V2775 (shen.lazyderef (tl V2774) V2861) (if (= () V2775) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (unify A V2859 V2861 (freeze (shen.th* X A V2860 V2861 V2862)))))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2776 (shen.lazyderef V2858 V2861) (if (cons? V2776) (let V2777 (shen.lazyderef (hd V2776) V2861) (if (= input+ V2777) (let V2778 (shen.lazyderef (tl V2776) V2861) (if (cons? V2778) (let A (hd V2778) (let V2779 (shen.lazyderef (tl V2778) V2861) (if (cons? V2779) (let Stream (hd V2779) (let V2780 (shen.lazyderef (tl V2779) V2861) (if (= () V2780) (let C (shen.newpv V2861) (do (shen.incinfs) (bind C (shen.demodulate (shen.lazyderef A V2861)) V2861 (freeze (unify V2859 C V2861 (freeze (shen.th* Stream (cons stream (cons in ())) V2860 V2861 V2862))))))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2781 (shen.lazyderef V2858 V2861) (if (cons? V2781) (let V2782 (shen.lazyderef (hd V2781) V2861) (if (= read+ V2782) (let V2783 (shen.lazyderef (tl V2781) V2861) (if (cons? V2783) (let V2784 (shen.lazyderef (hd V2783) V2861) (if (= : V2784) (let V2785 (shen.lazyderef (tl V2783) V2861) (if (cons? V2785) (let A (hd V2785) (let V2786 (shen.lazyderef (tl V2785) V2861) (if (cons? V2786) (let Stream (hd V2786) (let V2787 (shen.lazyderef (tl V2786) V2861) (if (= () V2787) (let C (shen.newpv V2861) (do (shen.incinfs) (bind C (shen.demodulate (shen.lazyderef A V2861)) V2861 (freeze (unify V2859 C V2861 (freeze (shen.th* Stream (cons stream (cons in ())) V2860 V2861 V2862))))))) false))) false))) false)) false)) false)) false)) false)) (if (= Case false) (let Case (let V2788 (shen.lazyderef V2858 V2861) (if (cons? V2788) (let V2789 (shen.lazyderef (hd V2788) V2861) (if (= set V2789) (let V2790 (shen.lazyderef (tl V2788) V2861) (if (cons? V2790) (let Var (hd V2790) (let V2791 (shen.lazyderef (tl V2790) V2861) (if (cons? V2791) (let Val (hd V2791) (let V2792 (shen.lazyderef (tl V2791) V2861) (if (= () V2792) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (shen.th* Var symbol V2860 V2861 (freeze (cut Throwcontrol V2861 (freeze (shen.th* (cons value (cons Var ())) V2859 V2860 V2861 (freeze (shen.th* Val V2859 V2860 V2861 V2862)))))))))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2793 (shen.lazyderef V2858 V2861) (if (cons? V2793) (let V2794 (shen.lazyderef (hd V2793) V2861) (if (= shen.<-sem V2794) (let V2795 (shen.lazyderef (tl V2793) V2861) (if (cons? V2795) (let F (hd V2795) (let V2796 (shen.lazyderef (tl V2795) V2861) (if (= () V2796) (let A (shen.newpv V2861) (let F&& (shen.newpv V2861) (let B (shen.newpv V2861) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (shen.th* F (cons A (cons ==> (cons B ()))) V2860 V2861 (freeze (cut Throwcontrol V2861 (freeze (bind F&& (concat && (shen.lazyderef F V2861)) V2861 (freeze (cut Throwcontrol V2861 (freeze (shen.th* F&& V2859 (cons (cons F&& (cons : (cons B ()))) V2860) V2861 V2862))))))))))))))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2797 (shen.lazyderef V2858 V2861) (if (cons? V2797) (let V2798 (shen.lazyderef (hd V2797) V2861) (if (= fail V2798) (let V2799 (shen.lazyderef (tl V2797) V2861) (if (= () V2799) (let V2800 (shen.lazyderef V2859 V2861) (if (= symbol V2800) (do (shen.incinfs) (thaw V2862)) (if (shen.pvar? V2800) (do (shen.bindv V2800 symbol V2861) (let Result (do (shen.incinfs) (thaw V2862)) (do (shen.unbindv V2800 V2861) Result))) false))) false)) false)) false)) (if (= Case false) (let Case (let NewHyp (shen.newpv V2861) (do (shen.incinfs) (shen.t*-hyps V2860 NewHyp V2861 (freeze (shen.th* V2858 V2859 NewHyp V2861 V2862))))) (if (= Case false) (let Case (let V2801 (shen.lazyderef V2858 V2861) (if (cons? V2801) (let V2802 (shen.lazyderef (hd V2801) V2861) (if (= define V2802) (let V2803 (shen.lazyderef (tl V2801) V2861) (if (cons? V2803) (let F (hd V2803) (let X (tl V2803) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (shen.t*-def (cons define (cons F X)) V2859 V2860 V2861 V2862)))))) false)) false)) false)) (if (= Case false) (let Case (let V2804 (shen.lazyderef V2858 V2861) (if (cons? V2804) (let V2805 (shen.lazyderef (hd V2804) V2861) (if (= defcc V2805) (let V2806 (shen.lazyderef (tl V2804) V2861) (if (cons? V2806) (let F (hd V2806) (let X (tl V2806) (do (shen.incinfs) (cut Throwcontrol V2861 (freeze (shen.t*-defcc (cons defcc (cons F X)) V2859 V2860 V2861 V2862)))))) false)) false)) false)) (if (= Case false) (let Case (let V2807 (shen.lazyderef V2858 V2861) (if (cons? V2807) (let V2808 (shen.lazyderef (hd V2807) V2861) (if (= defmacro V2808) (let V2809 (shen.lazyderef V2859 V2861) (if (= unit V2809) (do (shen.incinfs) (cut Throwcontrol V2861 V2862)) (if (shen.pvar? V2809) (do (shen.bindv V2809 unit V2861) (let Result (do (shen.incinfs) (cut Throwcontrol V2861 V2862)) (do (shen.unbindv V2809 V2861) Result))) false))) false)) false)) (if (= Case false) (let Case (let V2810 (shen.lazyderef V2858 V2861) (if (cons? V2810) (let V2811 (shen.lazyderef (hd V2810) V2861) (if (= shen.process-datatype V2811) (let V2812 (shen.lazyderef V2859 V2861) (if (= symbol V2812) (do (shen.incinfs) (thaw V2862)) (if (shen.pvar? V2812) (do (shen.bindv V2812 symbol V2861) (let Result (do (shen.incinfs) (thaw V2862)) (do (shen.unbindv V2812 V2861) Result))) false))) false)) false)) (if (= Case false) (let Case (let V2813 (shen.lazyderef V2858 V2861) (if (cons? V2813) (let V2814 (shen.lazyderef (hd V2813) V2861) (if (= shen.synonyms-help V2814) (let V2815 (shen.lazyderef V2859 V2861) (if (= symbol V2815) (do (shen.incinfs) (thaw V2862)) (if (shen.pvar? V2815) (do (shen.bindv V2815 symbol V2861) (let Result (do (shen.incinfs) (thaw V2862)) (do (shen.unbindv V2815 V2861) Result))) false))) false)) false)) (if (= Case false) (let Datatypes (shen.newpv V2861) (do (shen.incinfs) (bind Datatypes (value shen.*datatypes*) V2861 (freeze (shen.udefs* (cons V2858 (cons : (cons V2859 ()))) V2860 Datatypes V2861 V2862))))) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case))))) +(defun shen.th* (V2819 V2820 V2821 V2822 V2823) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (do (shen.incinfs) (shen.show (cons V2819 (cons : (cons V2820 ()))) V2821 V2822 (freeze (fwhen false V2822 V2823)))) (if (= Case false) (let Case (let F (shen.newpv V2822) (do (shen.incinfs) (fwhen (shen.typedf? (shen.lazyderef V2819 V2822)) V2822 (freeze (bind F (shen.sigf (shen.lazyderef V2819 V2822)) V2822 (freeze (call (cons F (cons V2820 ())) V2822 V2823))))))) (if (= Case false) (let Case (do (shen.incinfs) (shen.base V2819 V2820 V2822 V2823)) (if (= Case false) (let Case (do (shen.incinfs) (shen.by_hypothesis V2819 V2820 V2821 V2822 V2823)) (if (= Case false) (let Case (let V2668 (shen.lazyderef V2819 V2822) (if (cons? V2668) (let F (hd V2668) (let V2669 (shen.lazyderef (tl V2668) V2822) (if (= () V2669) (do (shen.incinfs) (shen.th* F (cons --> (cons V2820 ())) V2821 V2822 V2823)) false))) false)) (if (= Case false) (let Case (let V2670 (shen.lazyderef V2819 V2822) (if (cons? V2670) (let F (hd V2670) (let V2671 (shen.lazyderef (tl V2670) V2822) (if (cons? V2671) (let X (hd V2671) (let V2672 (shen.lazyderef (tl V2671) V2822) (if (= () V2672) (let B (shen.newpv V2822) (do (shen.incinfs) (shen.th* F (cons B (cons --> (cons V2820 ()))) V2821 V2822 (freeze (shen.th* X B V2821 V2822 V2823))))) false))) false))) false)) (if (= Case false) (let Case (let V2673 (shen.lazyderef V2819 V2822) (if (cons? V2673) (let V2674 (shen.lazyderef (hd V2673) V2822) (if (= cons V2674) (let V2675 (shen.lazyderef (tl V2673) V2822) (if (cons? V2675) (let X (hd V2675) (let V2676 (shen.lazyderef (tl V2675) V2822) (if (cons? V2676) (let Y (hd V2676) (let V2677 (shen.lazyderef (tl V2676) V2822) (if (= () V2677) (let V2678 (shen.lazyderef V2820 V2822) (if (cons? V2678) (let V2679 (shen.lazyderef (hd V2678) V2822) (if (= list V2679) (let V2680 (shen.lazyderef (tl V2678) V2822) (if (cons? V2680) (let A (hd V2680) (let V2681 (shen.lazyderef (tl V2680) V2822) (if (= () V2681) (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons list (cons A ())) V2821 V2822 V2823)))) (if (shen.pvar? V2681) (do (shen.bindv V2681 () V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons list (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2681 V2822) Result))) false)))) (if (shen.pvar? V2680) (let A (shen.newpv V2822) (do (shen.bindv V2680 (cons A ()) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons list (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2680 V2822) Result)))) false))) (if (shen.pvar? V2679) (do (shen.bindv V2679 list V2822) (let Result (let V2682 (shen.lazyderef (tl V2678) V2822) (if (cons? V2682) (let A (hd V2682) (let V2683 (shen.lazyderef (tl V2682) V2822) (if (= () V2683) (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons list (cons A ())) V2821 V2822 V2823)))) (if (shen.pvar? V2683) (do (shen.bindv V2683 () V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons list (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2683 V2822) Result))) false)))) (if (shen.pvar? V2682) (let A (shen.newpv V2822) (do (shen.bindv V2682 (cons A ()) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons list (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2682 V2822) Result)))) false))) (do (shen.unbindv V2679 V2822) Result))) false))) (if (shen.pvar? V2678) (let A (shen.newpv V2822) (do (shen.bindv V2678 (cons list (cons A ())) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons list (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2678 V2822) Result)))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2684 (shen.lazyderef V2819 V2822) (if (cons? V2684) (let V2685 (shen.lazyderef (hd V2684) V2822) (if (= @p V2685) (let V2686 (shen.lazyderef (tl V2684) V2822) (if (cons? V2686) (let X (hd V2686) (let V2687 (shen.lazyderef (tl V2686) V2822) (if (cons? V2687) (let Y (hd V2687) (let V2688 (shen.lazyderef (tl V2687) V2822) (if (= () V2688) (let V2689 (shen.lazyderef V2820 V2822) (if (cons? V2689) (let A (hd V2689) (let V2690 (shen.lazyderef (tl V2689) V2822) (if (cons? V2690) (let V2691 (shen.lazyderef (hd V2690) V2822) (if (= * V2691) (let V2692 (shen.lazyderef (tl V2690) V2822) (if (cons? V2692) (let B (hd V2692) (let V2693 (shen.lazyderef (tl V2692) V2822) (if (= () V2693) (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y B V2821 V2822 V2823)))) (if (shen.pvar? V2693) (do (shen.bindv V2693 () V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y B V2821 V2822 V2823)))) (do (shen.unbindv V2693 V2822) Result))) false)))) (if (shen.pvar? V2692) (let B (shen.newpv V2822) (do (shen.bindv V2692 (cons B ()) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y B V2821 V2822 V2823)))) (do (shen.unbindv V2692 V2822) Result)))) false))) (if (shen.pvar? V2691) (do (shen.bindv V2691 * V2822) (let Result (let V2694 (shen.lazyderef (tl V2690) V2822) (if (cons? V2694) (let B (hd V2694) (let V2695 (shen.lazyderef (tl V2694) V2822) (if (= () V2695) (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y B V2821 V2822 V2823)))) (if (shen.pvar? V2695) (do (shen.bindv V2695 () V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y B V2821 V2822 V2823)))) (do (shen.unbindv V2695 V2822) Result))) false)))) (if (shen.pvar? V2694) (let B (shen.newpv V2822) (do (shen.bindv V2694 (cons B ()) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y B V2821 V2822 V2823)))) (do (shen.unbindv V2694 V2822) Result)))) false))) (do (shen.unbindv V2691 V2822) Result))) false))) (if (shen.pvar? V2690) (let B (shen.newpv V2822) (do (shen.bindv V2690 (cons * (cons B ())) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y B V2821 V2822 V2823)))) (do (shen.unbindv V2690 V2822) Result)))) false)))) (if (shen.pvar? V2689) (let A (shen.newpv V2822) (let B (shen.newpv V2822) (do (shen.bindv V2689 (cons A (cons * (cons B ()))) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y B V2821 V2822 V2823)))) (do (shen.unbindv V2689 V2822) Result))))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2696 (shen.lazyderef V2819 V2822) (if (cons? V2696) (let V2697 (shen.lazyderef (hd V2696) V2822) (if (= @v V2697) (let V2698 (shen.lazyderef (tl V2696) V2822) (if (cons? V2698) (let X (hd V2698) (let V2699 (shen.lazyderef (tl V2698) V2822) (if (cons? V2699) (let Y (hd V2699) (let V2700 (shen.lazyderef (tl V2699) V2822) (if (= () V2700) (let V2701 (shen.lazyderef V2820 V2822) (if (cons? V2701) (let V2702 (shen.lazyderef (hd V2701) V2822) (if (= vector V2702) (let V2703 (shen.lazyderef (tl V2701) V2822) (if (cons? V2703) (let A (hd V2703) (let V2704 (shen.lazyderef (tl V2703) V2822) (if (= () V2704) (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons vector (cons A ())) V2821 V2822 V2823)))) (if (shen.pvar? V2704) (do (shen.bindv V2704 () V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons vector (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2704 V2822) Result))) false)))) (if (shen.pvar? V2703) (let A (shen.newpv V2822) (do (shen.bindv V2703 (cons A ()) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons vector (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2703 V2822) Result)))) false))) (if (shen.pvar? V2702) (do (shen.bindv V2702 vector V2822) (let Result (let V2705 (shen.lazyderef (tl V2701) V2822) (if (cons? V2705) (let A (hd V2705) (let V2706 (shen.lazyderef (tl V2705) V2822) (if (= () V2706) (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons vector (cons A ())) V2821 V2822 V2823)))) (if (shen.pvar? V2706) (do (shen.bindv V2706 () V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons vector (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2706 V2822) Result))) false)))) (if (shen.pvar? V2705) (let A (shen.newpv V2822) (do (shen.bindv V2705 (cons A ()) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons vector (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2705 V2822) Result)))) false))) (do (shen.unbindv V2702 V2822) Result))) false))) (if (shen.pvar? V2701) (let A (shen.newpv V2822) (do (shen.bindv V2701 (cons vector (cons A ())) V2822) (let Result (do (shen.incinfs) (shen.th* X A V2821 V2822 (freeze (shen.th* Y (cons vector (cons A ())) V2821 V2822 V2823)))) (do (shen.unbindv V2701 V2822) Result)))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2707 (shen.lazyderef V2819 V2822) (if (cons? V2707) (let V2708 (shen.lazyderef (hd V2707) V2822) (if (= @s V2708) (let V2709 (shen.lazyderef (tl V2707) V2822) (if (cons? V2709) (let X (hd V2709) (let V2710 (shen.lazyderef (tl V2709) V2822) (if (cons? V2710) (let Y (hd V2710) (let V2711 (shen.lazyderef (tl V2710) V2822) (if (= () V2711) (let V2712 (shen.lazyderef V2820 V2822) (if (= string V2712) (do (shen.incinfs) (shen.th* X string V2821 V2822 (freeze (shen.th* Y string V2821 V2822 V2823)))) (if (shen.pvar? V2712) (do (shen.bindv V2712 string V2822) (let Result (do (shen.incinfs) (shen.th* X string V2821 V2822 (freeze (shen.th* Y string V2821 V2822 V2823)))) (do (shen.unbindv V2712 V2822) Result))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2713 (shen.lazyderef V2819 V2822) (if (cons? V2713) (let V2714 (shen.lazyderef (hd V2713) V2822) (if (= lambda V2714) (let V2715 (shen.lazyderef (tl V2713) V2822) (if (cons? V2715) (let X (hd V2715) (let V2716 (shen.lazyderef (tl V2715) V2822) (if (cons? V2716) (let Y (hd V2716) (let V2717 (shen.lazyderef (tl V2716) V2822) (if (= () V2717) (let V2718 (shen.lazyderef V2820 V2822) (if (cons? V2718) (let A (hd V2718) (let V2719 (shen.lazyderef (tl V2718) V2822) (if (cons? V2719) (let V2720 (shen.lazyderef (hd V2719) V2822) (if (= --> V2720) (let V2721 (shen.lazyderef (tl V2719) V2822) (if (cons? V2721) (let B (hd V2721) (let V2722 (shen.lazyderef (tl V2721) V2822) (if (= () V2722) (let Z (shen.newpv V2822) (let X&& (shen.newpv V2822) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (bind X&& (shen.placeholder) V2822 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2822) (shen.lazyderef X V2822) (shen.lazyderef Y V2822)) V2822 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2821) V2822 V2823)))))))))) (if (shen.pvar? V2722) (do (shen.bindv V2722 () V2822) (let Result (let Z (shen.newpv V2822) (let X&& (shen.newpv V2822) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (bind X&& (shen.placeholder) V2822 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2822) (shen.lazyderef X V2822) (shen.lazyderef Y V2822)) V2822 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2821) V2822 V2823)))))))))) (do (shen.unbindv V2722 V2822) Result))) false)))) (if (shen.pvar? V2721) (let B (shen.newpv V2822) (do (shen.bindv V2721 (cons B ()) V2822) (let Result (let Z (shen.newpv V2822) (let X&& (shen.newpv V2822) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (bind X&& (shen.placeholder) V2822 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2822) (shen.lazyderef X V2822) (shen.lazyderef Y V2822)) V2822 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2821) V2822 V2823)))))))))) (do (shen.unbindv V2721 V2822) Result)))) false))) (if (shen.pvar? V2720) (do (shen.bindv V2720 --> V2822) (let Result (let V2723 (shen.lazyderef (tl V2719) V2822) (if (cons? V2723) (let B (hd V2723) (let V2724 (shen.lazyderef (tl V2723) V2822) (if (= () V2724) (let Z (shen.newpv V2822) (let X&& (shen.newpv V2822) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (bind X&& (shen.placeholder) V2822 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2822) (shen.lazyderef X V2822) (shen.lazyderef Y V2822)) V2822 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2821) V2822 V2823)))))))))) (if (shen.pvar? V2724) (do (shen.bindv V2724 () V2822) (let Result (let Z (shen.newpv V2822) (let X&& (shen.newpv V2822) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (bind X&& (shen.placeholder) V2822 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2822) (shen.lazyderef X V2822) (shen.lazyderef Y V2822)) V2822 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2821) V2822 V2823)))))))))) (do (shen.unbindv V2724 V2822) Result))) false)))) (if (shen.pvar? V2723) (let B (shen.newpv V2822) (do (shen.bindv V2723 (cons B ()) V2822) (let Result (let Z (shen.newpv V2822) (let X&& (shen.newpv V2822) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (bind X&& (shen.placeholder) V2822 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2822) (shen.lazyderef X V2822) (shen.lazyderef Y V2822)) V2822 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2821) V2822 V2823)))))))))) (do (shen.unbindv V2723 V2822) Result)))) false))) (do (shen.unbindv V2720 V2822) Result))) false))) (if (shen.pvar? V2719) (let B (shen.newpv V2822) (do (shen.bindv V2719 (cons --> (cons B ())) V2822) (let Result (let Z (shen.newpv V2822) (let X&& (shen.newpv V2822) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (bind X&& (shen.placeholder) V2822 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2822) (shen.lazyderef X V2822) (shen.lazyderef Y V2822)) V2822 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2821) V2822 V2823)))))))))) (do (shen.unbindv V2719 V2822) Result)))) false)))) (if (shen.pvar? V2718) (let A (shen.newpv V2822) (let B (shen.newpv V2822) (do (shen.bindv V2718 (cons A (cons --> (cons B ()))) V2822) (let Result (let Z (shen.newpv V2822) (let X&& (shen.newpv V2822) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (bind X&& (shen.placeholder) V2822 (freeze (bind Z (shen.ebr (shen.lazyderef X&& V2822) (shen.lazyderef X V2822) (shen.lazyderef Y V2822)) V2822 (freeze (shen.th* Z B (cons (cons X&& (cons : (cons A ()))) V2821) V2822 V2823)))))))))) (do (shen.unbindv V2718 V2822) Result))))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2725 (shen.lazyderef V2819 V2822) (if (cons? V2725) (let V2726 (shen.lazyderef (hd V2725) V2822) (if (= let V2726) (let V2727 (shen.lazyderef (tl V2725) V2822) (if (cons? V2727) (let X (hd V2727) (let V2728 (shen.lazyderef (tl V2727) V2822) (if (cons? V2728) (let Y (hd V2728) (let V2729 (shen.lazyderef (tl V2728) V2822) (if (cons? V2729) (let Z (hd V2729) (let V2730 (shen.lazyderef (tl V2729) V2822) (if (= () V2730) (let W (shen.newpv V2822) (let X&& (shen.newpv V2822) (let B (shen.newpv V2822) (do (shen.incinfs) (shen.th* Y B V2821 V2822 (freeze (bind X&& (shen.placeholder) V2822 (freeze (bind W (shen.ebr (shen.lazyderef X&& V2822) (shen.lazyderef X V2822) (shen.lazyderef Z V2822)) V2822 (freeze (shen.th* W V2820 (cons (cons X&& (cons : (cons B ()))) V2821) V2822 V2823))))))))))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2731 (shen.lazyderef V2819 V2822) (if (cons? V2731) (let V2732 (shen.lazyderef (hd V2731) V2822) (if (= open V2732) (let V2733 (shen.lazyderef (tl V2731) V2822) (if (cons? V2733) (let FileName (hd V2733) (let V2734 (shen.lazyderef (tl V2733) V2822) (if (cons? V2734) (let Direction2664 (hd V2734) (let V2735 (shen.lazyderef (tl V2734) V2822) (if (= () V2735) (let V2736 (shen.lazyderef V2820 V2822) (if (cons? V2736) (let V2737 (shen.lazyderef (hd V2736) V2822) (if (= stream V2737) (let V2738 (shen.lazyderef (tl V2736) V2822) (if (cons? V2738) (let Direction (hd V2738) (let V2739 (shen.lazyderef (tl V2738) V2822) (if (= () V2739) (do (shen.incinfs) (unify! Direction Direction2664 V2822 (freeze (cut Throwcontrol V2822 (freeze (shen.th* FileName string V2821 V2822 V2823)))))) (if (shen.pvar? V2739) (do (shen.bindv V2739 () V2822) (let Result (do (shen.incinfs) (unify! Direction Direction2664 V2822 (freeze (cut Throwcontrol V2822 (freeze (shen.th* FileName string V2821 V2822 V2823)))))) (do (shen.unbindv V2739 V2822) Result))) false)))) (if (shen.pvar? V2738) (let Direction (shen.newpv V2822) (do (shen.bindv V2738 (cons Direction ()) V2822) (let Result (do (shen.incinfs) (unify! Direction Direction2664 V2822 (freeze (cut Throwcontrol V2822 (freeze (shen.th* FileName string V2821 V2822 V2823)))))) (do (shen.unbindv V2738 V2822) Result)))) false))) (if (shen.pvar? V2737) (do (shen.bindv V2737 stream V2822) (let Result (let V2740 (shen.lazyderef (tl V2736) V2822) (if (cons? V2740) (let Direction (hd V2740) (let V2741 (shen.lazyderef (tl V2740) V2822) (if (= () V2741) (do (shen.incinfs) (unify! Direction Direction2664 V2822 (freeze (cut Throwcontrol V2822 (freeze (shen.th* FileName string V2821 V2822 V2823)))))) (if (shen.pvar? V2741) (do (shen.bindv V2741 () V2822) (let Result (do (shen.incinfs) (unify! Direction Direction2664 V2822 (freeze (cut Throwcontrol V2822 (freeze (shen.th* FileName string V2821 V2822 V2823)))))) (do (shen.unbindv V2741 V2822) Result))) false)))) (if (shen.pvar? V2740) (let Direction (shen.newpv V2822) (do (shen.bindv V2740 (cons Direction ()) V2822) (let Result (do (shen.incinfs) (unify! Direction Direction2664 V2822 (freeze (cut Throwcontrol V2822 (freeze (shen.th* FileName string V2821 V2822 V2823)))))) (do (shen.unbindv V2740 V2822) Result)))) false))) (do (shen.unbindv V2737 V2822) Result))) false))) (if (shen.pvar? V2736) (let Direction (shen.newpv V2822) (do (shen.bindv V2736 (cons stream (cons Direction ())) V2822) (let Result (do (shen.incinfs) (unify! Direction Direction2664 V2822 (freeze (cut Throwcontrol V2822 (freeze (shen.th* FileName string V2821 V2822 V2823)))))) (do (shen.unbindv V2736 V2822) Result)))) false))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2742 (shen.lazyderef V2819 V2822) (if (cons? V2742) (let V2743 (shen.lazyderef (hd V2742) V2822) (if (= type V2743) (let V2744 (shen.lazyderef (tl V2742) V2822) (if (cons? V2744) (let X (hd V2744) (let V2745 (shen.lazyderef (tl V2744) V2822) (if (cons? V2745) (let A (hd V2745) (let V2746 (shen.lazyderef (tl V2745) V2822) (if (= () V2746) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (unify A V2820 V2822 (freeze (shen.th* X A V2821 V2822 V2823)))))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2747 (shen.lazyderef V2819 V2822) (if (cons? V2747) (let V2748 (shen.lazyderef (hd V2747) V2822) (if (= input+ V2748) (let V2749 (shen.lazyderef (tl V2747) V2822) (if (cons? V2749) (let A (hd V2749) (let V2750 (shen.lazyderef (tl V2749) V2822) (if (cons? V2750) (let Stream (hd V2750) (let V2751 (shen.lazyderef (tl V2750) V2822) (if (= () V2751) (let C (shen.newpv V2822) (do (shen.incinfs) (bind C (shen.demodulate (shen.lazyderef A V2822)) V2822 (freeze (unify V2820 C V2822 (freeze (shen.th* Stream (cons stream (cons in ())) V2821 V2822 V2823))))))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2752 (shen.lazyderef V2819 V2822) (if (cons? V2752) (let V2753 (shen.lazyderef (hd V2752) V2822) (if (= set V2753) (let V2754 (shen.lazyderef (tl V2752) V2822) (if (cons? V2754) (let Var (hd V2754) (let V2755 (shen.lazyderef (tl V2754) V2822) (if (cons? V2755) (let Val (hd V2755) (let V2756 (shen.lazyderef (tl V2755) V2822) (if (= () V2756) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (shen.th* Var symbol V2821 V2822 (freeze (cut Throwcontrol V2822 (freeze (shen.th* (cons value (cons Var ())) V2820 V2821 V2822 (freeze (shen.th* Val V2820 V2821 V2822 V2823)))))))))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2757 (shen.lazyderef V2819 V2822) (if (cons? V2757) (let V2758 (shen.lazyderef (hd V2757) V2822) (if (= fail V2758) (let V2759 (shen.lazyderef (tl V2757) V2822) (if (= () V2759) (let V2760 (shen.lazyderef V2820 V2822) (if (= symbol V2760) (do (shen.incinfs) (thaw V2823)) (if (shen.pvar? V2760) (do (shen.bindv V2760 symbol V2822) (let Result (do (shen.incinfs) (thaw V2823)) (do (shen.unbindv V2760 V2822) Result))) false))) false)) false)) false)) (if (= Case false) (let Case (let NewHyp (shen.newpv V2822) (do (shen.incinfs) (shen.t*-hyps V2821 NewHyp V2822 (freeze (shen.th* V2819 V2820 NewHyp V2822 V2823))))) (if (= Case false) (let Case (let V2761 (shen.lazyderef V2819 V2822) (if (cons? V2761) (let V2762 (shen.lazyderef (hd V2761) V2822) (if (= define V2762) (let V2763 (shen.lazyderef (tl V2761) V2822) (if (cons? V2763) (let F (hd V2763) (let X (tl V2763) (do (shen.incinfs) (cut Throwcontrol V2822 (freeze (shen.t*-def (cons define (cons F X)) V2820 V2821 V2822 V2823)))))) false)) false)) false)) (if (= Case false) (let Case (let V2764 (shen.lazyderef V2819 V2822) (if (cons? V2764) (let V2765 (shen.lazyderef (hd V2764) V2822) (if (= defmacro V2765) (let V2766 (shen.lazyderef V2820 V2822) (if (= unit V2766) (do (shen.incinfs) (cut Throwcontrol V2822 V2823)) (if (shen.pvar? V2766) (do (shen.bindv V2766 unit V2822) (let Result (do (shen.incinfs) (cut Throwcontrol V2822 V2823)) (do (shen.unbindv V2766 V2822) Result))) false))) false)) false)) (if (= Case false) (let Case (let V2767 (shen.lazyderef V2819 V2822) (if (cons? V2767) (let V2768 (shen.lazyderef (hd V2767) V2822) (if (= shen.process-datatype V2768) (let V2769 (shen.lazyderef V2820 V2822) (if (= symbol V2769) (do (shen.incinfs) (thaw V2823)) (if (shen.pvar? V2769) (do (shen.bindv V2769 symbol V2822) (let Result (do (shen.incinfs) (thaw V2823)) (do (shen.unbindv V2769 V2822) Result))) false))) false)) false)) (if (= Case false) (let Case (let V2770 (shen.lazyderef V2819 V2822) (if (cons? V2770) (let V2771 (shen.lazyderef (hd V2770) V2822) (if (= shen.synonyms-help V2771) (let V2772 (shen.lazyderef V2820 V2822) (if (= symbol V2772) (do (shen.incinfs) (thaw V2823)) (if (shen.pvar? V2772) (do (shen.bindv V2772 symbol V2822) (let Result (do (shen.incinfs) (thaw V2823)) (do (shen.unbindv V2772 V2822) Result))) false))) false)) false)) (if (= Case false) (let Datatypes (shen.newpv V2822) (do (shen.incinfs) (bind Datatypes (value shen.*datatypes*) V2822 (freeze (shen.udefs* (cons V2819 (cons : (cons V2820 ()))) V2821 Datatypes V2822 V2823))))) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case)) Case))))) -(defun shen.t*-hyps (V2863 V2864 V2865 V2866) (let Case (let V2608 (shen.lazyderef V2863 V2865) (if (cons? V2608) (let V2609 (shen.lazyderef (hd V2608) V2865) (if (cons? V2609) (let V2610 (shen.lazyderef (hd V2609) V2865) (if (cons? V2610) (let V2611 (shen.lazyderef (hd V2610) V2865) (if (= cons V2611) (let V2612 (shen.lazyderef (tl V2610) V2865) (if (cons? V2612) (let X (hd V2612) (let V2613 (shen.lazyderef (tl V2612) V2865) (if (cons? V2613) (let Y (hd V2613) (let V2614 (shen.lazyderef (tl V2613) V2865) (if (= () V2614) (let V2615 (shen.lazyderef (tl V2609) V2865) (if (cons? V2615) (let V2616 (shen.lazyderef (hd V2615) V2865) (if (= : V2616) (let V2617 (shen.lazyderef (tl V2615) V2865) (if (cons? V2617) (let V2618 (shen.lazyderef (hd V2617) V2865) (if (cons? V2618) (let V2619 (shen.lazyderef (hd V2618) V2865) (if (= list V2619) (let V2620 (shen.lazyderef (tl V2618) V2865) (if (cons? V2620) (let A (hd V2620) (let V2621 (shen.lazyderef (tl V2620) V2865) (if (= () V2621) (let V2622 (shen.lazyderef (tl V2617) V2865) (if (= () V2622) (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2622) (do (shen.bindv V2622 () V2865) (let Result (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2622 V2865) Result))) false))) (if (shen.pvar? V2621) (do (shen.bindv V2621 () V2865) (let Result (let V2623 (shen.lazyderef (tl V2617) V2865) (if (= () V2623) (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2623) (do (shen.bindv V2623 () V2865) (let Result (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2623 V2865) Result))) false))) (do (shen.unbindv V2621 V2865) Result))) false)))) (if (shen.pvar? V2620) (let A (shen.newpv V2865) (do (shen.bindv V2620 (cons A ()) V2865) (let Result (let V2624 (shen.lazyderef (tl V2617) V2865) (if (= () V2624) (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2624) (do (shen.bindv V2624 () V2865) (let Result (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2624 V2865) Result))) false))) (do (shen.unbindv V2620 V2865) Result)))) false))) (if (shen.pvar? V2619) (do (shen.bindv V2619 list V2865) (let Result (let V2625 (shen.lazyderef (tl V2618) V2865) (if (cons? V2625) (let A (hd V2625) (let V2626 (shen.lazyderef (tl V2625) V2865) (if (= () V2626) (let V2627 (shen.lazyderef (tl V2617) V2865) (if (= () V2627) (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2627) (do (shen.bindv V2627 () V2865) (let Result (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2627 V2865) Result))) false))) (if (shen.pvar? V2626) (do (shen.bindv V2626 () V2865) (let Result (let V2628 (shen.lazyderef (tl V2617) V2865) (if (= () V2628) (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2628) (do (shen.bindv V2628 () V2865) (let Result (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2628 V2865) Result))) false))) (do (shen.unbindv V2626 V2865) Result))) false)))) (if (shen.pvar? V2625) (let A (shen.newpv V2865) (do (shen.bindv V2625 (cons A ()) V2865) (let Result (let V2629 (shen.lazyderef (tl V2617) V2865) (if (= () V2629) (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2629) (do (shen.bindv V2629 () V2865) (let Result (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2629 V2865) Result))) false))) (do (shen.unbindv V2625 V2865) Result)))) false))) (do (shen.unbindv V2619 V2865) Result))) false))) (if (shen.pvar? V2618) (let A (shen.newpv V2865) (do (shen.bindv V2618 (cons list (cons A ())) V2865) (let Result (let V2630 (shen.lazyderef (tl V2617) V2865) (if (= () V2630) (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2630) (do (shen.bindv V2630 () V2865) (let Result (let Hyp (tl V2608) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons list (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2630 V2865) Result))) false))) (do (shen.unbindv V2618 V2865) Result)))) false))) false)) false)) false)) false))) false))) false)) false)) false)) false)) false)) (if (= Case false) (let Case (let V2631 (shen.lazyderef V2863 V2865) (if (cons? V2631) (let V2632 (shen.lazyderef (hd V2631) V2865) (if (cons? V2632) (let V2633 (shen.lazyderef (hd V2632) V2865) (if (cons? V2633) (let V2634 (shen.lazyderef (hd V2633) V2865) (if (= @p V2634) (let V2635 (shen.lazyderef (tl V2633) V2865) (if (cons? V2635) (let X (hd V2635) (let V2636 (shen.lazyderef (tl V2635) V2865) (if (cons? V2636) (let Y (hd V2636) (let V2637 (shen.lazyderef (tl V2636) V2865) (if (= () V2637) (let V2638 (shen.lazyderef (tl V2632) V2865) (if (cons? V2638) (let V2639 (shen.lazyderef (hd V2638) V2865) (if (= : V2639) (let V2640 (shen.lazyderef (tl V2638) V2865) (if (cons? V2640) (let V2641 (shen.lazyderef (hd V2640) V2865) (if (cons? V2641) (let A (hd V2641) (let V2642 (shen.lazyderef (tl V2641) V2865) (if (cons? V2642) (let V2643 (shen.lazyderef (hd V2642) V2865) (if (= * V2643) (let V2644 (shen.lazyderef (tl V2642) V2865) (if (cons? V2644) (let B (hd V2644) (let V2645 (shen.lazyderef (tl V2644) V2865) (if (= () V2645) (let V2646 (shen.lazyderef (tl V2640) V2865) (if (= () V2646) (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2646) (do (shen.bindv V2646 () V2865) (let Result (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2646 V2865) Result))) false))) (if (shen.pvar? V2645) (do (shen.bindv V2645 () V2865) (let Result (let V2647 (shen.lazyderef (tl V2640) V2865) (if (= () V2647) (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2647) (do (shen.bindv V2647 () V2865) (let Result (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2647 V2865) Result))) false))) (do (shen.unbindv V2645 V2865) Result))) false)))) (if (shen.pvar? V2644) (let B (shen.newpv V2865) (do (shen.bindv V2644 (cons B ()) V2865) (let Result (let V2648 (shen.lazyderef (tl V2640) V2865) (if (= () V2648) (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2648) (do (shen.bindv V2648 () V2865) (let Result (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2648 V2865) Result))) false))) (do (shen.unbindv V2644 V2865) Result)))) false))) (if (shen.pvar? V2643) (do (shen.bindv V2643 * V2865) (let Result (let V2649 (shen.lazyderef (tl V2642) V2865) (if (cons? V2649) (let B (hd V2649) (let V2650 (shen.lazyderef (tl V2649) V2865) (if (= () V2650) (let V2651 (shen.lazyderef (tl V2640) V2865) (if (= () V2651) (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2651) (do (shen.bindv V2651 () V2865) (let Result (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2651 V2865) Result))) false))) (if (shen.pvar? V2650) (do (shen.bindv V2650 () V2865) (let Result (let V2652 (shen.lazyderef (tl V2640) V2865) (if (= () V2652) (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2652) (do (shen.bindv V2652 () V2865) (let Result (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2652 V2865) Result))) false))) (do (shen.unbindv V2650 V2865) Result))) false)))) (if (shen.pvar? V2649) (let B (shen.newpv V2865) (do (shen.bindv V2649 (cons B ()) V2865) (let Result (let V2653 (shen.lazyderef (tl V2640) V2865) (if (= () V2653) (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2653) (do (shen.bindv V2653 () V2865) (let Result (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2653 V2865) Result))) false))) (do (shen.unbindv V2649 V2865) Result)))) false))) (do (shen.unbindv V2643 V2865) Result))) false))) (if (shen.pvar? V2642) (let B (shen.newpv V2865) (do (shen.bindv V2642 (cons * (cons B ())) V2865) (let Result (let V2654 (shen.lazyderef (tl V2640) V2865) (if (= () V2654) (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2654) (do (shen.bindv V2654 () V2865) (let Result (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2654 V2865) Result))) false))) (do (shen.unbindv V2642 V2865) Result)))) false)))) (if (shen.pvar? V2641) (let A (shen.newpv V2865) (let B (shen.newpv V2865) (do (shen.bindv V2641 (cons A (cons * (cons B ()))) V2865) (let Result (let V2655 (shen.lazyderef (tl V2640) V2865) (if (= () V2655) (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2655) (do (shen.bindv V2655 () V2865) (let Result (let Hyp (tl V2631) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (shen.lazyderef B V2865) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2655 V2865) Result))) false))) (do (shen.unbindv V2641 V2865) Result))))) false))) false)) false)) false)) false))) false))) false)) false)) false)) false)) false)) (if (= Case false) (let Case (let V2656 (shen.lazyderef V2863 V2865) (if (cons? V2656) (let V2657 (shen.lazyderef (hd V2656) V2865) (if (cons? V2657) (let V2658 (shen.lazyderef (hd V2657) V2865) (if (cons? V2658) (let V2659 (shen.lazyderef (hd V2658) V2865) (if (= @v V2659) (let V2660 (shen.lazyderef (tl V2658) V2865) (if (cons? V2660) (let X (hd V2660) (let V2661 (shen.lazyderef (tl V2660) V2865) (if (cons? V2661) (let Y (hd V2661) (let V2662 (shen.lazyderef (tl V2661) V2865) (if (= () V2662) (let V2663 (shen.lazyderef (tl V2657) V2865) (if (cons? V2663) (let V2664 (shen.lazyderef (hd V2663) V2865) (if (= : V2664) (let V2665 (shen.lazyderef (tl V2663) V2865) (if (cons? V2665) (let V2666 (shen.lazyderef (hd V2665) V2865) (if (cons? V2666) (let V2667 (shen.lazyderef (hd V2666) V2865) (if (= vector V2667) (let V2668 (shen.lazyderef (tl V2666) V2865) (if (cons? V2668) (let A (hd V2668) (let V2669 (shen.lazyderef (tl V2668) V2865) (if (= () V2669) (let V2670 (shen.lazyderef (tl V2665) V2865) (if (= () V2670) (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2670) (do (shen.bindv V2670 () V2865) (let Result (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2670 V2865) Result))) false))) (if (shen.pvar? V2669) (do (shen.bindv V2669 () V2865) (let Result (let V2671 (shen.lazyderef (tl V2665) V2865) (if (= () V2671) (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2671) (do (shen.bindv V2671 () V2865) (let Result (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2671 V2865) Result))) false))) (do (shen.unbindv V2669 V2865) Result))) false)))) (if (shen.pvar? V2668) (let A (shen.newpv V2865) (do (shen.bindv V2668 (cons A ()) V2865) (let Result (let V2672 (shen.lazyderef (tl V2665) V2865) (if (= () V2672) (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2672) (do (shen.bindv V2672 () V2865) (let Result (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2672 V2865) Result))) false))) (do (shen.unbindv V2668 V2865) Result)))) false))) (if (shen.pvar? V2667) (do (shen.bindv V2667 vector V2865) (let Result (let V2673 (shen.lazyderef (tl V2666) V2865) (if (cons? V2673) (let A (hd V2673) (let V2674 (shen.lazyderef (tl V2673) V2865) (if (= () V2674) (let V2675 (shen.lazyderef (tl V2665) V2865) (if (= () V2675) (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2675) (do (shen.bindv V2675 () V2865) (let Result (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2675 V2865) Result))) false))) (if (shen.pvar? V2674) (do (shen.bindv V2674 () V2865) (let Result (let V2676 (shen.lazyderef (tl V2665) V2865) (if (= () V2676) (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2676) (do (shen.bindv V2676 () V2865) (let Result (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2676 V2865) Result))) false))) (do (shen.unbindv V2674 V2865) Result))) false)))) (if (shen.pvar? V2673) (let A (shen.newpv V2865) (do (shen.bindv V2673 (cons A ()) V2865) (let Result (let V2677 (shen.lazyderef (tl V2665) V2865) (if (= () V2677) (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2677) (do (shen.bindv V2677 () V2865) (let Result (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2677 V2865) Result))) false))) (do (shen.unbindv V2673 V2865) Result)))) false))) (do (shen.unbindv V2667 V2865) Result))) false))) (if (shen.pvar? V2666) (let A (shen.newpv V2865) (do (shen.bindv V2666 (cons vector (cons A ())) V2865) (let Result (let V2678 (shen.lazyderef (tl V2665) V2865) (if (= () V2678) (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2678) (do (shen.bindv V2678 () V2865) (let Result (let Hyp (tl V2656) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons (shen.lazyderef A V2865) ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons (cons vector (cons (shen.lazyderef A V2865) ())) ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2678 V2865) Result))) false))) (do (shen.unbindv V2666 V2865) Result)))) false))) false)) false)) false)) false))) false))) false)) false)) false)) false)) false)) (if (= Case false) (let Case (let V2679 (shen.lazyderef V2863 V2865) (if (cons? V2679) (let V2680 (shen.lazyderef (hd V2679) V2865) (if (cons? V2680) (let V2681 (shen.lazyderef (hd V2680) V2865) (if (cons? V2681) (let V2682 (shen.lazyderef (hd V2681) V2865) (if (= @s V2682) (let V2683 (shen.lazyderef (tl V2681) V2865) (if (cons? V2683) (let X (hd V2683) (let V2684 (shen.lazyderef (tl V2683) V2865) (if (cons? V2684) (let Y (hd V2684) (let V2685 (shen.lazyderef (tl V2684) V2865) (if (= () V2685) (let V2686 (shen.lazyderef (tl V2680) V2865) (if (cons? V2686) (let V2687 (shen.lazyderef (hd V2686) V2865) (if (= : V2687) (let V2688 (shen.lazyderef (tl V2686) V2865) (if (cons? V2688) (let V2689 (shen.lazyderef (hd V2688) V2865) (if (= string V2689) (let V2690 (shen.lazyderef (tl V2688) V2865) (if (= () V2690) (let Hyp (tl V2679) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons string ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons string ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2690) (do (shen.bindv V2690 () V2865) (let Result (let Hyp (tl V2679) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons string ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons string ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2690 V2865) Result))) false))) (if (shen.pvar? V2689) (do (shen.bindv V2689 string V2865) (let Result (let V2691 (shen.lazyderef (tl V2688) V2865) (if (= () V2691) (let Hyp (tl V2679) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons string ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons string ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (if (shen.pvar? V2691) (do (shen.bindv V2691 () V2865) (let Result (let Hyp (tl V2679) (do (shen.incinfs) (bind V2864 (cons (cons (shen.lazyderef X V2865) (cons : (cons string ()))) (cons (cons (shen.lazyderef Y V2865) (cons : (cons string ()))) (shen.lazyderef Hyp V2865))) V2865 V2866))) (do (shen.unbindv V2691 V2865) Result))) false))) (do (shen.unbindv V2689 V2865) Result))) false))) false)) false)) false)) false))) false))) false)) false)) false)) false)) false)) (if (= Case false) (let V2692 (shen.lazyderef V2863 V2865) (if (cons? V2692) (let X (hd V2692) (let Hyp (tl V2692) (let NewHyps (shen.newpv V2865) (do (shen.incinfs) (bind V2864 (cons (shen.lazyderef X V2865) (shen.lazyderef NewHyps V2865)) V2865 (freeze (shen.t*-hyps Hyp NewHyps V2865 V2866))))))) false)) Case)) Case)) Case)) Case))) +(defun shen.t*-hyps (V2824 V2825 V2826 V2827) (let Case (let V2579 (shen.lazyderef V2824 V2826) (if (cons? V2579) (let V2580 (shen.lazyderef (hd V2579) V2826) (if (cons? V2580) (let V2581 (shen.lazyderef (hd V2580) V2826) (if (cons? V2581) (let V2582 (shen.lazyderef (hd V2581) V2826) (if (= cons V2582) (let V2583 (shen.lazyderef (tl V2581) V2826) (if (cons? V2583) (let X (hd V2583) (let V2584 (shen.lazyderef (tl V2583) V2826) (if (cons? V2584) (let Y (hd V2584) (let V2585 (shen.lazyderef (tl V2584) V2826) (if (= () V2585) (let V2586 (shen.lazyderef (tl V2580) V2826) (if (cons? V2586) (let V2587 (shen.lazyderef (hd V2586) V2826) (if (= : V2587) (let V2588 (shen.lazyderef (tl V2586) V2826) (if (cons? V2588) (let V2589 (shen.lazyderef (hd V2588) V2826) (if (cons? V2589) (let V2590 (shen.lazyderef (hd V2589) V2826) (if (= list V2590) (let V2591 (shen.lazyderef (tl V2589) V2826) (if (cons? V2591) (let A (hd V2591) (let V2592 (shen.lazyderef (tl V2591) V2826) (if (= () V2592) (let V2593 (shen.lazyderef (tl V2588) V2826) (if (= () V2593) (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2593) (do (shen.bindv V2593 () V2826) (let Result (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2593 V2826) Result))) false))) (if (shen.pvar? V2592) (do (shen.bindv V2592 () V2826) (let Result (let V2594 (shen.lazyderef (tl V2588) V2826) (if (= () V2594) (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2594) (do (shen.bindv V2594 () V2826) (let Result (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2594 V2826) Result))) false))) (do (shen.unbindv V2592 V2826) Result))) false)))) (if (shen.pvar? V2591) (let A (shen.newpv V2826) (do (shen.bindv V2591 (cons A ()) V2826) (let Result (let V2595 (shen.lazyderef (tl V2588) V2826) (if (= () V2595) (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2595) (do (shen.bindv V2595 () V2826) (let Result (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2595 V2826) Result))) false))) (do (shen.unbindv V2591 V2826) Result)))) false))) (if (shen.pvar? V2590) (do (shen.bindv V2590 list V2826) (let Result (let V2596 (shen.lazyderef (tl V2589) V2826) (if (cons? V2596) (let A (hd V2596) (let V2597 (shen.lazyderef (tl V2596) V2826) (if (= () V2597) (let V2598 (shen.lazyderef (tl V2588) V2826) (if (= () V2598) (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2598) (do (shen.bindv V2598 () V2826) (let Result (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2598 V2826) Result))) false))) (if (shen.pvar? V2597) (do (shen.bindv V2597 () V2826) (let Result (let V2599 (shen.lazyderef (tl V2588) V2826) (if (= () V2599) (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2599) (do (shen.bindv V2599 () V2826) (let Result (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2599 V2826) Result))) false))) (do (shen.unbindv V2597 V2826) Result))) false)))) (if (shen.pvar? V2596) (let A (shen.newpv V2826) (do (shen.bindv V2596 (cons A ()) V2826) (let Result (let V2600 (shen.lazyderef (tl V2588) V2826) (if (= () V2600) (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2600) (do (shen.bindv V2600 () V2826) (let Result (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2600 V2826) Result))) false))) (do (shen.unbindv V2596 V2826) Result)))) false))) (do (shen.unbindv V2590 V2826) Result))) false))) (if (shen.pvar? V2589) (let A (shen.newpv V2826) (do (shen.bindv V2589 (cons list (cons A ())) V2826) (let Result (let V2601 (shen.lazyderef (tl V2588) V2826) (if (= () V2601) (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2601) (do (shen.bindv V2601 () V2826) (let Result (let Hyp (tl V2579) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons list (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2601 V2826) Result))) false))) (do (shen.unbindv V2589 V2826) Result)))) false))) false)) false)) false)) false))) false))) false)) false)) false)) false)) false)) (if (= Case false) (let Case (let V2602 (shen.lazyderef V2824 V2826) (if (cons? V2602) (let V2603 (shen.lazyderef (hd V2602) V2826) (if (cons? V2603) (let V2604 (shen.lazyderef (hd V2603) V2826) (if (cons? V2604) (let V2605 (shen.lazyderef (hd V2604) V2826) (if (= @p V2605) (let V2606 (shen.lazyderef (tl V2604) V2826) (if (cons? V2606) (let X (hd V2606) (let V2607 (shen.lazyderef (tl V2606) V2826) (if (cons? V2607) (let Y (hd V2607) (let V2608 (shen.lazyderef (tl V2607) V2826) (if (= () V2608) (let V2609 (shen.lazyderef (tl V2603) V2826) (if (cons? V2609) (let V2610 (shen.lazyderef (hd V2609) V2826) (if (= : V2610) (let V2611 (shen.lazyderef (tl V2609) V2826) (if (cons? V2611) (let V2612 (shen.lazyderef (hd V2611) V2826) (if (cons? V2612) (let A (hd V2612) (let V2613 (shen.lazyderef (tl V2612) V2826) (if (cons? V2613) (let V2614 (shen.lazyderef (hd V2613) V2826) (if (= * V2614) (let V2615 (shen.lazyderef (tl V2613) V2826) (if (cons? V2615) (let B (hd V2615) (let V2616 (shen.lazyderef (tl V2615) V2826) (if (= () V2616) (let V2617 (shen.lazyderef (tl V2611) V2826) (if (= () V2617) (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2617) (do (shen.bindv V2617 () V2826) (let Result (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2617 V2826) Result))) false))) (if (shen.pvar? V2616) (do (shen.bindv V2616 () V2826) (let Result (let V2618 (shen.lazyderef (tl V2611) V2826) (if (= () V2618) (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2618) (do (shen.bindv V2618 () V2826) (let Result (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2618 V2826) Result))) false))) (do (shen.unbindv V2616 V2826) Result))) false)))) (if (shen.pvar? V2615) (let B (shen.newpv V2826) (do (shen.bindv V2615 (cons B ()) V2826) (let Result (let V2619 (shen.lazyderef (tl V2611) V2826) (if (= () V2619) (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2619) (do (shen.bindv V2619 () V2826) (let Result (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2619 V2826) Result))) false))) (do (shen.unbindv V2615 V2826) Result)))) false))) (if (shen.pvar? V2614) (do (shen.bindv V2614 * V2826) (let Result (let V2620 (shen.lazyderef (tl V2613) V2826) (if (cons? V2620) (let B (hd V2620) (let V2621 (shen.lazyderef (tl V2620) V2826) (if (= () V2621) (let V2622 (shen.lazyderef (tl V2611) V2826) (if (= () V2622) (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2622) (do (shen.bindv V2622 () V2826) (let Result (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2622 V2826) Result))) false))) (if (shen.pvar? V2621) (do (shen.bindv V2621 () V2826) (let Result (let V2623 (shen.lazyderef (tl V2611) V2826) (if (= () V2623) (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2623) (do (shen.bindv V2623 () V2826) (let Result (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2623 V2826) Result))) false))) (do (shen.unbindv V2621 V2826) Result))) false)))) (if (shen.pvar? V2620) (let B (shen.newpv V2826) (do (shen.bindv V2620 (cons B ()) V2826) (let Result (let V2624 (shen.lazyderef (tl V2611) V2826) (if (= () V2624) (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2624) (do (shen.bindv V2624 () V2826) (let Result (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2624 V2826) Result))) false))) (do (shen.unbindv V2620 V2826) Result)))) false))) (do (shen.unbindv V2614 V2826) Result))) false))) (if (shen.pvar? V2613) (let B (shen.newpv V2826) (do (shen.bindv V2613 (cons * (cons B ())) V2826) (let Result (let V2625 (shen.lazyderef (tl V2611) V2826) (if (= () V2625) (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2625) (do (shen.bindv V2625 () V2826) (let Result (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2625 V2826) Result))) false))) (do (shen.unbindv V2613 V2826) Result)))) false)))) (if (shen.pvar? V2612) (let A (shen.newpv V2826) (let B (shen.newpv V2826) (do (shen.bindv V2612 (cons A (cons * (cons B ()))) V2826) (let Result (let V2626 (shen.lazyderef (tl V2611) V2826) (if (= () V2626) (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2626) (do (shen.bindv V2626 () V2826) (let Result (let Hyp (tl V2602) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (shen.lazyderef B V2826) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2626 V2826) Result))) false))) (do (shen.unbindv V2612 V2826) Result))))) false))) false)) false)) false)) false))) false))) false)) false)) false)) false)) false)) (if (= Case false) (let Case (let V2627 (shen.lazyderef V2824 V2826) (if (cons? V2627) (let V2628 (shen.lazyderef (hd V2627) V2826) (if (cons? V2628) (let V2629 (shen.lazyderef (hd V2628) V2826) (if (cons? V2629) (let V2630 (shen.lazyderef (hd V2629) V2826) (if (= @v V2630) (let V2631 (shen.lazyderef (tl V2629) V2826) (if (cons? V2631) (let X (hd V2631) (let V2632 (shen.lazyderef (tl V2631) V2826) (if (cons? V2632) (let Y (hd V2632) (let V2633 (shen.lazyderef (tl V2632) V2826) (if (= () V2633) (let V2634 (shen.lazyderef (tl V2628) V2826) (if (cons? V2634) (let V2635 (shen.lazyderef (hd V2634) V2826) (if (= : V2635) (let V2636 (shen.lazyderef (tl V2634) V2826) (if (cons? V2636) (let V2637 (shen.lazyderef (hd V2636) V2826) (if (cons? V2637) (let V2638 (shen.lazyderef (hd V2637) V2826) (if (= vector V2638) (let V2639 (shen.lazyderef (tl V2637) V2826) (if (cons? V2639) (let A (hd V2639) (let V2640 (shen.lazyderef (tl V2639) V2826) (if (= () V2640) (let V2641 (shen.lazyderef (tl V2636) V2826) (if (= () V2641) (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2641) (do (shen.bindv V2641 () V2826) (let Result (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2641 V2826) Result))) false))) (if (shen.pvar? V2640) (do (shen.bindv V2640 () V2826) (let Result (let V2642 (shen.lazyderef (tl V2636) V2826) (if (= () V2642) (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2642) (do (shen.bindv V2642 () V2826) (let Result (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2642 V2826) Result))) false))) (do (shen.unbindv V2640 V2826) Result))) false)))) (if (shen.pvar? V2639) (let A (shen.newpv V2826) (do (shen.bindv V2639 (cons A ()) V2826) (let Result (let V2643 (shen.lazyderef (tl V2636) V2826) (if (= () V2643) (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2643) (do (shen.bindv V2643 () V2826) (let Result (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2643 V2826) Result))) false))) (do (shen.unbindv V2639 V2826) Result)))) false))) (if (shen.pvar? V2638) (do (shen.bindv V2638 vector V2826) (let Result (let V2644 (shen.lazyderef (tl V2637) V2826) (if (cons? V2644) (let A (hd V2644) (let V2645 (shen.lazyderef (tl V2644) V2826) (if (= () V2645) (let V2646 (shen.lazyderef (tl V2636) V2826) (if (= () V2646) (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2646) (do (shen.bindv V2646 () V2826) (let Result (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2646 V2826) Result))) false))) (if (shen.pvar? V2645) (do (shen.bindv V2645 () V2826) (let Result (let V2647 (shen.lazyderef (tl V2636) V2826) (if (= () V2647) (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2647) (do (shen.bindv V2647 () V2826) (let Result (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2647 V2826) Result))) false))) (do (shen.unbindv V2645 V2826) Result))) false)))) (if (shen.pvar? V2644) (let A (shen.newpv V2826) (do (shen.bindv V2644 (cons A ()) V2826) (let Result (let V2648 (shen.lazyderef (tl V2636) V2826) (if (= () V2648) (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2648) (do (shen.bindv V2648 () V2826) (let Result (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2648 V2826) Result))) false))) (do (shen.unbindv V2644 V2826) Result)))) false))) (do (shen.unbindv V2638 V2826) Result))) false))) (if (shen.pvar? V2637) (let A (shen.newpv V2826) (do (shen.bindv V2637 (cons vector (cons A ())) V2826) (let Result (let V2649 (shen.lazyderef (tl V2636) V2826) (if (= () V2649) (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2649) (do (shen.bindv V2649 () V2826) (let Result (let Hyp (tl V2627) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons (shen.lazyderef A V2826) ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons (cons vector (cons (shen.lazyderef A V2826) ())) ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2649 V2826) Result))) false))) (do (shen.unbindv V2637 V2826) Result)))) false))) false)) false)) false)) false))) false))) false)) false)) false)) false)) false)) (if (= Case false) (let Case (let V2650 (shen.lazyderef V2824 V2826) (if (cons? V2650) (let V2651 (shen.lazyderef (hd V2650) V2826) (if (cons? V2651) (let V2652 (shen.lazyderef (hd V2651) V2826) (if (cons? V2652) (let V2653 (shen.lazyderef (hd V2652) V2826) (if (= @s V2653) (let V2654 (shen.lazyderef (tl V2652) V2826) (if (cons? V2654) (let X (hd V2654) (let V2655 (shen.lazyderef (tl V2654) V2826) (if (cons? V2655) (let Y (hd V2655) (let V2656 (shen.lazyderef (tl V2655) V2826) (if (= () V2656) (let V2657 (shen.lazyderef (tl V2651) V2826) (if (cons? V2657) (let V2658 (shen.lazyderef (hd V2657) V2826) (if (= : V2658) (let V2659 (shen.lazyderef (tl V2657) V2826) (if (cons? V2659) (let V2660 (shen.lazyderef (hd V2659) V2826) (if (= string V2660) (let V2661 (shen.lazyderef (tl V2659) V2826) (if (= () V2661) (let Hyp (tl V2650) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons string ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons string ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2661) (do (shen.bindv V2661 () V2826) (let Result (let Hyp (tl V2650) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons string ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons string ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2661 V2826) Result))) false))) (if (shen.pvar? V2660) (do (shen.bindv V2660 string V2826) (let Result (let V2662 (shen.lazyderef (tl V2659) V2826) (if (= () V2662) (let Hyp (tl V2650) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons string ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons string ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (if (shen.pvar? V2662) (do (shen.bindv V2662 () V2826) (let Result (let Hyp (tl V2650) (do (shen.incinfs) (bind V2825 (cons (cons (shen.lazyderef X V2826) (cons : (cons string ()))) (cons (cons (shen.lazyderef Y V2826) (cons : (cons string ()))) (shen.lazyderef Hyp V2826))) V2826 V2827))) (do (shen.unbindv V2662 V2826) Result))) false))) (do (shen.unbindv V2660 V2826) Result))) false))) false)) false)) false)) false))) false))) false)) false)) false)) false)) false)) (if (= Case false) (let V2663 (shen.lazyderef V2824 V2826) (if (cons? V2663) (let X (hd V2663) (let Hyp (tl V2663) (let NewHyps (shen.newpv V2826) (do (shen.incinfs) (bind V2825 (cons (shen.lazyderef X V2826) (shen.lazyderef NewHyps V2826)) V2826 (freeze (shen.t*-hyps Hyp NewHyps V2826 V2827))))))) false)) Case)) Case)) Case)) Case))) -(defun shen.show (V2879 V2880 V2881 V2882) (cond ((value shen.*spy*) (do (shen.line) (do (shen.show-p (shen.deref V2879 V2881)) (do (nl 1) (do (nl 1) (do (shen.show-assumptions (shen.deref V2880 V2881) 1) (do (shen.prhush " -> " (stoutput)) (do (shen.pause-for-user) (thaw V2882))))))))) (true (thaw V2882)))) +(defun shen.show (V2840 V2841 V2842 V2843) (cond ((value shen.*spy*) (do (shen.line) (do (shen.show-p (shen.deref V2840 V2842)) (do (nl 1) (do (nl 1) (do (shen.show-assumptions (shen.deref V2841 V2842) 1) (do (shen.prhush " +> " (stoutput)) (do (shen.pause-for-user) (thaw V2843))))))))) (true (thaw V2843)))) (defun shen.line () (let Infs (inferences) (shen.prhush (cn "____________________________________________________________ " (shen.app Infs (cn " inference" (shen.app (if (= 1 Infs) "" "s") " ?- " shen.a)) shen.a)) (stoutput)))) -(defun shen.show-p (V2883) (cond ((and (cons? V2883) (and (cons? (tl V2883)) (and (= : (hd (tl V2883))) (and (cons? (tl (tl V2883))) (= () (tl (tl (tl V2883)))))))) (shen.prhush (shen.app (hd V2883) (cn " : " (shen.app (hd (tl (tl V2883))) "" shen.r)) shen.r) (stoutput))) (true (shen.prhush (shen.app V2883 "" shen.r) (stoutput))))) +(defun shen.show-p (V2844) (cond ((and (cons? V2844) (and (cons? (tl V2844)) (and (= : (hd (tl V2844))) (and (cons? (tl (tl V2844))) (= () (tl (tl (tl V2844)))))))) (shen.prhush (shen.app (hd V2844) (cn " : " (shen.app (hd (tl (tl V2844))) "" shen.r)) shen.r) (stoutput))) (true (shen.prhush (shen.app V2844 "" shen.r) (stoutput))))) -(defun shen.show-assumptions (V2886 V2887) (cond ((= () V2886) shen.skip) ((cons? V2886) (do (shen.prhush (shen.app V2887 ". " shen.a) (stoutput)) (do (shen.show-p (hd V2886)) (do (nl 1) (shen.show-assumptions (tl V2886) (+ V2887 1)))))) (true (shen.sys-error shen.show-assumptions)))) +(defun shen.show-assumptions (V2847 V2848) (cond ((= () V2847) shen.skip) ((cons? V2847) (do (shen.prhush (shen.app V2848 ". " shen.a) (stoutput)) (do (shen.show-p (hd V2847)) (do (nl 1) (shen.show-assumptions (tl V2847) (+ V2848 1)))))) (true (shen.sys-error shen.show-assumptions)))) (defun shen.pause-for-user () (let Byte (read-byte (stinput)) (if (= Byte 94) (simple-error "input aborted ") (nl 1)))) -(defun shen.typedf? (V2888) (cons? (assoc V2888 (value shen.*signedfuncs*)))) +(defun shen.typedf? (V2849) (cons? (assoc V2849 (value shen.*signedfuncs*)))) -(defun shen.sigf (V2889) (concat shen.type-signature-of- V2889)) +(defun shen.sigf (V2850) (concat shen.type-signature-of- V2850)) (defun shen.placeholder () (gensym &&)) -(defun shen.base (V2890 V2891 V2892 V2893) (let Case (let V2595 (shen.lazyderef V2891 V2892) (if (= number V2595) (do (shen.incinfs) (fwhen (number? (shen.lazyderef V2890 V2892)) V2892 V2893)) (if (shen.pvar? V2595) (do (shen.bindv V2595 number V2892) (let Result (do (shen.incinfs) (fwhen (number? (shen.lazyderef V2890 V2892)) V2892 V2893)) (do (shen.unbindv V2595 V2892) Result))) false))) (if (= Case false) (let Case (let V2596 (shen.lazyderef V2891 V2892) (if (= boolean V2596) (do (shen.incinfs) (fwhen (boolean? (shen.lazyderef V2890 V2892)) V2892 V2893)) (if (shen.pvar? V2596) (do (shen.bindv V2596 boolean V2892) (let Result (do (shen.incinfs) (fwhen (boolean? (shen.lazyderef V2890 V2892)) V2892 V2893)) (do (shen.unbindv V2596 V2892) Result))) false))) (if (= Case false) (let Case (let V2597 (shen.lazyderef V2891 V2892) (if (= string V2597) (do (shen.incinfs) (fwhen (string? (shen.lazyderef V2890 V2892)) V2892 V2893)) (if (shen.pvar? V2597) (do (shen.bindv V2597 string V2892) (let Result (do (shen.incinfs) (fwhen (string? (shen.lazyderef V2890 V2892)) V2892 V2893)) (do (shen.unbindv V2597 V2892) Result))) false))) (if (= Case false) (let Case (let V2598 (shen.lazyderef V2891 V2892) (if (= symbol V2598) (do (shen.incinfs) (fwhen (symbol? (shen.lazyderef V2890 V2892)) V2892 (freeze (fwhen (not (shen.ue? (shen.lazyderef V2890 V2892))) V2892 V2893)))) (if (shen.pvar? V2598) (do (shen.bindv V2598 symbol V2892) (let Result (do (shen.incinfs) (fwhen (symbol? (shen.lazyderef V2890 V2892)) V2892 (freeze (fwhen (not (shen.ue? (shen.lazyderef V2890 V2892))) V2892 V2893)))) (do (shen.unbindv V2598 V2892) Result))) false))) (if (= Case false) (let V2599 (shen.lazyderef V2890 V2892) (if (= () V2599) (let V2600 (shen.lazyderef V2891 V2892) (if (cons? V2600) (let V2601 (shen.lazyderef (hd V2600) V2892) (if (= list V2601) (let V2602 (shen.lazyderef (tl V2600) V2892) (if (cons? V2602) (let A (hd V2602) (let V2603 (shen.lazyderef (tl V2602) V2892) (if (= () V2603) (do (shen.incinfs) (thaw V2893)) (if (shen.pvar? V2603) (do (shen.bindv V2603 () V2892) (let Result (do (shen.incinfs) (thaw V2893)) (do (shen.unbindv V2603 V2892) Result))) false)))) (if (shen.pvar? V2602) (let A (shen.newpv V2892) (do (shen.bindv V2602 (cons A ()) V2892) (let Result (do (shen.incinfs) (thaw V2893)) (do (shen.unbindv V2602 V2892) Result)))) false))) (if (shen.pvar? V2601) (do (shen.bindv V2601 list V2892) (let Result (let V2604 (shen.lazyderef (tl V2600) V2892) (if (cons? V2604) (let A (hd V2604) (let V2605 (shen.lazyderef (tl V2604) V2892) (if (= () V2605) (do (shen.incinfs) (thaw V2893)) (if (shen.pvar? V2605) (do (shen.bindv V2605 () V2892) (let Result (do (shen.incinfs) (thaw V2893)) (do (shen.unbindv V2605 V2892) Result))) false)))) (if (shen.pvar? V2604) (let A (shen.newpv V2892) (do (shen.bindv V2604 (cons A ()) V2892) (let Result (do (shen.incinfs) (thaw V2893)) (do (shen.unbindv V2604 V2892) Result)))) false))) (do (shen.unbindv V2601 V2892) Result))) false))) (if (shen.pvar? V2600) (let A (shen.newpv V2892) (do (shen.bindv V2600 (cons list (cons A ())) V2892) (let Result (do (shen.incinfs) (thaw V2893)) (do (shen.unbindv V2600 V2892) Result)))) false))) false)) Case)) Case)) Case)) Case))) +(defun shen.base (V2851 V2852 V2853 V2854) (let Case (let V2566 (shen.lazyderef V2852 V2853) (if (= number V2566) (do (shen.incinfs) (fwhen (number? (shen.lazyderef V2851 V2853)) V2853 V2854)) (if (shen.pvar? V2566) (do (shen.bindv V2566 number V2853) (let Result (do (shen.incinfs) (fwhen (number? (shen.lazyderef V2851 V2853)) V2853 V2854)) (do (shen.unbindv V2566 V2853) Result))) false))) (if (= Case false) (let Case (let V2567 (shen.lazyderef V2852 V2853) (if (= boolean V2567) (do (shen.incinfs) (fwhen (boolean? (shen.lazyderef V2851 V2853)) V2853 V2854)) (if (shen.pvar? V2567) (do (shen.bindv V2567 boolean V2853) (let Result (do (shen.incinfs) (fwhen (boolean? (shen.lazyderef V2851 V2853)) V2853 V2854)) (do (shen.unbindv V2567 V2853) Result))) false))) (if (= Case false) (let Case (let V2568 (shen.lazyderef V2852 V2853) (if (= string V2568) (do (shen.incinfs) (fwhen (string? (shen.lazyderef V2851 V2853)) V2853 V2854)) (if (shen.pvar? V2568) (do (shen.bindv V2568 string V2853) (let Result (do (shen.incinfs) (fwhen (string? (shen.lazyderef V2851 V2853)) V2853 V2854)) (do (shen.unbindv V2568 V2853) Result))) false))) (if (= Case false) (let Case (let V2569 (shen.lazyderef V2852 V2853) (if (= symbol V2569) (do (shen.incinfs) (fwhen (symbol? (shen.lazyderef V2851 V2853)) V2853 (freeze (fwhen (not (shen.ue? (shen.lazyderef V2851 V2853))) V2853 V2854)))) (if (shen.pvar? V2569) (do (shen.bindv V2569 symbol V2853) (let Result (do (shen.incinfs) (fwhen (symbol? (shen.lazyderef V2851 V2853)) V2853 (freeze (fwhen (not (shen.ue? (shen.lazyderef V2851 V2853))) V2853 V2854)))) (do (shen.unbindv V2569 V2853) Result))) false))) (if (= Case false) (let V2570 (shen.lazyderef V2851 V2853) (if (= () V2570) (let V2571 (shen.lazyderef V2852 V2853) (if (cons? V2571) (let V2572 (shen.lazyderef (hd V2571) V2853) (if (= list V2572) (let V2573 (shen.lazyderef (tl V2571) V2853) (if (cons? V2573) (let A (hd V2573) (let V2574 (shen.lazyderef (tl V2573) V2853) (if (= () V2574) (do (shen.incinfs) (thaw V2854)) (if (shen.pvar? V2574) (do (shen.bindv V2574 () V2853) (let Result (do (shen.incinfs) (thaw V2854)) (do (shen.unbindv V2574 V2853) Result))) false)))) (if (shen.pvar? V2573) (let A (shen.newpv V2853) (do (shen.bindv V2573 (cons A ()) V2853) (let Result (do (shen.incinfs) (thaw V2854)) (do (shen.unbindv V2573 V2853) Result)))) false))) (if (shen.pvar? V2572) (do (shen.bindv V2572 list V2853) (let Result (let V2575 (shen.lazyderef (tl V2571) V2853) (if (cons? V2575) (let A (hd V2575) (let V2576 (shen.lazyderef (tl V2575) V2853) (if (= () V2576) (do (shen.incinfs) (thaw V2854)) (if (shen.pvar? V2576) (do (shen.bindv V2576 () V2853) (let Result (do (shen.incinfs) (thaw V2854)) (do (shen.unbindv V2576 V2853) Result))) false)))) (if (shen.pvar? V2575) (let A (shen.newpv V2853) (do (shen.bindv V2575 (cons A ()) V2853) (let Result (do (shen.incinfs) (thaw V2854)) (do (shen.unbindv V2575 V2853) Result)))) false))) (do (shen.unbindv V2572 V2853) Result))) false))) (if (shen.pvar? V2571) (let A (shen.newpv V2853) (do (shen.bindv V2571 (cons list (cons A ())) V2853) (let Result (do (shen.incinfs) (thaw V2854)) (do (shen.unbindv V2571 V2853) Result)))) false))) false)) Case)) Case)) Case)) Case))) -(defun shen.by_hypothesis (V2894 V2895 V2896 V2897 V2898) (let Case (let V2586 (shen.lazyderef V2896 V2897) (if (cons? V2586) (let V2587 (shen.lazyderef (hd V2586) V2897) (if (cons? V2587) (let Y (hd V2587) (let V2588 (shen.lazyderef (tl V2587) V2897) (if (cons? V2588) (let V2589 (shen.lazyderef (hd V2588) V2897) (if (= : V2589) (let V2590 (shen.lazyderef (tl V2588) V2897) (if (cons? V2590) (let B (hd V2590) (let V2591 (shen.lazyderef (tl V2590) V2897) (if (= () V2591) (do (shen.incinfs) (identical V2894 Y V2897 (freeze (unify! V2895 B V2897 V2898)))) false))) false)) false)) false))) false)) false)) (if (= Case false) (let V2592 (shen.lazyderef V2896 V2897) (if (cons? V2592) (let Hyp (tl V2592) (do (shen.incinfs) (shen.by_hypothesis V2894 V2895 Hyp V2897 V2898))) false)) Case))) +(defun shen.by_hypothesis (V2855 V2856 V2857 V2858 V2859) (let Case (let V2557 (shen.lazyderef V2857 V2858) (if (cons? V2557) (let V2558 (shen.lazyderef (hd V2557) V2858) (if (cons? V2558) (let Y (hd V2558) (let V2559 (shen.lazyderef (tl V2558) V2858) (if (cons? V2559) (let V2560 (shen.lazyderef (hd V2559) V2858) (if (= : V2560) (let V2561 (shen.lazyderef (tl V2559) V2858) (if (cons? V2561) (let B (hd V2561) (let V2562 (shen.lazyderef (tl V2561) V2858) (if (= () V2562) (do (shen.incinfs) (identical V2855 Y V2858 (freeze (unify! V2856 B V2858 V2859)))) false))) false)) false)) false))) false)) false)) (if (= Case false) (let V2563 (shen.lazyderef V2857 V2858) (if (cons? V2563) (let Hyp (tl V2563) (do (shen.incinfs) (shen.by_hypothesis V2855 V2856 Hyp V2858 V2859))) false)) Case))) -(defun shen.t*-def (V2899 V2900 V2901 V2902 V2903) (let V2580 (shen.lazyderef V2899 V2902) (if (cons? V2580) (let V2581 (shen.lazyderef (hd V2580) V2902) (if (= define V2581) (let V2582 (shen.lazyderef (tl V2580) V2902) (if (cons? V2582) (let F (hd V2582) (let X (tl V2582) (let E (shen.newpv V2902) (do (shen.incinfs) (shen.t*-defh (compile shen. X (lambda E (if (cons? E) (simple-error (cn "parse error here: " (shen.app E " +(defun shen.t*-def (V2860 V2861 V2862 V2863 V2864) (let V2551 (shen.lazyderef V2860 V2863) (if (cons? V2551) (let V2552 (shen.lazyderef (hd V2551) V2863) (if (= define V2552) (let V2553 (shen.lazyderef (tl V2551) V2863) (if (cons? V2553) (let F (hd V2553) (let X (tl V2553) (let E (shen.newpv V2863) (do (shen.incinfs) (shen.t*-defh (compile (lambda X2787 (shen. X2787)) X (lambda E (if (cons? E) (simple-error (cn "parse error here: " (shen.app E " " shen.s))) (simple-error "parse error -")))) F V2900 V2901 V2902 V2903))))) false)) false)) false))) +")))) F V2861 V2862 V2863 V2864))))) false)) false)) false))) -(defun shen.t*-defh (V2904 V2905 V2906 V2907 V2908 V2909) (let V2576 (shen.lazyderef V2904 V2908) (if (cons? V2576) (let Sig (hd V2576) (let Rules (tl V2576) (do (shen.incinfs) (shen.t*-defhh Sig (shen.ue Sig) V2905 V2906 V2907 Rules V2908 V2909)))) false))) +(defun shen.t*-defh (V2865 V2866 V2867 V2868 V2869 V2870) (let V2547 (shen.lazyderef V2865 V2869) (if (cons? V2547) (let Sig (hd V2547) (let Rules (tl V2547) (do (shen.incinfs) (shen.t*-defhh Sig (shen.ue-sig Sig) V2866 V2867 V2868 Rules V2869 V2870)))) false))) -(defun shen.t*-defhh (V2910 V2911 V2912 V2913 V2914 V2915 V2916 V2917) (do (shen.incinfs) (shen.t*-rules V2915 V2911 1 V2912 (cons (cons V2912 (cons : (cons V2911 ()))) V2914) V2916 (freeze (shen.memo V2912 V2910 V2913 V2916 V2917))))) +(defun shen.t*-defhh (V2871 V2872 V2873 V2874 V2875 V2876 V2877 V2878) (do (shen.incinfs) (shen.t*-rules V2876 V2872 1 V2873 (cons (cons V2873 (cons : (cons V2872 ()))) V2875) V2877 (freeze (shen.memo V2873 V2871 V2874 V2877 V2878))))) -(defun shen.memo (V2918 V2919 V2920 V2921 V2922) (let Jnk (shen.newpv V2921) (do (shen.incinfs) (unify! V2920 V2919 V2921 (freeze (bind Jnk (declare (shen.lazyderef V2918 V2921) (shen.lazyderef V2920 V2921)) V2921 V2922)))))) +(defun shen.memo (V2879 V2880 V2881 V2882 V2883) (let Jnk (shen.newpv V2882) (do (shen.incinfs) (unify! V2881 V2880 V2882 (freeze (bind Jnk (declare (shen.lazyderef V2879 V2882) (shen.lazyderef V2881 V2882)) V2882 V2883)))))) -(defun shen. (V2927) (let Result (let Parse_shen. (shen. V2927) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) +(defun shen. (V2888) (let Result (let Parse_shen. (shen. V2888) (if (not (= (fail) Parse_shen.)) (let Parse_shen. (shen. Parse_shen.) (if (not (= (fail) Parse_shen.)) (shen.pair (hd Parse_shen.) (cons (shen.hdtl Parse_shen.) (shen.hdtl Parse_shen.))) (fail))) (fail))) (if (= Result (fail)) (fail) Result))) -(defun shen.ue (V2928) (cond ((and (cons? V2928) (and (cons? (tl V2928)) (and (= () (tl (tl V2928))) (= (hd V2928) protect)))) V2928) ((cons? V2928) (map shen.ue V2928)) ((variable? V2928) (concat && V2928)) (true V2928))) +(defun shen.ue (V2889) (cond ((and (cons? V2889) (and (cons? (tl V2889)) (and (= () (tl (tl V2889))) (= (hd V2889) protect)))) V2889) ((cons? V2889) (map (lambda X2788 (shen.ue X2788)) V2889)) ((variable? V2889) (concat && V2889)) (true V2889))) -(defun shen.ues (V2933) (cond ((shen.ue? V2933) (cons V2933 ())) ((cons? V2933) (union (shen.ues (hd V2933)) (shen.ues (tl V2933)))) (true ()))) +(defun shen.ue-sig (V2890) (cond ((cons? V2890) (map (lambda X2789 (shen.ue-sig X2789)) V2890)) ((variable? V2890) (concat &&& V2890)) (true V2890))) -(defun shen.ue? (V2934) (and (symbol? V2934) (shen.ue-h? (str V2934)))) +(defun shen.ues (V2895) (cond ((shen.ue? V2895) (cons V2895 ())) ((cons? V2895) (union (shen.ues (hd V2895)) (shen.ues (tl V2895)))) (true ()))) -(defun shen.ue-h? (V2941) (cond ((and (shen.+string? V2941) (and (= "&" (pos V2941 0)) (and (shen.+string? (tlstr V2941)) (= "&" (pos (tlstr V2941) 0))))) true) (true false))) +(defun shen.ue? (V2896) (and (symbol? V2896) (shen.ue-h? (str V2896)))) -(defun shen.t*-rules (V2942 V2943 V2944 V2945 V2946 V2947 V2948) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2551 (shen.lazyderef V2942 V2947) (if (= () V2551) (do (shen.incinfs) (thaw V2948)) false)) (if (= Case false) (let Case (let V2552 (shen.lazyderef V2942 V2947) (if (cons? V2552) (let V2553 (shen.lazyderef (hd V2552) V2947) (if (cons? V2553) (let V2554 (shen.lazyderef (hd V2553) V2947) (if (= () V2554) (let V2555 (shen.lazyderef (tl V2553) V2947) (if (cons? V2555) (let Action (hd V2555) (let V2556 (shen.lazyderef (tl V2555) V2947) (if (= () V2556) (let Rules (tl V2552) (let V2557 (shen.lazyderef V2943 V2947) (if (cons? V2557) (let V2558 (shen.lazyderef (hd V2557) V2947) (if (= --> V2558) (let V2559 (shen.lazyderef (tl V2557) V2947) (if (cons? V2559) (let A (hd V2559) (let V2560 (shen.lazyderef (tl V2559) V2947) (if (= () V2560) (do (shen.incinfs) (shen.t*-rule (cons () (cons (shen.ue Action) ())) A V2946 V2947 (freeze (cut Throwcontrol V2947 (freeze (shen.t*-rules Rules A (+ V2944 1) V2945 V2946 V2947 V2948)))))) false))) false)) false)) false))) false))) false)) false)) false)) false)) (if (= Case false) (let Case (let V2561 (shen.lazyderef V2942 V2947) (if (cons? V2561) (let Rule (hd V2561) (let Rules (tl V2561) (do (shen.incinfs) (shen.t*-rule (shen.ue Rule) V2943 V2946 V2947 (freeze (cut Throwcontrol V2947 (freeze (shen.t*-rules Rules V2943 (+ V2944 1) V2945 V2946 V2947 V2948)))))))) false)) (if (= Case false) (let Err (shen.newpv V2947) (do (shen.incinfs) (bind Err (simple-error (cn "type error in rule " (shen.app (shen.lazyderef V2944 V2947) (cn " of " (shen.app (shen.lazyderef V2945 V2947) "" shen.a)) shen.a))) V2947 V2948))) Case)) Case)) Case))))) +(defun shen.ue-h? (V2903) (cond ((and (shen.+string? V2903) (and (= "&" (pos V2903 0)) (and (shen.+string? (tlstr V2903)) (= "&" (pos (tlstr V2903) 0))))) true) (true false))) -(defun shen.t*-rule (V2949 V2950 V2951 V2952 V2953) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2533 (shen.lazyderef V2949 V2952) (if (cons? V2533) (let V2534 (shen.lazyderef (hd V2533) V2952) (if (= () V2534) (let V2535 (shen.lazyderef (tl V2533) V2952) (if (cons? V2535) (let Action (hd V2535) (let V2536 (shen.lazyderef (tl V2535) V2952) (if (= () V2536) (do (shen.incinfs) (cut Throwcontrol V2952 (freeze (shen.t*-action (shen.curry Action) V2950 V2951 V2952 V2953)))) false))) false)) false)) false)) (if (= Case false) (let V2537 (shen.lazyderef V2949 V2952) (if (cons? V2537) (let V2538 (shen.lazyderef (hd V2537) V2952) (if (cons? V2538) (let Pattern (hd V2538) (let Patterns (tl V2538) (let V2539 (shen.lazyderef (tl V2537) V2952) (if (cons? V2539) (let Action (hd V2539) (let V2540 (shen.lazyderef (tl V2539) V2952) (if (= () V2540) (let V2541 (shen.lazyderef V2950 V2952) (if (cons? V2541) (let A (hd V2541) (let V2542 (shen.lazyderef (tl V2541) V2952) (if (cons? V2542) (let V2543 (shen.lazyderef (hd V2542) V2952) (if (= --> V2543) (let V2544 (shen.lazyderef (tl V2542) V2952) (if (cons? V2544) (let B (hd V2544) (let V2545 (shen.lazyderef (tl V2544) V2952) (if (= () V2545) (do (shen.incinfs) (shen.t*-pattern Pattern A V2952 (freeze (cut Throwcontrol V2952 (freeze (shen.t*-rule (cons Patterns (cons Action ())) B (cons (cons Pattern (cons : (cons A ()))) V2951) V2952 V2953)))))) false))) false)) false)) false))) false)) false))) false)))) false)) false)) Case))))) +(defun shen.t*-rules (V2904 V2905 V2906 V2907 V2908 V2909 V2910) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2522 (shen.lazyderef V2904 V2909) (if (= () V2522) (do (shen.incinfs) (thaw V2910)) false)) (if (= Case false) (let Case (let V2523 (shen.lazyderef V2904 V2909) (if (cons? V2523) (let V2524 (shen.lazyderef (hd V2523) V2909) (if (cons? V2524) (let V2525 (shen.lazyderef (hd V2524) V2909) (if (= () V2525) (let V2526 (shen.lazyderef (tl V2524) V2909) (if (cons? V2526) (let Action (hd V2526) (let V2527 (shen.lazyderef (tl V2526) V2909) (if (= () V2527) (let Rules (tl V2523) (let V2528 (shen.lazyderef V2905 V2909) (if (cons? V2528) (let V2529 (shen.lazyderef (hd V2528) V2909) (if (= --> V2529) (let V2530 (shen.lazyderef (tl V2528) V2909) (if (cons? V2530) (let A (hd V2530) (let V2531 (shen.lazyderef (tl V2530) V2909) (if (= () V2531) (do (shen.incinfs) (shen.t*-rule (cons () (cons (shen.ue Action) ())) A V2908 V2909 (freeze (cut Throwcontrol V2909 (freeze (shen.t*-rules Rules A (+ V2906 1) V2907 V2908 V2909 V2910)))))) false))) false)) false)) false))) false))) false)) false)) false)) false)) (if (= Case false) (let Case (let V2532 (shen.lazyderef V2904 V2909) (if (cons? V2532) (let Rule (hd V2532) (let Rules (tl V2532) (do (shen.incinfs) (shen.t*-rule (shen.ue Rule) V2905 V2908 V2909 (freeze (cut Throwcontrol V2909 (freeze (shen.t*-rules Rules V2905 (+ V2906 1) V2907 V2908 V2909 V2910)))))))) false)) (if (= Case false) (let Err (shen.newpv V2909) (do (shen.incinfs) (bind Err (simple-error (cn "type error in rule " (shen.app (shen.lazyderef V2906 V2909) (cn " of " (shen.app (shen.lazyderef V2907 V2909) "" shen.a)) shen.a))) V2909 V2910))) Case)) Case)) Case))))) -(defun shen.t*-action (V2954 V2955 V2956 V2957 V2958) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2510 (shen.lazyderef V2954 V2957) (if (cons? V2510) (let V2511 (shen.lazyderef (hd V2510) V2957) (if (= where V2511) (let V2512 (shen.lazyderef (tl V2510) V2957) (if (cons? V2512) (let P (hd V2512) (let V2513 (shen.lazyderef (tl V2512) V2957) (if (cons? V2513) (let Action (hd V2513) (let V2514 (shen.lazyderef (tl V2513) V2957) (if (= () V2514) (do (shen.incinfs) (cut Throwcontrol V2957 (freeze (shen.t* (cons P (cons : (cons boolean ()))) V2956 V2957 (freeze (cut Throwcontrol V2957 (freeze (shen.t*-action Action V2955 (cons (cons P (cons : (cons verified ()))) V2956) V2957 V2958)))))))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2515 (shen.lazyderef V2954 V2957) (if (cons? V2515) (let V2516 (shen.lazyderef (hd V2515) V2957) (if (= shen.choicepoint! V2516) (let V2517 (shen.lazyderef (tl V2515) V2957) (if (cons? V2517) (let V2518 (shen.lazyderef (hd V2517) V2957) (if (cons? V2518) (let V2519 (shen.lazyderef (hd V2518) V2957) (if (cons? V2519) (let V2520 (shen.lazyderef (hd V2519) V2957) (if (= fail-if V2520) (let V2521 (shen.lazyderef (tl V2519) V2957) (if (cons? V2521) (let F (hd V2521) (let V2522 (shen.lazyderef (tl V2521) V2957) (if (= () V2522) (let V2523 (shen.lazyderef (tl V2518) V2957) (if (cons? V2523) (let Action (hd V2523) (let V2524 (shen.lazyderef (tl V2523) V2957) (if (= () V2524) (let V2525 (shen.lazyderef (tl V2517) V2957) (if (= () V2525) (do (shen.incinfs) (cut Throwcontrol V2957 (freeze (shen.t*-action (cons where (cons (cons not (cons (cons F (cons Action ())) ())) (cons Action ()))) V2955 V2956 V2957 V2958)))) false)) false))) false)) false))) false)) false)) false)) false)) false)) false)) false)) (if (= Case false) (let Case (let V2526 (shen.lazyderef V2954 V2957) (if (cons? V2526) (let V2527 (shen.lazyderef (hd V2526) V2957) (if (= shen.choicepoint! V2527) (let V2528 (shen.lazyderef (tl V2526) V2957) (if (cons? V2528) (let Action (hd V2528) (let V2529 (shen.lazyderef (tl V2528) V2957) (if (= () V2529) (do (shen.incinfs) (cut Throwcontrol V2957 (freeze (shen.t*-action (cons where (cons (cons not (cons (cons (cons = (cons Action ())) (cons (cons fail ()) ())) ())) (cons Action ()))) V2955 V2956 V2957 V2958)))) false))) false)) false)) false)) (if (= Case false) (do (shen.incinfs) (shen.t* (cons V2954 (cons : (cons V2955 ()))) V2956 V2957 V2958)) Case)) Case)) Case))))) +(defun shen.t*-rule (V2911 V2912 V2913 V2914 V2915) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2504 (shen.lazyderef V2911 V2914) (if (cons? V2504) (let V2505 (shen.lazyderef (hd V2504) V2914) (if (= () V2505) (let V2506 (shen.lazyderef (tl V2504) V2914) (if (cons? V2506) (let Action (hd V2506) (let V2507 (shen.lazyderef (tl V2506) V2914) (if (= () V2507) (do (shen.incinfs) (cut Throwcontrol V2914 (freeze (shen.t*-action (shen.curry Action) V2912 V2913 V2914 V2915)))) false))) false)) false)) false)) (if (= Case false) (let V2508 (shen.lazyderef V2911 V2914) (if (cons? V2508) (let V2509 (shen.lazyderef (hd V2508) V2914) (if (cons? V2509) (let Pattern (hd V2509) (let Patterns (tl V2509) (let V2510 (shen.lazyderef (tl V2508) V2914) (if (cons? V2510) (let Action (hd V2510) (let V2511 (shen.lazyderef (tl V2510) V2914) (if (= () V2511) (let V2512 (shen.lazyderef V2912 V2914) (if (cons? V2512) (let A (hd V2512) (let V2513 (shen.lazyderef (tl V2512) V2914) (if (cons? V2513) (let V2514 (shen.lazyderef (hd V2513) V2914) (if (= --> V2514) (let V2515 (shen.lazyderef (tl V2513) V2914) (if (cons? V2515) (let B (hd V2515) (let V2516 (shen.lazyderef (tl V2515) V2914) (if (= () V2516) (do (shen.incinfs) (shen.t*-pattern Pattern A V2914 (freeze (cut Throwcontrol V2914 (freeze (shen.t*-rule (cons Patterns (cons Action ())) B (cons (cons Pattern (cons : (cons A ()))) V2913) V2914 V2915)))))) false))) false)) false)) false))) false)) false))) false)))) false)) false)) Case))))) -(defun shen.t*-pattern (V2959 V2960 V2961 V2962) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Hyp (shen.newpv V2961) (do (shen.incinfs) (shen.tms->hyp (shen.ues V2959) Hyp V2961 (freeze (cut Throwcontrol V2961 (freeze (shen.t* (cons V2959 (cons : (cons V2960 ()))) Hyp V2961 V2962)))))))))) +(defun shen.t*-action (V2916 V2917 V2918 V2919 V2920) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2481 (shen.lazyderef V2916 V2919) (if (cons? V2481) (let V2482 (shen.lazyderef (hd V2481) V2919) (if (= where V2482) (let V2483 (shen.lazyderef (tl V2481) V2919) (if (cons? V2483) (let P (hd V2483) (let V2484 (shen.lazyderef (tl V2483) V2919) (if (cons? V2484) (let Action (hd V2484) (let V2485 (shen.lazyderef (tl V2484) V2919) (if (= () V2485) (do (shen.incinfs) (cut Throwcontrol V2919 (freeze (shen.t* (cons P (cons : (cons boolean ()))) V2918 V2919 (freeze (cut Throwcontrol V2919 (freeze (shen.t*-action Action V2917 (cons (cons P (cons : (cons verified ()))) V2918) V2919 V2920)))))))) false))) false))) false)) false)) false)) (if (= Case false) (let Case (let V2486 (shen.lazyderef V2916 V2919) (if (cons? V2486) (let V2487 (shen.lazyderef (hd V2486) V2919) (if (= shen.choicepoint! V2487) (let V2488 (shen.lazyderef (tl V2486) V2919) (if (cons? V2488) (let V2489 (shen.lazyderef (hd V2488) V2919) (if (cons? V2489) (let V2490 (shen.lazyderef (hd V2489) V2919) (if (cons? V2490) (let V2491 (shen.lazyderef (hd V2490) V2919) (if (= fail-if V2491) (let V2492 (shen.lazyderef (tl V2490) V2919) (if (cons? V2492) (let F (hd V2492) (let V2493 (shen.lazyderef (tl V2492) V2919) (if (= () V2493) (let V2494 (shen.lazyderef (tl V2489) V2919) (if (cons? V2494) (let Action (hd V2494) (let V2495 (shen.lazyderef (tl V2494) V2919) (if (= () V2495) (let V2496 (shen.lazyderef (tl V2488) V2919) (if (= () V2496) (do (shen.incinfs) (cut Throwcontrol V2919 (freeze (shen.t*-action (cons where (cons (cons not (cons (cons F (cons Action ())) ())) (cons Action ()))) V2917 V2918 V2919 V2920)))) false)) false))) false)) false))) false)) false)) false)) false)) false)) false)) false)) (if (= Case false) (let Case (let V2497 (shen.lazyderef V2916 V2919) (if (cons? V2497) (let V2498 (shen.lazyderef (hd V2497) V2919) (if (= shen.choicepoint! V2498) (let V2499 (shen.lazyderef (tl V2497) V2919) (if (cons? V2499) (let Action (hd V2499) (let V2500 (shen.lazyderef (tl V2499) V2919) (if (= () V2500) (do (shen.incinfs) (cut Throwcontrol V2919 (freeze (shen.t*-action (cons where (cons (cons not (cons (cons (cons = (cons Action ())) (cons (cons fail ()) ())) ())) (cons Action ()))) V2917 V2918 V2919 V2920)))) false))) false)) false)) false)) (if (= Case false) (do (shen.incinfs) (shen.t* (cons V2916 (cons : (cons V2917 ()))) V2918 V2919 V2920)) Case)) Case)) Case))))) -(defun shen.tms->hyp (V2963 V2964 V2965 V2966) (let Case (let V2494 (shen.lazyderef V2963 V2965) (if (= () V2494) (let V2495 (shen.lazyderef V2964 V2965) (if (= () V2495) (do (shen.incinfs) (thaw V2966)) (if (shen.pvar? V2495) (do (shen.bindv V2495 () V2965) (let Result (do (shen.incinfs) (thaw V2966)) (do (shen.unbindv V2495 V2965) Result))) false))) false)) (if (= Case false) (let V2496 (shen.lazyderef V2963 V2965) (if (cons? V2496) (let Tm2491 (hd V2496) (let Tms (tl V2496) (let V2497 (shen.lazyderef V2964 V2965) (if (cons? V2497) (let V2498 (shen.lazyderef (hd V2497) V2965) (if (cons? V2498) (let Tm (hd V2498) (let V2499 (shen.lazyderef (tl V2498) V2965) (if (cons? V2499) (let V2500 (shen.lazyderef (hd V2499) V2965) (if (= : V2500) (let V2501 (shen.lazyderef (tl V2499) V2965) (if (cons? V2501) (let A (hd V2501) (let V2502 (shen.lazyderef (tl V2501) V2965) (if (= () V2502) (let Hyp (tl V2497) (do (shen.incinfs) (unify! Tm Tm2491 V2965 (freeze (shen.tms->hyp Tms Hyp V2965 V2966))))) (if (shen.pvar? V2502) (do (shen.bindv V2502 () V2965) (let Result (let Hyp (tl V2497) (do (shen.incinfs) (unify! Tm Tm2491 V2965 (freeze (shen.tms->hyp Tms Hyp V2965 V2966))))) (do (shen.unbindv V2502 V2965) Result))) false)))) (if (shen.pvar? V2501) (let A (shen.newpv V2965) (do (shen.bindv V2501 (cons A ()) V2965) (let Result (let Hyp (tl V2497) (do (shen.incinfs) (unify! Tm Tm2491 V2965 (freeze (shen.tms->hyp Tms Hyp V2965 V2966))))) (do (shen.unbindv V2501 V2965) Result)))) false))) (if (shen.pvar? V2500) (do (shen.bindv V2500 : V2965) (let Result (let V2503 (shen.lazyderef (tl V2499) V2965) (if (cons? V2503) (let A (hd V2503) (let V2504 (shen.lazyderef (tl V2503) V2965) (if (= () V2504) (let Hyp (tl V2497) (do (shen.incinfs) (unify! Tm Tm2491 V2965 (freeze (shen.tms->hyp Tms Hyp V2965 V2966))))) (if (shen.pvar? V2504) (do (shen.bindv V2504 () V2965) (let Result (let Hyp (tl V2497) (do (shen.incinfs) (unify! Tm Tm2491 V2965 (freeze (shen.tms->hyp Tms Hyp V2965 V2966))))) (do (shen.unbindv V2504 V2965) Result))) false)))) (if (shen.pvar? V2503) (let A (shen.newpv V2965) (do (shen.bindv V2503 (cons A ()) V2965) (let Result (let Hyp (tl V2497) (do (shen.incinfs) (unify! Tm Tm2491 V2965 (freeze (shen.tms->hyp Tms Hyp V2965 V2966))))) (do (shen.unbindv V2503 V2965) Result)))) false))) (do (shen.unbindv V2500 V2965) Result))) false))) (if (shen.pvar? V2499) (let A (shen.newpv V2965) (do (shen.bindv V2499 (cons : (cons A ())) V2965) (let Result (let Hyp (tl V2497) (do (shen.incinfs) (unify! Tm Tm2491 V2965 (freeze (shen.tms->hyp Tms Hyp V2965 V2966))))) (do (shen.unbindv V2499 V2965) Result)))) false)))) (if (shen.pvar? V2498) (let Tm (shen.newpv V2965) (let A (shen.newpv V2965) (do (shen.bindv V2498 (cons Tm (cons : (cons A ()))) V2965) (let Result (let Hyp (tl V2497) (do (shen.incinfs) (unify! Tm Tm2491 V2965 (freeze (shen.tms->hyp Tms Hyp V2965 V2966))))) (do (shen.unbindv V2498 V2965) Result))))) false))) (if (shen.pvar? V2497) (let Tm (shen.newpv V2965) (let A (shen.newpv V2965) (let Hyp (shen.newpv V2965) (do (shen.bindv V2497 (cons (cons Tm (cons : (cons A ()))) Hyp) V2965) (let Result (do (shen.incinfs) (unify! Tm Tm2491 V2965 (freeze (shen.tms->hyp Tms Hyp V2965 V2966)))) (do (shen.unbindv V2497 V2965) Result)))))) false))))) false)) Case))) +(defun shen.t*-pattern (V2921 V2922 V2923 V2924) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Hyp (shen.newpv V2923) (do (shen.incinfs) (shen.tms->hyp (shen.ues V2921) Hyp V2923 (freeze (cut Throwcontrol V2923 (freeze (shen.t* (cons V2921 (cons : (cons V2922 ()))) Hyp V2923 V2924)))))))))) -(defun findall (V2967 V2968 V2969 V2970 V2971) (let B (shen.newpv V2970) (let A (shen.newpv V2970) (do (shen.incinfs) (bind A (gensym shen.a) V2970 (freeze (bind B (set (shen.lazyderef A V2970) ()) V2970 (freeze (shen.findallhelp V2967 V2968 V2969 A V2970 V2971))))))))) +(defun shen.tms->hyp (V2925 V2926 V2927 V2928) (let Case (let V2465 (shen.lazyderef V2925 V2927) (if (= () V2465) (let V2466 (shen.lazyderef V2926 V2927) (if (= () V2466) (do (shen.incinfs) (thaw V2928)) (if (shen.pvar? V2466) (do (shen.bindv V2466 () V2927) (let Result (do (shen.incinfs) (thaw V2928)) (do (shen.unbindv V2466 V2927) Result))) false))) false)) (if (= Case false) (let V2467 (shen.lazyderef V2925 V2927) (if (cons? V2467) (let Tm2462 (hd V2467) (let Tms (tl V2467) (let V2468 (shen.lazyderef V2926 V2927) (if (cons? V2468) (let V2469 (shen.lazyderef (hd V2468) V2927) (if (cons? V2469) (let Tm (hd V2469) (let V2470 (shen.lazyderef (tl V2469) V2927) (if (cons? V2470) (let V2471 (shen.lazyderef (hd V2470) V2927) (if (= : V2471) (let V2472 (shen.lazyderef (tl V2470) V2927) (if (cons? V2472) (let A (hd V2472) (let V2473 (shen.lazyderef (tl V2472) V2927) (if (= () V2473) (let Hyp (tl V2468) (do (shen.incinfs) (unify! Tm Tm2462 V2927 (freeze (shen.tms->hyp Tms Hyp V2927 V2928))))) (if (shen.pvar? V2473) (do (shen.bindv V2473 () V2927) (let Result (let Hyp (tl V2468) (do (shen.incinfs) (unify! Tm Tm2462 V2927 (freeze (shen.tms->hyp Tms Hyp V2927 V2928))))) (do (shen.unbindv V2473 V2927) Result))) false)))) (if (shen.pvar? V2472) (let A (shen.newpv V2927) (do (shen.bindv V2472 (cons A ()) V2927) (let Result (let Hyp (tl V2468) (do (shen.incinfs) (unify! Tm Tm2462 V2927 (freeze (shen.tms->hyp Tms Hyp V2927 V2928))))) (do (shen.unbindv V2472 V2927) Result)))) false))) (if (shen.pvar? V2471) (do (shen.bindv V2471 : V2927) (let Result (let V2474 (shen.lazyderef (tl V2470) V2927) (if (cons? V2474) (let A (hd V2474) (let V2475 (shen.lazyderef (tl V2474) V2927) (if (= () V2475) (let Hyp (tl V2468) (do (shen.incinfs) (unify! Tm Tm2462 V2927 (freeze (shen.tms->hyp Tms Hyp V2927 V2928))))) (if (shen.pvar? V2475) (do (shen.bindv V2475 () V2927) (let Result (let Hyp (tl V2468) (do (shen.incinfs) (unify! Tm Tm2462 V2927 (freeze (shen.tms->hyp Tms Hyp V2927 V2928))))) (do (shen.unbindv V2475 V2927) Result))) false)))) (if (shen.pvar? V2474) (let A (shen.newpv V2927) (do (shen.bindv V2474 (cons A ()) V2927) (let Result (let Hyp (tl V2468) (do (shen.incinfs) (unify! Tm Tm2462 V2927 (freeze (shen.tms->hyp Tms Hyp V2927 V2928))))) (do (shen.unbindv V2474 V2927) Result)))) false))) (do (shen.unbindv V2471 V2927) Result))) false))) (if (shen.pvar? V2470) (let A (shen.newpv V2927) (do (shen.bindv V2470 (cons : (cons A ())) V2927) (let Result (let Hyp (tl V2468) (do (shen.incinfs) (unify! Tm Tm2462 V2927 (freeze (shen.tms->hyp Tms Hyp V2927 V2928))))) (do (shen.unbindv V2470 V2927) Result)))) false)))) (if (shen.pvar? V2469) (let Tm (shen.newpv V2927) (let A (shen.newpv V2927) (do (shen.bindv V2469 (cons Tm (cons : (cons A ()))) V2927) (let Result (let Hyp (tl V2468) (do (shen.incinfs) (unify! Tm Tm2462 V2927 (freeze (shen.tms->hyp Tms Hyp V2927 V2928))))) (do (shen.unbindv V2469 V2927) Result))))) false))) (if (shen.pvar? V2468) (let Tm (shen.newpv V2927) (let A (shen.newpv V2927) (let Hyp (shen.newpv V2927) (do (shen.bindv V2468 (cons (cons Tm (cons : (cons A ()))) Hyp) V2927) (let Result (do (shen.incinfs) (unify! Tm Tm2462 V2927 (freeze (shen.tms->hyp Tms Hyp V2927 V2928)))) (do (shen.unbindv V2468 V2927) Result)))))) false))))) false)) Case))) -(defun shen.findallhelp (V2972 V2973 V2974 V2975 V2976 V2977) (let Case (do (shen.incinfs) (call V2973 V2976 (freeze (shen.remember V2975 V2972 V2976 (freeze (fwhen false V2976 V2977)))))) (if (= Case false) (do (shen.incinfs) (bind V2974 (value (shen.lazyderef V2975 V2976)) V2976 V2977)) Case))) +(defun findall (V2929 V2930 V2931 V2932 V2933) (let B (shen.newpv V2932) (let A (shen.newpv V2932) (do (shen.incinfs) (bind A (gensym shen.a) V2932 (freeze (bind B (set (shen.lazyderef A V2932) ()) V2932 (freeze (shen.findallhelp V2929 V2930 V2931 A V2932 V2933))))))))) -(defun shen.remember (V2978 V2979 V2980 V2981) (let B (shen.newpv V2980) (do (shen.incinfs) (bind B (set (shen.deref V2978 V2980) (cons (shen.deref V2979 V2980) (value (shen.deref V2978 V2980)))) V2980 V2981)))) +(defun shen.findallhelp (V2934 V2935 V2936 V2937 V2938 V2939) (let Case (do (shen.incinfs) (call V2935 V2938 (freeze (shen.remember V2937 V2934 V2938 (freeze (fwhen false V2938 V2939)))))) (if (= Case false) (do (shen.incinfs) (bind V2936 (value (shen.lazyderef V2937 V2938)) V2938 V2939)) Case))) -(defun shen.t*-defcc (V2982 V2983 V2984 V2985 V2986) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let V2467 (shen.lazyderef V2982 V2985) (if (cons? V2467) (let V2468 (shen.lazyderef (hd V2467) V2985) (if (= defcc V2468) (let V2469 (shen.lazyderef (tl V2467) V2985) (if (cons? V2469) (let F (hd V2469) (let V2470 (shen.lazyderef (tl V2469) V2985) (if (cons? V2470) (let V2471 (shen.lazyderef (hd V2470) V2985) (if (= { V2471) (let V2472 (shen.lazyderef (tl V2470) V2985) (if (cons? V2472) (let V2473 (shen.lazyderef (hd V2472) V2985) (if (cons? V2473) (let V2474 (shen.lazyderef (hd V2473) V2985) (if (= list V2474) (let V2475 (shen.lazyderef (tl V2473) V2985) (if (cons? V2475) (let A (hd V2475) (let V2476 (shen.lazyderef (tl V2475) V2985) (if (= () V2476) (let V2477 (shen.lazyderef (tl V2472) V2985) (if (cons? V2477) (let V2478 (shen.lazyderef (hd V2477) V2985) (if (= ==> V2478) (let V2479 (shen.lazyderef (tl V2477) V2985) (if (cons? V2479) (let B (hd V2479) (let V2480 (shen.lazyderef (tl V2479) V2985) (if (cons? V2480) (let V2481 (shen.lazyderef (hd V2480) V2985) (if (= } V2481) (let Rest (tl V2480) (let Rest& (shen.newpv V2985) (let Rest&& (shen.newpv V2985) (let Rules (shen.newpv V2985) (let ListA&& (shen.newpv V2985) (let B&& (shen.newpv V2985) (let Sig (shen.newpv V2985) (let Declare (shen.newpv V2985) (do (shen.incinfs) (bind Sig (shen.ue (cons (cons list (cons (shen.lazyderef A V2985) ())) (cons ==> (cons (shen.lazyderef B V2985) ())))) V2985 (freeze (bind ListA&& (hd (shen.lazyderef Sig V2985)) V2985 (freeze (bind B&& (hd (tl (tl (shen.lazyderef Sig V2985)))) V2985 (freeze (bind Rest& (shen.plug-wildcards (shen.lazyderef Rest V2985)) V2985 (freeze (bind Rest&& (shen.ue (shen.lazyderef Rest& V2985)) V2985 (freeze (shen.get-rules Rules Rest&& V2985 (freeze (cut Throwcontrol V2985 (freeze (shen.tc-rules F Rules ListA&& B&& (cons (cons F (cons : (cons Sig ()))) V2984) 1 V2985 (freeze (unify V2983 (cons (cons list (cons A ())) (cons ==> (cons B ()))) V2985 (freeze (bind Declare (declare (shen.lazyderef F V2985) (cons (cons list (cons (shen.lazyderef A V2985) ())) (cons ==> (cons (shen.lazyderef B V2985) ())))) V2985 V2986)))))))))))))))))))))))))))) false)) false))) false)) false)) false)) false))) false)) false)) false)) false)) false)) false))) false)) false)) false))))) - -(defun shen.plug-wildcards (V2987) (cond ((cons? V2987) (map shen.plug-wildcards V2987)) ((= V2987 _) (gensym (intern "X"))) (true V2987))) - -(defun shen.get-rules (V2988 V2989 V2990 V2991) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2460 (shen.lazyderef V2988 V2990) (if (= () V2460) (let V2461 (shen.lazyderef V2989 V2990) (if (= () V2461) (do (shen.incinfs) (cut Throwcontrol V2990 V2991)) false)) (if (shen.pvar? V2460) (do (shen.bindv V2460 () V2990) (let Result (let V2462 (shen.lazyderef V2989 V2990) (if (= () V2462) (do (shen.incinfs) (cut Throwcontrol V2990 V2991)) false)) (do (shen.unbindv V2460 V2990) Result))) false))) (if (= Case false) (let V2463 (shen.lazyderef V2988 V2990) (if (cons? V2463) (let Rule (hd V2463) (let Rules (tl V2463) (let Other (shen.newpv V2990) (do (shen.incinfs) (shen.first-rule V2989 Rule Other V2990 (freeze (cut Throwcontrol V2990 (freeze (shen.get-rules Rules Other V2990 V2991))))))))) (if (shen.pvar? V2463) (let Rule (shen.newpv V2990) (let Rules (shen.newpv V2990) (do (shen.bindv V2463 (cons Rule Rules) V2990) (let Result (let Other (shen.newpv V2990) (do (shen.incinfs) (shen.first-rule V2989 Rule Other V2990 (freeze (cut Throwcontrol V2990 (freeze (shen.get-rules Rules Other V2990 V2991))))))) (do (shen.unbindv V2463 V2990) Result))))) false))) Case))))) - -(defun shen.first-rule (V2992 V2993 V2994 V2995 V2996) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2453 (shen.lazyderef V2992 V2995) (if (cons? V2453) (let V2454 (shen.lazyderef (hd V2453) V2995) (if (= ; V2454) (let Other2448 (tl V2453) (let V2455 (shen.lazyderef V2993 V2995) (if (= () V2455) (do (shen.incinfs) (unify! V2994 Other2448 V2995 (freeze (cut Throwcontrol V2995 V2996)))) (if (shen.pvar? V2455) (do (shen.bindv V2455 () V2995) (let Result (do (shen.incinfs) (unify! V2994 Other2448 V2995 (freeze (cut Throwcontrol V2995 V2996)))) (do (shen.unbindv V2455 V2995) Result))) false)))) false)) false)) (if (= Case false) (let V2456 (shen.lazyderef V2992 V2995) (if (cons? V2456) (let X2449 (hd V2456) (let Rest (tl V2456) (let V2457 (shen.lazyderef V2993 V2995) (if (cons? V2457) (let X (hd V2457) (let Rule (tl V2457) (do (shen.incinfs) (unify! X X2449 V2995 (freeze (shen.first-rule Rest Rule V2994 V2995 V2996)))))) (if (shen.pvar? V2457) (let X (shen.newpv V2995) (let Rule (shen.newpv V2995) (do (shen.bindv V2457 (cons X Rule) V2995) (let Result (do (shen.incinfs) (unify! X X2449 V2995 (freeze (shen.first-rule Rest Rule V2994 V2995 V2996)))) (do (shen.unbindv V2457 V2995) Result))))) false))))) false)) Case))))) - -(defun shen.tc-rules (V2997 V2998 V2999 V3000 V3001 V3002 V3003 V3004) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2442 (shen.lazyderef V2998 V3003) (if (= () V2442) (do (shen.incinfs) (thaw V3004)) false)) (if (= Case false) (let V2443 (shen.lazyderef V2998 V3003) (if (cons? V2443) (let Rule (hd V2443) (let Rules (tl V2443) (let V2444 (shen.lazyderef V2999 V3003) (if (cons? V2444) (let V2445 (shen.lazyderef (hd V2444) V3003) (if (= list V2445) (let V2446 (shen.lazyderef (tl V2444) V3003) (if (cons? V2446) (let A (hd V2446) (let V2447 (shen.lazyderef (tl V2446) V3003) (if (= () V2447) (let M (shen.newpv V3003) (do (shen.incinfs) (shen.tc-rule V2997 Rule A V3000 V3001 V3002 V3003 (freeze (bind M (+ (shen.deref V3002 V3003) 1) V3003 (freeze (cut Throwcontrol V3003 (freeze (shen.tc-rules V2997 Rules (cons list (cons A ())) V3000 V3001 M V3003 V3004))))))))) false))) false)) false)) false)))) false)) Case))))) - -(defun shen.tc-rule (V3005 V3006 V3007 V3008 V3009 V3010 V3011 V3012) (let Case (do (shen.incinfs) (shen.check-defcc-rule V3006 V3007 V3008 V3009 V3011 V3012)) (if (= Case false) (let Err (shen.newpv V3011) (do (shen.incinfs) (bind Err (simple-error (cn "type error in rule " (shen.app (shen.lazyderef V3010 V3011) (cn " of " (shen.app (shen.lazyderef V3005 V3011) "" shen.a)) shen.a))) V3011 V3012))) Case))) - -(defun shen.check-defcc-rule (V3013 V3014 V3015 V3016 V3017 V3018) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Syntax (shen.newpv V3017) (let Semantics (shen.newpv V3017) (let SynHyps (shen.newpv V3017) (do (shen.incinfs) (shen.get-syntax+semantics Syntax Semantics V3013 V3017 (freeze (cut Throwcontrol V3017 (freeze (shen.syntax-hyps Syntax V3016 SynHyps V3014 V3017 (freeze (cut Throwcontrol V3017 (freeze (shen.syntax-check Syntax V3014 SynHyps V3017 (freeze (cut Throwcontrol V3017 (freeze (shen.semantics-check Semantics V3015 SynHyps V3017 V3018)))))))))))))))))))) - -(defun shen.syntax-hyps (V3019 V3020 V3021 V3022 V3023 V3024) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2415 (shen.lazyderef V3019 V3023) (if (= () V2415) (do (shen.incinfs) (unify! V3021 V3020 V3023 V3024)) false)) (if (= Case false) (let Case (let V2416 (shen.lazyderef V3019 V3023) (if (cons? V2416) (let X2409 (hd V2416) (let Y (tl V2416) (let V2417 (shen.lazyderef V3021 V3023) (if (cons? V2417) (let V2418 (shen.lazyderef (hd V2417) V3023) (if (cons? V2418) (let X (hd V2418) (let V2419 (shen.lazyderef (tl V2418) V3023) (if (cons? V2419) (let V2420 (shen.lazyderef (hd V2419) V3023) (if (= : V2420) (let V2421 (shen.lazyderef (tl V2419) V3023) (if (cons? V2421) (let A2410 (hd V2421) (let V2422 (shen.lazyderef (tl V2421) V3023) (if (= () V2422) (let SynHyps (tl V2417) (do (shen.incinfs) (unify! V3022 A2410 V3023 (freeze (unify! X X2409 V3023 (freeze (fwhen (shen.ue? (shen.deref X V3023)) V3023 (freeze (cut Throwcontrol V3023 (freeze (shen.syntax-hyps Y V3020 SynHyps V3022 V3023 V3024))))))))))) (if (shen.pvar? V2422) (do (shen.bindv V2422 () V3023) (let Result (let SynHyps (tl V2417) (do (shen.incinfs) (unify! V3022 A2410 V3023 (freeze (unify! X X2409 V3023 (freeze (fwhen (shen.ue? (shen.deref X V3023)) V3023 (freeze (cut Throwcontrol V3023 (freeze (shen.syntax-hyps Y V3020 SynHyps V3022 V3023 V3024))))))))))) (do (shen.unbindv V2422 V3023) Result))) false)))) (if (shen.pvar? V2421) (let A2410 (shen.newpv V3023) (do (shen.bindv V2421 (cons A2410 ()) V3023) (let Result (let SynHyps (tl V2417) (do (shen.incinfs) (unify! V3022 A2410 V3023 (freeze (unify! X X2409 V3023 (freeze (fwhen (shen.ue? (shen.deref X V3023)) V3023 (freeze (cut Throwcontrol V3023 (freeze (shen.syntax-hyps Y V3020 SynHyps V3022 V3023 V3024))))))))))) (do (shen.unbindv V2421 V3023) Result)))) false))) (if (shen.pvar? V2420) (do (shen.bindv V2420 : V3023) (let Result (let V2423 (shen.lazyderef (tl V2419) V3023) (if (cons? V2423) (let A2410 (hd V2423) (let V2424 (shen.lazyderef (tl V2423) V3023) (if (= () V2424) (let SynHyps (tl V2417) (do (shen.incinfs) (unify! V3022 A2410 V3023 (freeze (unify! X X2409 V3023 (freeze (fwhen (shen.ue? (shen.deref X V3023)) V3023 (freeze (cut Throwcontrol V3023 (freeze (shen.syntax-hyps Y V3020 SynHyps V3022 V3023 V3024))))))))))) (if (shen.pvar? V2424) (do (shen.bindv V2424 () V3023) (let Result (let SynHyps (tl V2417) (do (shen.incinfs) (unify! V3022 A2410 V3023 (freeze (unify! X X2409 V3023 (freeze (fwhen (shen.ue? (shen.deref X V3023)) V3023 (freeze (cut Throwcontrol V3023 (freeze (shen.syntax-hyps Y V3020 SynHyps V3022 V3023 V3024))))))))))) (do (shen.unbindv V2424 V3023) Result))) false)))) (if (shen.pvar? V2423) (let A2410 (shen.newpv V3023) (do (shen.bindv V2423 (cons A2410 ()) V3023) (let Result (let SynHyps (tl V2417) (do (shen.incinfs) (unify! V3022 A2410 V3023 (freeze (unify! X X2409 V3023 (freeze (fwhen (shen.ue? (shen.deref X V3023)) V3023 (freeze (cut Throwcontrol V3023 (freeze (shen.syntax-hyps Y V3020 SynHyps V3022 V3023 V3024))))))))))) (do (shen.unbindv V2423 V3023) Result)))) false))) (do (shen.unbindv V2420 V3023) Result))) false))) (if (shen.pvar? V2419) (let A2410 (shen.newpv V3023) (do (shen.bindv V2419 (cons : (cons A2410 ())) V3023) (let Result (let SynHyps (tl V2417) (do (shen.incinfs) (unify! V3022 A2410 V3023 (freeze (unify! X X2409 V3023 (freeze (fwhen (shen.ue? (shen.deref X V3023)) V3023 (freeze (cut Throwcontrol V3023 (freeze (shen.syntax-hyps Y V3020 SynHyps V3022 V3023 V3024))))))))))) (do (shen.unbindv V2419 V3023) Result)))) false)))) (if (shen.pvar? V2418) (let X (shen.newpv V3023) (let A2410 (shen.newpv V3023) (do (shen.bindv V2418 (cons X (cons : (cons A2410 ()))) V3023) (let Result (let SynHyps (tl V2417) (do (shen.incinfs) (unify! V3022 A2410 V3023 (freeze (unify! X X2409 V3023 (freeze (fwhen (shen.ue? (shen.deref X V3023)) V3023 (freeze (cut Throwcontrol V3023 (freeze (shen.syntax-hyps Y V3020 SynHyps V3022 V3023 V3024))))))))))) (do (shen.unbindv V2418 V3023) Result))))) false))) (if (shen.pvar? V2417) (let X (shen.newpv V3023) (let A2410 (shen.newpv V3023) (let SynHyps (shen.newpv V3023) (do (shen.bindv V2417 (cons (cons X (cons : (cons A2410 ()))) SynHyps) V3023) (let Result (do (shen.incinfs) (unify! V3022 A2410 V3023 (freeze (unify! X X2409 V3023 (freeze (fwhen (shen.ue? (shen.deref X V3023)) V3023 (freeze (cut Throwcontrol V3023 (freeze (shen.syntax-hyps Y V3020 SynHyps V3022 V3023 V3024)))))))))) (do (shen.unbindv V2417 V3023) Result)))))) false))))) false)) (if (= Case false) (let V2425 (shen.lazyderef V3019 V3023) (if (cons? V2425) (let Y (tl V2425) (do (shen.incinfs) (shen.syntax-hyps Y V3020 V3021 V3022 V3023 V3024))) false)) Case)) Case))))) - -(defun shen.get-syntax+semantics (V3025 V3026 V3027 V3028 V3029) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2381 (shen.lazyderef V3025 V3028) (if (= () V2381) (let V2382 (shen.lazyderef V3027 V3028) (if (cons? V2382) (let V2383 (shen.lazyderef (hd V2382) V3028) (if (= := V2383) (let V2384 (shen.lazyderef (tl V2382) V3028) (if (cons? V2384) (let Semantics (hd V2384) (let V2385 (shen.lazyderef (tl V2384) V3028) (if (= () V2385) (do (shen.incinfs) (cut Throwcontrol V3028 (freeze (bind V3026 (shen.lazyderef Semantics V3028) V3028 V3029)))) false))) false)) false)) false)) (if (shen.pvar? V2381) (do (shen.bindv V2381 () V3028) (let Result (let V2386 (shen.lazyderef V3027 V3028) (if (cons? V2386) (let V2387 (shen.lazyderef (hd V2386) V3028) (if (= := V2387) (let V2388 (shen.lazyderef (tl V2386) V3028) (if (cons? V2388) (let Semantics (hd V2388) (let V2389 (shen.lazyderef (tl V2388) V3028) (if (= () V2389) (do (shen.incinfs) (cut Throwcontrol V3028 (freeze (bind V3026 (shen.lazyderef Semantics V3028) V3028 V3029)))) false))) false)) false)) false)) (do (shen.unbindv V2381 V3028) Result))) false))) (if (= Case false) (let Case (let V2390 (shen.lazyderef V3025 V3028) (if (= () V2390) (let V2391 (shen.lazyderef V3027 V3028) (if (cons? V2391) (let V2392 (shen.lazyderef (hd V2391) V3028) (if (= := V2392) (let V2393 (shen.lazyderef (tl V2391) V3028) (if (cons? V2393) (let Semantics (hd V2393) (let V2394 (shen.lazyderef (tl V2393) V3028) (if (cons? V2394) (let V2395 (shen.lazyderef (hd V2394) V3028) (if (= where V2395) (let V2396 (shen.lazyderef (tl V2394) V3028) (if (cons? V2396) (let G (hd V2396) (let V2397 (shen.lazyderef (tl V2396) V3028) (if (= () V2397) (do (shen.incinfs) (cut Throwcontrol V3028 (freeze (bind V3026 (cons where (cons (shen.lazyderef G V3028) (cons (shen.lazyderef Semantics V3028) ()))) V3028 V3029)))) false))) false)) false)) false))) false)) false)) false)) (if (shen.pvar? V2390) (do (shen.bindv V2390 () V3028) (let Result (let V2398 (shen.lazyderef V3027 V3028) (if (cons? V2398) (let V2399 (shen.lazyderef (hd V2398) V3028) (if (= := V2399) (let V2400 (shen.lazyderef (tl V2398) V3028) (if (cons? V2400) (let Semantics (hd V2400) (let V2401 (shen.lazyderef (tl V2400) V3028) (if (cons? V2401) (let V2402 (shen.lazyderef (hd V2401) V3028) (if (= where V2402) (let V2403 (shen.lazyderef (tl V2401) V3028) (if (cons? V2403) (let G (hd V2403) (let V2404 (shen.lazyderef (tl V2403) V3028) (if (= () V2404) (do (shen.incinfs) (cut Throwcontrol V3028 (freeze (bind V3026 (cons where (cons (shen.lazyderef G V3028) (cons (shen.lazyderef Semantics V3028) ()))) V3028 V3029)))) false))) false)) false)) false))) false)) false)) false)) (do (shen.unbindv V2390 V3028) Result))) false))) (if (= Case false) (let V2405 (shen.lazyderef V3025 V3028) (if (cons? V2405) (let X2377 (hd V2405) (let Syntax (tl V2405) (let V2406 (shen.lazyderef V3027 V3028) (if (cons? V2406) (let X (hd V2406) (let Rule (tl V2406) (do (shen.incinfs) (unify! X X2377 V3028 (freeze (shen.get-syntax+semantics Syntax V3026 Rule V3028 V3029)))))) false)))) (if (shen.pvar? V2405) (let X2377 (shen.newpv V3028) (let Syntax (shen.newpv V3028) (do (shen.bindv V2405 (cons X2377 Syntax) V3028) (let Result (let V2407 (shen.lazyderef V3027 V3028) (if (cons? V2407) (let X (hd V2407) (let Rule (tl V2407) (do (shen.incinfs) (unify! X X2377 V3028 (freeze (shen.get-syntax+semantics Syntax V3026 Rule V3028 V3029)))))) false)) (do (shen.unbindv V2405 V3028) Result))))) false))) Case)) Case))))) - -(defun shen.syntax-check (V3030 V3031 V3032 V3033 V3034) (let Throwcontrol (shen.catchpoint) (shen.cutpoint Throwcontrol (let Case (let V2374 (shen.lazyderef V3030 V3033) (if (= () V2374) (do (shen.incinfs) (thaw V3034)) false)) (if (= Case false) (let Case (let V2375 (shen.lazyderef V3030 V3033) (if (cons? V2375) (let X (hd V2375) (let Syntax (tl V2375) (let C (shen.newpv V3033) (let X&& (shen.newpv V3033) (let B (shen.newpv V3033) (do (shen.incinfs) (fwhen (shen.grammar_symbol? (shen.lazyderef X V3033)) V3033 (freeze (cut Throwcontrol V3033 (freeze (shen.t* (cons X (cons : (cons (cons (cons list (cons B ())) (cons ==> (cons C ()))) ()))) V3032 V3033 (freeze (cut Throwcontrol V3033 (freeze (bind X&& (concat && (shen.lazyderef X V3033)) V3033 (freeze (cut Throwcontrol V3033 (freeze (shen.t* (cons X&& (cons : (cons (cons list (cons V3031 ())) ()))) (cons (cons X&& (cons : (cons (cons list (cons B ())) ()))) V3032) V3033 (freeze (cut Throwcontrol V3033 (freeze (shen.syntax-check Syntax V3031 V3032 V3033 V3034))))))))))))))))))))))) false)) (if (= Case false) (let V2376 (shen.lazyderef V3030 V3033) (if (cons? V2376) (let X (hd V2376) (let Syntax (tl V2376) (do (shen.incinfs) (shen.t* (cons X (cons : (cons V3031 ()))) V3032 V3033 (freeze (cut Throwcontrol V3033 (freeze (shen.syntax-check Syntax V3031 V3032 V3033 V3034)))))))) false)) Case)) Case))))) - -(defun shen.semantics-check (V3035 V3036 V3037 V3038 V3039) (let Semantics* (shen.newpv V3038) (do (shen.incinfs) (bind Semantics* (shen.curry (shen.rename-semantics (shen.deref V3035 V3038))) V3038 (freeze (shen.t* (cons Semantics* (cons : (cons V3036 ()))) V3037 V3038 V3039)))))) - -(defun shen.rename-semantics (V3040) (cond ((cons? V3040) (cons (shen.rename-semantics (hd V3040)) (shen.rename-semantics (tl V3040)))) ((shen.grammar_symbol? V3040) (cons shen.<-sem (cons V3040 ()))) (true V3040))) +(defun shen.remember (V2940 V2941 V2942 V2943) (let B (shen.newpv V2942) (do (shen.incinfs) (bind B (set (shen.deref V2940 V2942) (cons (shen.deref V2941 V2942) (value (shen.deref V2940 V2942)))) V2942 V2943)))) diff --git a/shen/klambda/toplevel.kl b/shen/klambda/toplevel.kl index 5a154fb..9f7a37a 100644 --- a/shen/klambda/toplevel.kl +++ b/shen/klambda/toplevel.kl @@ -51,10 +51,6 @@ (defun shen.loop () (do (shen.initialise_environment) (do (shen.prompt) (do (trap-error (shen.read-evaluate-print) (lambda E (pr (error-to-string E) (stoutput)))) (shen.loop))))) -(defun version (V2288) (set *version* V2288)) - -(version "version 13") - (defun shen.credits () (do (shen.prhush " Shen 2010, copyright (C) 2010 Mark Tarver " (stoutput)) (do (shen.prhush "released under the Shen license @@ -65,27 +61,27 @@ port " (shen.app (value *port*) (cn " ported by " (shen.app (value *porters*) " (defun shen.initialise_environment () (shen.multiple-set (cons shen.*call* (cons 0 (cons shen.*infs* (cons 0 (cons shen.*process-counter* (cons 0 (cons shen.*catch* (cons 0 ())))))))))) -(defun shen.multiple-set (V2289) (cond ((= () V2289) ()) ((and (cons? V2289) (cons? (tl V2289))) (do (set (hd V2289) (hd (tl V2289))) (shen.multiple-set (tl (tl V2289))))) (true (shen.sys-error shen.multiple-set)))) +(defun shen.multiple-set (V2374) (cond ((= () V2374) ()) ((and (cons? V2374) (cons? (tl V2374))) (do (set (hd V2374) (hd (tl V2374))) (shen.multiple-set (tl (tl V2374))))) (true (shen.sys-error shen.multiple-set)))) -(defun destroy (V2290) (declare V2290 ())) +(defun destroy (V2375) (declare V2375 symbol)) (set shen.*history* ()) (defun shen.read-evaluate-print () (let Lineread (shen.toplineread) (let History (value shen.*history*) (let NewLineread (shen.retrieve-from-history-if-needed Lineread History) (let NewHistory (shen.update_history NewLineread History) (let Parsed (fst NewLineread) (shen.toplevel Parsed))))))) -(defun shen.retrieve-from-history-if-needed (V2300 V2301) (cond ((and (tuple? V2300) (and (cons? (snd V2300)) (element? (hd (snd V2300)) (cons (shen.space) (cons (shen.newline) ()))))) (shen.retrieve-from-history-if-needed (@p (fst V2300) (tl (snd V2300))) V2301)) ((and (tuple? V2300) (and (cons? (snd V2300)) (and (cons? (tl (snd V2300))) (and (= () (tl (tl (snd V2300)))) (and (cons? V2301) (and (= (hd (snd V2300)) (shen.exclamation)) (= (hd (tl (snd V2300))) (shen.exclamation)))))))) (let PastPrint (shen.prbytes (snd (hd V2301))) (hd V2301))) ((and (tuple? V2300) (and (cons? (snd V2300)) (= (hd (snd V2300)) (shen.exclamation)))) (let Key? (shen.make-key (tl (snd V2300)) V2301) (let Find (head (shen.find-past-inputs Key? V2301)) (let PastPrint (shen.prbytes (snd Find)) Find)))) ((and (tuple? V2300) (and (cons? (snd V2300)) (and (= () (tl (snd V2300))) (= (hd (snd V2300)) (shen.percent))))) (do (shen.print-past-inputs (lambda X true) (reverse V2301) 0) (abort))) ((and (tuple? V2300) (and (cons? (snd V2300)) (= (hd (snd V2300)) (shen.percent)))) (let Key? (shen.make-key (tl (snd V2300)) V2301) (let Pastprint (shen.print-past-inputs Key? (reverse V2301) 0) (abort)))) (true V2300))) +(defun shen.retrieve-from-history-if-needed (V2385 V2386) (cond ((and (tuple? V2385) (and (cons? (snd V2385)) (element? (hd (snd V2385)) (cons (shen.space) (cons (shen.newline) ()))))) (shen.retrieve-from-history-if-needed (@p (fst V2385) (tl (snd V2385))) V2386)) ((and (tuple? V2385) (and (cons? (snd V2385)) (and (cons? (tl (snd V2385))) (and (= () (tl (tl (snd V2385)))) (and (cons? V2386) (and (= (hd (snd V2385)) (shen.exclamation)) (= (hd (tl (snd V2385))) (shen.exclamation)))))))) (let PastPrint (shen.prbytes (snd (hd V2386))) (hd V2386))) ((and (tuple? V2385) (and (cons? (snd V2385)) (= (hd (snd V2385)) (shen.exclamation)))) (let Key? (shen.make-key (tl (snd V2385)) V2386) (let Find (head (shen.find-past-inputs Key? V2386)) (let PastPrint (shen.prbytes (snd Find)) Find)))) ((and (tuple? V2385) (and (cons? (snd V2385)) (and (= () (tl (snd V2385))) (= (hd (snd V2385)) (shen.percent))))) (do (shen.print-past-inputs (lambda X true) (reverse V2386) 0) (abort))) ((and (tuple? V2385) (and (cons? (snd V2385)) (= (hd (snd V2385)) (shen.percent)))) (let Key? (shen.make-key (tl (snd V2385)) V2386) (let Pastprint (shen.print-past-inputs Key? (reverse V2386) 0) (abort)))) (true V2385))) (defun shen.percent () 37) (defun shen.exclamation () 33) -(defun shen.prbytes (V2302) (do (map (lambda Byte (pr (n->string Byte) (stoutput))) V2302) (nl 1))) +(defun shen.prbytes (V2387) (do (map (lambda Byte (pr (n->string Byte) (stoutput))) V2387) (nl 1))) -(defun shen.update_history (V2303 V2304) (set shen.*history* (cons V2303 V2304))) +(defun shen.update_history (V2388 V2389) (set shen.*history* (cons V2388 V2389))) (defun shen.toplineread () (shen.toplineread_loop (read-byte (stinput)) ())) -(defun shen.toplineread_loop (V2306 V2307) (cond ((= V2306 (shen.hat)) (simple-error "line read aborted")) ((element? V2306 (cons (shen.newline) (cons (shen.carriage-return) ()))) (let Line (compile shen. V2307 (lambda E shen.nextline)) (if (or (= Line shen.nextline) (empty? Line)) (shen.toplineread_loop (read-byte (stinput)) (append V2307 (cons V2306 ()))) (@p Line V2307)))) (true (shen.toplineread_loop (read-byte (stinput)) (append V2307 (cons V2306 ())))))) +(defun shen.toplineread_loop (V2391 V2392) (cond ((= V2391 (shen.hat)) (simple-error "line read aborted")) ((element? V2391 (cons (shen.newline) (cons (shen.carriage-return) ()))) (let Line (compile (lambda X2372 (shen. X2372)) V2392 (lambda E shen.nextline)) (let It (shen.record-it V2392) (if (or (= Line shen.nextline) (empty? Line)) (shen.toplineread_loop (read-byte (stinput)) (append V2392 (cons V2391 ()))) (@p Line V2392))))) (true (shen.toplineread_loop (read-byte (stinput)) (append V2392 (cons V2391 ())))))) (defun shen.hat () 94) @@ -93,7 +89,7 @@ port " (shen.app (value *port*) (cn " ported by " (shen.app (value *porters*) " (defun shen.carriage-return () 13) -(defun tc (V2312) (cond ((= + V2312) (set shen.*tc* true)) ((= - V2312) (set shen.*tc* false)) (true (simple-error "tc expects a + or -")))) +(defun tc (V2397) (cond ((= + V2397) (set shen.*tc* true)) ((= - V2397) (set shen.*tc* false)) (true (simple-error "tc expects a + or -")))) (defun shen.prompt () (if (value shen.*tc*) (shen.prhush (cn " @@ -101,16 +97,16 @@ port " (shen.app (value *port*) (cn " ported by " (shen.app (value *porters*) " (" (shen.app (length (value shen.*history*)) "-) " shen.a)) (stoutput)))) -(defun shen.toplevel (V2313) (shen.toplevel_evaluate V2313 (value shen.*tc*))) +(defun shen.toplevel (V2398) (shen.toplevel_evaluate V2398 (value shen.*tc*))) -(defun shen.find-past-inputs (V2314 V2315) (let F (shen.find V2314 V2315) (if (empty? F) (simple-error "input not found +(defun shen.find-past-inputs (V2399 V2400) (let F (shen.find V2399 V2400) (if (empty? F) (simple-error "input not found ") F))) -(defun shen.make-key (V2316 V2317) (let Atom (hd (compile shen. V2316 (lambda E (if (cons? E) (simple-error (cn "parse error here: " (shen.app E " +(defun shen.make-key (V2401 V2402) (let Atom (hd (compile (lambda X2373 (shen. X2373)) V2401 (lambda E (if (cons? E) (simple-error (cn "parse error here: " (shen.app E " " shen.s))) (simple-error "parse error -"))))) (if (integer? Atom) (lambda X (= X (nth (+ Atom 1) (reverse V2317)))) (lambda X (shen.prefix? V2316 (shen.trim-gubbins (snd X))))))) +"))))) (if (integer? Atom) (lambda X (= X (nth (+ Atom 1) (reverse V2402)))) (lambda X (shen.prefix? V2401 (shen.trim-gubbins (snd X))))))) -(defun shen.trim-gubbins (V2318) (cond ((and (cons? V2318) (= (hd V2318) (shen.space))) (shen.trim-gubbins (tl V2318))) ((and (cons? V2318) (= (hd V2318) (shen.newline))) (shen.trim-gubbins (tl V2318))) ((and (cons? V2318) (= (hd V2318) (shen.carriage-return))) (shen.trim-gubbins (tl V2318))) ((and (cons? V2318) (= (hd V2318) (shen.tab))) (shen.trim-gubbins (tl V2318))) ((and (cons? V2318) (= (hd V2318) (shen.left-round))) (shen.trim-gubbins (tl V2318))) (true V2318))) +(defun shen.trim-gubbins (V2403) (cond ((and (cons? V2403) (= (hd V2403) (shen.space))) (shen.trim-gubbins (tl V2403))) ((and (cons? V2403) (= (hd V2403) (shen.newline))) (shen.trim-gubbins (tl V2403))) ((and (cons? V2403) (= (hd V2403) (shen.carriage-return))) (shen.trim-gubbins (tl V2403))) ((and (cons? V2403) (= (hd V2403) (shen.tab))) (shen.trim-gubbins (tl V2403))) ((and (cons? V2403) (= (hd V2403) (shen.left-round))) (shen.trim-gubbins (tl V2403))) (true V2403))) (defun shen.space () 32) @@ -118,22 +114,22 @@ port " (shen.app (value *port*) (cn " ported by " (shen.app (value *porters*) " (defun shen.left-round () 40) -(defun shen.find (V2325 V2326) (cond ((= () V2326) ()) ((and (cons? V2326) (V2325 (hd V2326))) (cons (hd V2326) (shen.find V2325 (tl V2326)))) ((cons? V2326) (shen.find V2325 (tl V2326))) (true (shen.sys-error shen.find)))) +(defun shen.find (V2410 V2411) (cond ((= () V2411) ()) ((and (cons? V2411) (V2410 (hd V2411))) (cons (hd V2411) (shen.find V2410 (tl V2411)))) ((cons? V2411) (shen.find V2410 (tl V2411))) (true (shen.sys-error shen.find)))) -(defun shen.prefix? (V2337 V2338) (cond ((= () V2337) true) ((and (cons? V2337) (and (cons? V2338) (= (hd V2338) (hd V2337)))) (shen.prefix? (tl V2337) (tl V2338))) (true false))) +(defun shen.prefix? (V2422 V2423) (cond ((= () V2422) true) ((and (cons? V2422) (and (cons? V2423) (= (hd V2423) (hd V2422)))) (shen.prefix? (tl V2422) (tl V2423))) (true false))) -(defun shen.print-past-inputs (V2348 V2349 V2350) (cond ((= () V2349) _) ((and (cons? V2349) (not (V2348 (hd V2349)))) (shen.print-past-inputs V2348 (tl V2349) (+ V2350 1))) ((and (cons? V2349) (tuple? (hd V2349))) (do (shen.prhush (shen.app V2350 ". " shen.a) (stoutput)) (do (shen.prbytes (snd (hd V2349))) (shen.print-past-inputs V2348 (tl V2349) (+ V2350 1))))) (true (shen.sys-error shen.print-past-inputs)))) +(defun shen.print-past-inputs (V2433 V2434 V2435) (cond ((= () V2434) _) ((and (cons? V2434) (not (V2433 (hd V2434)))) (shen.print-past-inputs V2433 (tl V2434) (+ V2435 1))) ((and (cons? V2434) (tuple? (hd V2434))) (do (shen.prhush (shen.app V2435 ". " shen.a) (stoutput)) (do (shen.prbytes (snd (hd V2434))) (shen.print-past-inputs V2433 (tl V2434) (+ V2435 1))))) (true (shen.sys-error shen.print-past-inputs)))) -(defun shen.toplevel_evaluate (V2351 V2352) (cond ((and (cons? V2351) (and (cons? (tl V2351)) (and (= : (hd (tl V2351))) (and (cons? (tl (tl V2351))) (and (= () (tl (tl (tl V2351)))) (= true V2352)))))) (shen.typecheck-and-evaluate (hd V2351) (hd (tl (tl V2351))))) ((and (cons? V2351) (cons? (tl V2351))) (do (shen.toplevel_evaluate (cons (hd V2351) ()) V2352) (do (nl 1) (shen.toplevel_evaluate (tl V2351) V2352)))) ((and (cons? V2351) (and (= () (tl V2351)) (= true V2352))) (shen.typecheck-and-evaluate (hd V2351) (gensym A))) ((and (cons? V2351) (and (= () (tl V2351)) (= false V2352))) (let Eval (shen.eval-without-macros (hd V2351)) (print Eval))) (true (shen.sys-error shen.toplevel_evaluate)))) +(defun shen.toplevel_evaluate (V2436 V2437) (cond ((and (cons? V2436) (and (cons? (tl V2436)) (and (= : (hd (tl V2436))) (and (cons? (tl (tl V2436))) (and (= () (tl (tl (tl V2436)))) (= true V2437)))))) (shen.typecheck-and-evaluate (hd V2436) (hd (tl (tl V2436))))) ((and (cons? V2436) (cons? (tl V2436))) (do (shen.toplevel_evaluate (cons (hd V2436) ()) V2437) (do (nl 1) (shen.toplevel_evaluate (tl V2436) V2437)))) ((and (cons? V2436) (and (= () (tl V2436)) (= true V2437))) (shen.typecheck-and-evaluate (hd V2436) (gensym A))) ((and (cons? V2436) (and (= () (tl V2436)) (= false V2437))) (let Eval (shen.eval-without-macros (hd V2436)) (print Eval))) (true (shen.sys-error shen.toplevel_evaluate)))) -(defun shen.typecheck-and-evaluate (V2353 V2354) (let Typecheck (shen.typecheck V2353 V2354) (if (= Typecheck false) (simple-error "type error -") (let Eval (shen.eval-without-macros V2353) (let Type (shen.pretty-type Typecheck) (shen.prhush (shen.app Eval (cn " : " (shen.app Type "" shen.r)) shen.s) (stoutput))))))) +(defun shen.typecheck-and-evaluate (V2438 V2439) (let Typecheck (shen.typecheck V2438 V2439) (if (= Typecheck false) (simple-error "type error +") (let Eval (shen.eval-without-macros V2438) (let Type (shen.pretty-type Typecheck) (shen.prhush (shen.app Eval (cn " : " (shen.app Type "" shen.r)) shen.s) (stoutput))))))) -(defun shen.pretty-type (V2355) (shen.mult_subst (value shen.*alphabet*) (shen.extract-pvars V2355) V2355)) +(defun shen.pretty-type (V2440) (shen.mult_subst (value shen.*alphabet*) (shen.extract-pvars V2440) V2440)) -(defun shen.extract-pvars (V2360) (cond ((shen.pvar? V2360) (cons V2360 ())) ((cons? V2360) (union (shen.extract-pvars (hd V2360)) (shen.extract-pvars (tl V2360)))) (true ()))) +(defun shen.extract-pvars (V2445) (cond ((shen.pvar? V2445) (cons V2445 ())) ((cons? V2445) (union (shen.extract-pvars (hd V2445)) (shen.extract-pvars (tl V2445)))) (true ()))) -(defun shen.mult_subst (V2365 V2366 V2367) (cond ((= () V2365) V2367) ((= () V2366) V2367) ((and (cons? V2365) (cons? V2366)) (shen.mult_subst (tl V2365) (tl V2366) (subst (hd V2365) (hd V2366) V2367))) (true (shen.sys-error shen.mult_subst)))) +(defun shen.mult_subst (V2450 V2451 V2452) (cond ((= () V2450) V2452) ((= () V2451) V2452) ((and (cons? V2450) (cons? V2451)) (shen.mult_subst (tl V2450) (tl V2451) (subst (hd V2450) (hd V2451) V2452))) (true (shen.sys-error shen.mult_subst)))) diff --git a/shen/klambda/track.kl b/shen/klambda/track.kl index 298b4b7..7139779 100644 --- a/shen/klambda/track.kl +++ b/shen/klambda/track.kl @@ -47,57 +47,57 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun shen.f_error (V2062) (do (shen.prhush (cn "partial function " (shen.app V2062 "; -" shen.a)) (stoutput)) (do (if (and (not (shen.tracked? V2062)) (y-or-n? (cn "track " (shen.app V2062 "? " shen.a)))) (shen.track-function (ps V2062)) shen.ok) (simple-error "aborted")))) +"(defun shen.f_error (V2122) (do (shen.prhush (cn "partial function " (shen.app V2122 "; +" shen.a)) (stoutput)) (do (if (and (not (shen.tracked? V2122)) (y-or-n? (cn "track " (shen.app V2122 "? " shen.a)))) (shen.track-function (ps V2122)) shen.ok) (simple-error "aborted")))) -(defun shen.tracked? (V2063) (element? V2063 (value shen.*tracking*))) +(defun shen.tracked? (V2123) (element? V2123 (value shen.*tracking*))) -(defun track (V2064) (let Source (ps V2064) (shen.track-function Source))) +(defun track (V2124) (let Source (ps V2124) (shen.track-function Source))) -(defun shen.track-function (V2065) (cond ((and (cons? V2065) (and (= defun (hd V2065)) (and (cons? (tl V2065)) (and (cons? (tl (tl V2065))) (and (cons? (tl (tl (tl V2065)))) (= () (tl (tl (tl (tl V2065)))))))))) (let KL (cons defun (cons (hd (tl V2065)) (cons (hd (tl (tl V2065))) (cons (shen.insert-tracking-code (hd (tl V2065)) (hd (tl (tl V2065))) (hd (tl (tl (tl V2065))))) ())))) (let Ob (eval KL) (let Tr (set shen.*tracking* (cons Ob (value shen.*tracking*))) Ob)))) (true (shen.sys-error shen.track-function)))) +(defun shen.track-function (V2125) (cond ((and (cons? V2125) (and (= defun (hd V2125)) (and (cons? (tl V2125)) (and (cons? (tl (tl V2125))) (and (cons? (tl (tl (tl V2125)))) (= () (tl (tl (tl (tl V2125)))))))))) (let KL (cons defun (cons (hd (tl V2125)) (cons (hd (tl (tl V2125))) (cons (shen.insert-tracking-code (hd (tl V2125)) (hd (tl (tl V2125))) (hd (tl (tl (tl V2125))))) ())))) (let Ob (eval-kl KL) (let Tr (set shen.*tracking* (cons Ob (value shen.*tracking*))) Ob)))) (true (shen.sys-error shen.track-function)))) -(defun shen.insert-tracking-code (V2066 V2067 V2068) (cons do (cons (cons set (cons shen.*call* (cons (cons + (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.input-track (cons (cons value (cons shen.*call* ())) (cons V2066 (cons (shen.cons_form V2067) ())))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons (cons let (cons Result (cons V2068 (cons (cons do (cons (cons shen.output-track (cons (cons value (cons shen.*call* ())) (cons V2066 (cons Result ())))) (cons (cons do (cons (cons set (cons shen.*call* (cons (cons - (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons Result ()))) ()))) ()))) ())))) ()))) ()))) ())))) +(defun shen.insert-tracking-code (V2126 V2127 V2128) (cons do (cons (cons set (cons shen.*call* (cons (cons + (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.input-track (cons (cons value (cons shen.*call* ())) (cons V2126 (cons (shen.cons_form V2127) ())))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons (cons let (cons Result (cons V2128 (cons (cons do (cons (cons shen.output-track (cons (cons value (cons shen.*call* ())) (cons V2126 (cons Result ())))) (cons (cons do (cons (cons set (cons shen.*call* (cons (cons - (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons Result ()))) ()))) ()))) ())))) ()))) ()))) ())))) (set shen.*step* false) -(defun step (V2073) (cond ((= + V2073) (set shen.*step* true)) ((= - V2073) (set shen.*step* false)) (true (simple-error "step expects a + or a -. +(defun step (V2133) (cond ((= + V2133) (set shen.*step* true)) ((= - V2133) (set shen.*step* false)) (true (simple-error "step expects a + or a -. ")))) -(defun spy (V2078) (cond ((= + V2078) (set shen.*spy* true)) ((= - V2078) (set shen.*spy* false)) (true (simple-error "spy expects a + or a -. +(defun spy (V2138) (cond ((= + V2138) (set shen.*spy* true)) ((= - V2138) (set shen.*spy* false)) (true (simple-error "spy expects a + or a -. ")))) (defun shen.terpri-or-read-char () (if (value shen.*step*) (shen.check-byte (read-byte (value *stinput*))) (nl 1))) -(defun shen.check-byte (V2083) (cond ((= V2083 (shen.hat)) (simple-error "aborted")) (true true))) +(defun shen.check-byte (V2143) (cond ((= V2143 (shen.hat)) (simple-error "aborted")) (true true))) -(defun shen.input-track (V2084 V2085 V2086) (do (shen.prhush (cn " -" (shen.app (shen.spaces V2084) (cn "<" (shen.app V2084 (cn "> Inputs to " (shen.app V2085 (cn " -" (shen.app (shen.spaces V2084) "" shen.a)) shen.a)) shen.a)) shen.a)) (stoutput)) (shen.recursively-print V2086))) +(defun shen.input-track (V2144 V2145 V2146) (do (shen.prhush (cn " +" (shen.app (shen.spaces V2144) (cn "<" (shen.app V2144 (cn "> Inputs to " (shen.app V2145 (cn " +" (shen.app (shen.spaces V2144) "" shen.a)) shen.a)) shen.a)) shen.a)) (stoutput)) (shen.recursively-print V2146))) -(defun shen.recursively-print (V2087) (cond ((= () V2087) (shen.prhush " ==>" (stoutput))) ((cons? V2087) (do (print (hd V2087)) (do (shen.prhush ", " (stoutput)) (shen.recursively-print (tl V2087))))) (true (shen.sys-error shen.recursively-print)))) +(defun shen.recursively-print (V2147) (cond ((= () V2147) (shen.prhush " ==>" (stoutput))) ((cons? V2147) (do (print (hd V2147)) (do (shen.prhush ", " (stoutput)) (shen.recursively-print (tl V2147))))) (true (shen.sys-error shen.recursively-print)))) -(defun shen.spaces (V2088) (cond ((= 0 V2088) "") (true (cn " " (shen.spaces (- V2088 1)))))) +(defun shen.spaces (V2148) (cond ((= 0 V2148) "") (true (cn " " (shen.spaces (- V2148 1)))))) -(defun shen.output-track (V2089 V2090 V2091) (shen.prhush (cn " -" (shen.app (shen.spaces V2089) (cn "<" (shen.app V2089 (cn "> Output from " (shen.app V2090 (cn " -" (shen.app (shen.spaces V2089) (cn "==> " (shen.app V2091 "" shen.s)) shen.a)) shen.a)) shen.a)) shen.a)) (stoutput))) +(defun shen.output-track (V2149 V2150 V2151) (shen.prhush (cn " +" (shen.app (shen.spaces V2149) (cn "<" (shen.app V2149 (cn "> Output from " (shen.app V2150 (cn " +" (shen.app (shen.spaces V2149) (cn "==> " (shen.app V2151 "" shen.s)) shen.a)) shen.a)) shen.a)) shen.a)) (stoutput))) -(defun untrack (V2092) (eval (ps V2092))) +(defun untrack (V2152) (eval (ps V2152))) -(defun profile (V2093) (shen.profile-help (ps V2093))) +(defun profile (V2153) (shen.profile-help (ps V2153))) -(defun shen.profile-help (V2098) (cond ((and (cons? V2098) (and (= defun (hd V2098)) (and (cons? (tl V2098)) (and (cons? (tl (tl V2098))) (and (cons? (tl (tl (tl V2098)))) (= () (tl (tl (tl (tl V2098)))))))))) (let G (gensym shen.f) (let Profile (cons defun (cons (hd (tl V2098)) (cons (hd (tl (tl V2098))) (cons (shen.profile-func (hd (tl V2098)) (hd (tl (tl V2098))) (cons G (hd (tl (tl V2098))))) ())))) (let Def (cons defun (cons G (cons (hd (tl (tl V2098))) (cons (subst G (hd (tl V2098)) (hd (tl (tl (tl V2098))))) ())))) (let CompileProfile (shen.eval-without-macros Profile) (let CompileG (shen.eval-without-macros Def) (hd (tl V2098)))))))) (true (simple-error "Cannot profile. +(defun shen.profile-help (V2158) (cond ((and (cons? V2158) (and (= defun (hd V2158)) (and (cons? (tl V2158)) (and (cons? (tl (tl V2158))) (and (cons? (tl (tl (tl V2158)))) (= () (tl (tl (tl (tl V2158)))))))))) (let G (gensym shen.f) (let Profile (cons defun (cons (hd (tl V2158)) (cons (hd (tl (tl V2158))) (cons (shen.profile-func (hd (tl V2158)) (hd (tl (tl V2158))) (cons G (hd (tl (tl V2158))))) ())))) (let Def (cons defun (cons G (cons (hd (tl (tl V2158))) (cons (subst G (hd (tl V2158)) (hd (tl (tl (tl V2158))))) ())))) (let CompileProfile (shen.eval-without-macros Profile) (let CompileG (shen.eval-without-macros Def) (hd (tl V2158)))))))) (true (simple-error "Cannot profile. ")))) -(defun unprofile (V2099) (untrack V2099)) +(defun unprofile (V2159) (untrack V2159)) -(defun shen.profile-func (V2100 V2101 V2102) (cons let (cons Start (cons (cons get-time (cons run ())) (cons (cons let (cons Result (cons V2102 (cons (cons let (cons Finish (cons (cons - (cons (cons get-time (cons run ())) (cons Start ()))) (cons (cons let (cons Record (cons (cons shen.put-profile (cons V2100 (cons (cons + (cons (cons shen.get-profile (cons V2100 ())) (cons Finish ()))) ()))) (cons Result ())))) ())))) ())))) ()))))) +(defun shen.profile-func (V2160 V2161 V2162) (cons let (cons Start (cons (cons get-time (cons run ())) (cons (cons let (cons Result (cons V2162 (cons (cons let (cons Finish (cons (cons - (cons (cons get-time (cons run ())) (cons Start ()))) (cons (cons let (cons Record (cons (cons shen.put-profile (cons V2160 (cons (cons + (cons (cons shen.get-profile (cons V2160 ())) (cons Finish ()))) ()))) (cons Result ())))) ())))) ())))) ()))))) -(defun profile-results (V2103) (let Results (shen.get-profile V2103) (let Initialise (shen.put-profile V2103 0) (@p V2103 Results)))) +(defun profile-results (V2163) (let Results (shen.get-profile V2163) (let Initialise (shen.put-profile V2163 0) (@p V2163 Results)))) -(defun shen.get-profile (V2104) (trap-error (get V2104 profile (value *property-vector*)) (lambda E 0))) +(defun shen.get-profile (V2164) (trap-error (get V2164 profile (value *property-vector*)) (lambda E 0))) -(defun shen.put-profile (V2105 V2106) (put V2105 profile V2106 (value *property-vector*))) +(defun shen.put-profile (V2165 V2166) (put V2165 profile V2166 (value *property-vector*))) diff --git a/shen/klambda/types.kl b/shen/klambda/types.kl index b3781a8..3da7970 100644 --- a/shen/klambda/types.kl +++ b/shen/klambda/types.kl @@ -47,18 +47,14 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun declare (V2107 V2108) (let Record (set shen.*signedfuncs* (cons (cons V2107 V2108) (value shen.*signedfuncs*))) (let Variancy (trap-error (shen.variancy-test V2107 V2108) (lambda E shen.skip)) (let Type (shen.rcons_form (shen.demodulate V2108)) (let F* (concat shen.type-signature-of- V2107) (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) V2107))))))))))) +"(defun declare (V2168 V2169) (let Record (set shen.*signedfuncs* (cons (cons V2168 V2169) (value shen.*signedfuncs*))) (let Variancy (trap-error (shen.variancy-test V2168 V2169) (lambda E shen.skip)) (let Type (shen.rcons_form (shen.demodulate V2169)) (let F* (concat shen.type-signature-of- V2168) (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) V2168))))))))))) -(defun shen.demodulate (V2109) (fix shen.demodh V2109)) +(defun shen.demodulate (V2170) (trap-error (let Demod (shen.walk (lambda X2167 (shen.demod X2167)) V2170) (if (= Demod V2170) V2170 (shen.demodulate Demod))) (lambda E V2170))) -(defun shen.demodh (V2110) (cond ((cons? V2110) (map shen.demodh V2110)) (true (shen.demod-atom V2110)))) - -(defun shen.demod-atom (V2111) (let Val (assoc V2111 (value shen.*synonyms*)) (if (empty? Val) V2111 (tl Val)))) - -(defun shen.variancy-test (V2112 V2113) (let TypeF (shen.typecheck V2112 B) (let Check (if (= symbol TypeF) shen.skip (if (shen.variant? TypeF V2113) shen.skip (shen.prhush (cn "warning: changing the type of " (shen.app V2112 " may create errors +(defun shen.variancy-test (V2171 V2172) (let TypeF (shen.typecheck V2171 B) (let Check (if (= symbol TypeF) shen.skip (if (shen.variant? TypeF V2172) shen.skip (shen.prhush (cn "warning: changing the type of " (shen.app V2171 " may create errors " shen.a)) (stoutput)))) shen.skip))) -(defun shen.variant? (V2122 V2123) (cond ((= V2123 V2122) true) ((and (cons? V2122) (and (cons? V2123) (= (hd V2123) (hd V2122)))) (shen.variant? (tl V2122) (tl V2123))) ((and (cons? V2122) (and (cons? V2123) (and (shen.pvar? (hd V2122)) (variable? (hd V2123))))) (shen.variant? (subst shen.a (hd V2122) (tl V2122)) (subst shen.a (hd V2123) (tl V2123)))) ((and (cons? V2122) (and (cons? (hd V2122)) (and (cons? V2123) (cons? (hd V2123))))) (shen.variant? (append (hd V2122) (tl V2122)) (append (hd V2123) (tl V2123)))) (true false))) +(defun shen.variant? (V2181 V2182) (cond ((= V2182 V2181) true) ((and (cons? V2181) (and (cons? V2182) (= (hd V2182) (hd V2181)))) (shen.variant? (tl V2181) (tl V2182))) ((and (cons? V2181) (and (cons? V2182) (and (shen.pvar? (hd V2181)) (variable? (hd V2182))))) (shen.variant? (subst shen.a (hd V2181) (tl V2181)) (subst shen.a (hd V2182) (tl V2182)))) ((and (cons? V2181) (and (cons? (hd V2181)) (and (cons? V2182) (cons? (hd V2182))))) (shen.variant? (append (hd V2181) (tl V2181)) (append (hd V2182) (tl V2182)))) (true false))) (declare absvector? (cons A (cons --> (cons boolean ())))) @@ -84,11 +80,11 @@ (declare cn (cons string (cons --> (cons (cons string (cons --> (cons string ()))) ())))) -(declare compile (cons (cons (cons list (cons A ())) (cons ==> (cons B ()))) (cons --> (cons (cons (cons list (cons A ())) (cons --> (cons (cons (cons (cons list (cons A ())) (cons --> (cons B ()))) (cons --> (cons B ()))) ()))) ())))) +(declare compile (cons (cons A (cons ==> (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 (cons A (cons --> (cons B ()))) ())))) +(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 ())) ()))) ())))) @@ -138,6 +134,10 @@ (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 ())) ())))) @@ -152,6 +152,8 @@ (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 ())))) @@ -182,6 +184,12 @@ (declare or (cons boolean (cons --> (cons (cons boolean (cons --> (cons boolean ()))) ())))) +(declare os (cons --> (cons string ()))) + +(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 ()))) ())))) @@ -194,7 +202,7 @@ (declare shen.proc-nl (cons string (cons --> (cons string ())))) -(declare profile-results (cons A (cons --> (cons symbol ())))) +(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 ())))) @@ -214,6 +222,8 @@ (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 ())) ())))) @@ -240,7 +250,7 @@ (declare string->symbol (cons string (cons --> (cons symbol ())))) -(declare shen.sum (cons (cons list (cons number ())) (cons --> (cons number ())))) +(declare sum (cons (cons list (cons number ())) (cons --> (cons number ())))) (declare symbol? (cons A (cons --> (cons boolean ())))) @@ -262,8 +272,6 @@ (declare trap-error (cons A (cons --> (cons (cons (cons exception (cons --> (cons A ()))) (cons --> (cons A ()))) ())))) -(declare shen.truncate (cons string (cons --> (cons string ())))) - (declare tuple? (cons A (cons --> (cons boolean ())))) (declare undefmacro (cons symbol (cons --> (cons symbol ())))) @@ -280,7 +288,7 @@ (declare vector? (cons A (cons --> (cons boolean ())))) -(declare version (cons string (cons --> (cons string ())))) +(declare version (cons --> (cons string ()))) (declare write-to-file (cons string (cons --> (cons (cons A (cons --> (cons A ()))) ())))) @@ -308,5 +316,9 @@ (declare == (cons A (cons --> (cons (cons B (cons --> (cons boolean ()))) ())))) +(declare shen.in-> (cons (cons A (cons ==> (cons B ()))) (cons --> (cons A ())))) + +(declare shen.<-out (cons (cons A (cons ==> (cons B ()))) (cons --> (cons B ())))) + diff --git a/shen/klambda/writer.kl b/shen/klambda/writer.kl index abf8cf8..bd98b31 100644 --- a/shen/klambda/writer.kl +++ b/shen/klambda/writer.kl @@ -47,59 +47,59 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun pr (V2210 V2211) (trap-error (shen.prh V2210 V2211 0) (lambda E V2210))) +"(defun pr (V2294 V2295) (trap-error (shen.prh V2294 V2295 0) (lambda E V2294))) -(defun shen.prh (V2212 V2213 V2214) (shen.prh V2212 V2213 (shen.write-char-and-inc V2212 V2213 V2214))) +(defun shen.prh (V2296 V2297 V2298) (shen.prh V2296 V2297 (shen.write-char-and-inc V2296 V2297 V2298))) -(defun shen.write-char-and-inc (V2215 V2216 V2217) (do (write-byte (string->n (pos V2215 V2217)) V2216) (+ V2217 1))) +(defun shen.write-char-and-inc (V2299 V2300 V2301) (do (write-byte (string->n (pos V2299 V2301)) V2300) (+ V2301 1))) -(defun print (V2218) (let String (shen.insert V2218 "~S") (let Print (shen.prhush String (stoutput)) V2218))) +(defun print (V2302) (let String (shen.insert V2302 "~S") (let Print (shen.prhush String (stoutput)) V2302))) -(defun shen.prhush (V2219 V2220) (if (value *hush*) V2219 (pr V2219 V2220))) +(defun shen.prhush (V2303 V2304) (if (value *hush*) V2303 (pr V2303 V2304))) -(defun shen.mkstr (V2221 V2222) (cond ((string? V2221) (shen.mkstr-l (shen.proc-nl V2221) V2222)) (true (shen.mkstr-r (cons shen.proc-nl (cons V2221 ())) V2222)))) +(defun shen.mkstr (V2305 V2306) (cond ((string? V2305) (shen.mkstr-l (shen.proc-nl V2305) V2306)) (true (shen.mkstr-r (cons shen.proc-nl (cons V2305 ())) V2306)))) -(defun shen.mkstr-l (V2223 V2224) (cond ((= () V2224) V2223) ((cons? V2224) (shen.mkstr-l (shen.insert-l (hd V2224) V2223) (tl V2224))) (true (shen.sys-error shen.mkstr-l)))) +(defun shen.mkstr-l (V2307 V2308) (cond ((= () V2308) V2307) ((cons? V2308) (shen.mkstr-l (shen.insert-l (hd V2308) V2307) (tl V2308))) (true (shen.sys-error shen.mkstr-l)))) -(defun shen.insert-l (V2227 V2228) (cond ((= "" V2228) "") ((and (shen.+string? V2228) (and (= "~" (pos V2228 0)) (and (shen.+string? (tlstr V2228)) (= "A" (pos (tlstr V2228) 0))))) (cons shen.app (cons V2227 (cons (tlstr (tlstr V2228)) (cons shen.a ()))))) ((and (shen.+string? V2228) (and (= "~" (pos V2228 0)) (and (shen.+string? (tlstr V2228)) (= "R" (pos (tlstr V2228) 0))))) (cons shen.app (cons V2227 (cons (tlstr (tlstr V2228)) (cons shen.r ()))))) ((and (shen.+string? V2228) (and (= "~" (pos V2228 0)) (and (shen.+string? (tlstr V2228)) (= "S" (pos (tlstr V2228) 0))))) (cons shen.app (cons V2227 (cons (tlstr (tlstr V2228)) (cons shen.s ()))))) ((shen.+string? V2228) (shen.factor-cn (cons cn (cons (pos V2228 0) (cons (shen.insert-l V2227 (tlstr V2228)) ()))))) ((and (cons? V2228) (and (= cn (hd V2228)) (and (cons? (tl V2228)) (and (cons? (tl (tl V2228))) (= () (tl (tl (tl V2228)))))))) (cons cn (cons (hd (tl V2228)) (cons (shen.insert-l V2227 (hd (tl (tl V2228)))) ())))) ((and (cons? V2228) (and (= shen.app (hd V2228)) (and (cons? (tl V2228)) (and (cons? (tl (tl V2228))) (and (cons? (tl (tl (tl V2228)))) (= () (tl (tl (tl (tl V2228)))))))))) (cons shen.app (cons (hd (tl V2228)) (cons (shen.insert-l V2227 (hd (tl (tl V2228)))) (tl (tl (tl V2228))))))) (true (shen.sys-error shen.insert-l)))) +(defun shen.insert-l (V2311 V2312) (cond ((= "" V2312) "") ((and (shen.+string? V2312) (and (= "~" (pos V2312 0)) (and (shen.+string? (tlstr V2312)) (= "A" (pos (tlstr V2312) 0))))) (cons shen.app (cons V2311 (cons (tlstr (tlstr V2312)) (cons shen.a ()))))) ((and (shen.+string? V2312) (and (= "~" (pos V2312 0)) (and (shen.+string? (tlstr V2312)) (= "R" (pos (tlstr V2312) 0))))) (cons shen.app (cons V2311 (cons (tlstr (tlstr V2312)) (cons shen.r ()))))) ((and (shen.+string? V2312) (and (= "~" (pos V2312 0)) (and (shen.+string? (tlstr V2312)) (= "S" (pos (tlstr V2312) 0))))) (cons shen.app (cons V2311 (cons (tlstr (tlstr V2312)) (cons shen.s ()))))) ((shen.+string? V2312) (shen.factor-cn (cons cn (cons (pos V2312 0) (cons (shen.insert-l V2311 (tlstr V2312)) ()))))) ((and (cons? V2312) (and (= cn (hd V2312)) (and (cons? (tl V2312)) (and (cons? (tl (tl V2312))) (= () (tl (tl (tl V2312)))))))) (cons cn (cons (hd (tl V2312)) (cons (shen.insert-l V2311 (hd (tl (tl V2312)))) ())))) ((and (cons? V2312) (and (= shen.app (hd V2312)) (and (cons? (tl V2312)) (and (cons? (tl (tl V2312))) (and (cons? (tl (tl (tl V2312)))) (= () (tl (tl (tl (tl V2312)))))))))) (cons shen.app (cons (hd (tl V2312)) (cons (shen.insert-l V2311 (hd (tl (tl V2312)))) (tl (tl (tl V2312))))))) (true (shen.sys-error shen.insert-l)))) -(defun shen.factor-cn (V2229) (cond ((and (cons? V2229) (and (= cn (hd V2229)) (and (cons? (tl V2229)) (and (cons? (tl (tl V2229))) (and (cons? (hd (tl (tl V2229)))) (and (= cn (hd (hd (tl (tl V2229))))) (and (cons? (tl (hd (tl (tl V2229))))) (and (cons? (tl (tl (hd (tl (tl V2229)))))) (and (= () (tl (tl (tl (hd (tl (tl V2229))))))) (and (= () (tl (tl (tl V2229)))) (and (string? (hd (tl V2229))) (string? (hd (tl (hd (tl (tl V2229))))))))))))))))) (cons cn (cons (cn (hd (tl V2229)) (hd (tl (hd (tl (tl V2229)))))) (tl (tl (hd (tl (tl V2229)))))))) (true V2229))) +(defun shen.factor-cn (V2313) (cond ((and (cons? V2313) (and (= cn (hd V2313)) (and (cons? (tl V2313)) (and (cons? (tl (tl V2313))) (and (cons? (hd (tl (tl V2313)))) (and (= cn (hd (hd (tl (tl V2313))))) (and (cons? (tl (hd (tl (tl V2313))))) (and (cons? (tl (tl (hd (tl (tl V2313)))))) (and (= () (tl (tl (tl (hd (tl (tl V2313))))))) (and (= () (tl (tl (tl V2313)))) (and (string? (hd (tl V2313))) (string? (hd (tl (hd (tl (tl V2313))))))))))))))))) (cons cn (cons (cn (hd (tl V2313)) (hd (tl (hd (tl (tl V2313)))))) (tl (tl (hd (tl (tl V2313)))))))) (true V2313))) -(defun shen.proc-nl (V2230) (cond ((= "" V2230) "") ((and (shen.+string? V2230) (and (= "~" (pos V2230 0)) (and (shen.+string? (tlstr V2230)) (= "%" (pos (tlstr V2230) 0))))) (cn (n->string 10) (shen.proc-nl (tlstr (tlstr V2230))))) ((shen.+string? V2230) (cn (pos V2230 0) (shen.proc-nl (tlstr V2230)))) (true (shen.sys-error shen.proc-nl)))) +(defun shen.proc-nl (V2314) (cond ((= "" V2314) "") ((and (shen.+string? V2314) (and (= "~" (pos V2314 0)) (and (shen.+string? (tlstr V2314)) (= "%" (pos (tlstr V2314) 0))))) (cn (n->string 10) (shen.proc-nl (tlstr (tlstr V2314))))) ((shen.+string? V2314) (cn (pos V2314 0) (shen.proc-nl (tlstr V2314)))) (true (shen.sys-error shen.proc-nl)))) -(defun shen.mkstr-r (V2231 V2232) (cond ((= () V2232) V2231) ((cons? V2232) (shen.mkstr-r (cons shen.insert (cons (hd V2232) (cons V2231 ()))) (tl V2232))) (true (shen.sys-error shen.mkstr-r)))) +(defun shen.mkstr-r (V2315 V2316) (cond ((= () V2316) V2315) ((cons? V2316) (shen.mkstr-r (cons shen.insert (cons (hd V2316) (cons V2315 ()))) (tl V2316))) (true (shen.sys-error shen.mkstr-r)))) -(defun shen.insert (V2233 V2234) (shen.insert-h V2233 V2234 "")) +(defun shen.insert (V2317 V2318) (shen.insert-h V2317 V2318 "")) -(defun shen.insert-h (V2237 V2238 V2239) (cond ((= "" V2238) V2239) ((and (shen.+string? V2238) (and (= "~" (pos V2238 0)) (and (shen.+string? (tlstr V2238)) (= "A" (pos (tlstr V2238) 0))))) (cn V2239 (shen.app V2237 (tlstr (tlstr V2238)) shen.a))) ((and (shen.+string? V2238) (and (= "~" (pos V2238 0)) (and (shen.+string? (tlstr V2238)) (= "R" (pos (tlstr V2238) 0))))) (cn V2239 (shen.app V2237 (tlstr (tlstr V2238)) shen.r))) ((and (shen.+string? V2238) (and (= "~" (pos V2238 0)) (and (shen.+string? (tlstr V2238)) (= "S" (pos (tlstr V2238) 0))))) (cn V2239 (shen.app V2237 (tlstr (tlstr V2238)) shen.s))) ((shen.+string? V2238) (shen.insert-h V2237 (tlstr V2238) (cn V2239 (pos V2238 0)))) (true (shen.sys-error shen.insert-h)))) +(defun shen.insert-h (V2321 V2322 V2323) (cond ((= "" V2322) V2323) ((and (shen.+string? V2322) (and (= "~" (pos V2322 0)) (and (shen.+string? (tlstr V2322)) (= "A" (pos (tlstr V2322) 0))))) (cn V2323 (shen.app V2321 (tlstr (tlstr V2322)) shen.a))) ((and (shen.+string? V2322) (and (= "~" (pos V2322 0)) (and (shen.+string? (tlstr V2322)) (= "R" (pos (tlstr V2322) 0))))) (cn V2323 (shen.app V2321 (tlstr (tlstr V2322)) shen.r))) ((and (shen.+string? V2322) (and (= "~" (pos V2322 0)) (and (shen.+string? (tlstr V2322)) (= "S" (pos (tlstr V2322) 0))))) (cn V2323 (shen.app V2321 (tlstr (tlstr V2322)) shen.s))) ((shen.+string? V2322) (shen.insert-h V2321 (tlstr V2322) (cn V2323 (pos V2322 0)))) (true (shen.sys-error shen.insert-h)))) -(defun shen.app (V2240 V2241 V2242) (cn (shen.arg->str V2240 V2242) V2241)) +(defun shen.app (V2324 V2325 V2326) (cn (shen.arg->str V2324 V2326) V2325)) -(defun shen.arg->str (V2248 V2249) (cond ((= V2248 (fail)) "...") ((shen.list? V2248) (shen.list->str V2248 V2249)) ((string? V2248) (shen.str->str V2248 V2249)) ((absvector? V2248) (shen.vector->str V2248 V2249)) (true (shen.atom->str V2248)))) +(defun shen.arg->str (V2332 V2333) (cond ((= V2332 (fail)) "...") ((shen.list? V2332) (shen.list->str V2332 V2333)) ((string? V2332) (shen.str->str V2332 V2333)) ((absvector? V2332) (shen.vector->str V2332 V2333)) (true (shen.atom->str V2332)))) -(defun shen.list->str (V2250 V2251) (cond ((= shen.r V2251) (@s "(" (@s (shen.iter-list V2250 shen.r (shen.maxseq)) ")"))) (true (@s "[" (@s (shen.iter-list V2250 V2251 (shen.maxseq)) "]"))))) +(defun shen.list->str (V2334 V2335) (cond ((= shen.r V2335) (@s "(" (@s (shen.iter-list V2334 shen.r (shen.maxseq)) ")"))) (true (@s "[" (@s (shen.iter-list V2334 V2335 (shen.maxseq)) "]"))))) (defun shen.maxseq () (value *maximum-print-sequence-size*)) -(defun shen.iter-list (V2262 V2263 V2264) (cond ((= () V2262) "") ((= 0 V2264) "... etc") ((and (cons? V2262) (= () (tl V2262))) (shen.arg->str (hd V2262) V2263)) ((cons? V2262) (@s (shen.arg->str (hd V2262) V2263) (@s " " (shen.iter-list (tl V2262) V2263 (- V2264 1))))) (true (@s "|" (@s " " (shen.arg->str V2262 V2263)))))) +(defun shen.iter-list (V2346 V2347 V2348) (cond ((= () V2346) "") ((= 0 V2348) "... etc") ((and (cons? V2346) (= () (tl V2346))) (shen.arg->str (hd V2346) V2347)) ((cons? V2346) (@s (shen.arg->str (hd V2346) V2347) (@s " " (shen.iter-list (tl V2346) V2347 (- V2348 1))))) (true (@s "|" (@s " " (shen.arg->str V2346 V2347)))))) -(defun shen.str->str (V2269 V2270) (cond ((= shen.a V2270) V2269) (true (@s (n->string 34) (@s V2269 (n->string 34)))))) +(defun shen.str->str (V2353 V2354) (cond ((= shen.a V2354) V2353) (true (@s (n->string 34) (@s V2353 (n->string 34)))))) -(defun shen.vector->str (V2271 V2272) (if (shen.print-vector? V2271) ((<-address V2271 0) V2271) (if (vector? V2271) (@s "<" (@s (shen.iter-vector V2271 1 V2272 (shen.maxseq)) ">")) (@s "<" (@s "<" (@s (shen.iter-vector V2271 0 V2272 (shen.maxseq)) ">>")))))) +(defun shen.vector->str (V2355 V2356) (if (shen.print-vector? V2355) ((<-address V2355 0) V2355) (if (vector? V2355) (@s "<" (@s (shen.iter-vector V2355 1 V2356 (shen.maxseq)) ">")) (@s "<" (@s "<" (@s (shen.iter-vector V2355 0 V2356 (shen.maxseq)) ">>")))))) -(defun shen.print-vector? (V2273) (let Zero (<-address V2273 0) (if (= Zero shen.tuple) true (if (= Zero shen.pvar) true (if (not (number? Zero)) (shen.fbound? Zero) false))))) +(defun shen.print-vector? (V2357) (let Zero (<-address V2357 0) (if (= Zero shen.tuple) true (if (= Zero shen.pvar) true (if (not (number? Zero)) (shen.fbound? Zero) false))))) -(defun shen.fbound? (V2274) (trap-error (do (ps V2274) true) (lambda E false))) +(defun shen.fbound? (V2358) (trap-error (do (ps V2358) true) (lambda E false))) -(defun shen.tuple (V2275) (cn "(@p " (shen.app (<-address V2275 1) (cn " " (shen.app (<-address V2275 2) ")" shen.s)) shen.s))) +(defun shen.tuple (V2359) (cn "(@p " (shen.app (<-address V2359 1) (cn " " (shen.app (<-address V2359 2) ")" shen.s)) shen.s))) -(defun shen.iter-vector (V2282 V2283 V2284 V2285) (cond ((= 0 V2285) "... etc") (true (let Item (trap-error (<-address V2282 V2283) (lambda E shen.out-of-bounds)) (let Next (trap-error (<-address V2282 (+ V2283 1)) (lambda E shen.out-of-bounds)) (if (= Item shen.out-of-bounds) "" (if (= Next shen.out-of-bounds) (shen.arg->str Item V2284) (@s (shen.arg->str Item V2284) (@s " " (shen.iter-vector V2282 (+ V2283 1) V2284 (- V2285 1))))))))))) +(defun shen.iter-vector (V2366 V2367 V2368 V2369) (cond ((= 0 V2369) "... etc") (true (let Item (trap-error (<-address V2366 V2367) (lambda E shen.out-of-bounds)) (let Next (trap-error (<-address V2366 (+ V2367 1)) (lambda E shen.out-of-bounds)) (if (= Item shen.out-of-bounds) "" (if (= Next shen.out-of-bounds) (shen.arg->str Item V2368) (@s (shen.arg->str Item V2368) (@s " " (shen.iter-vector V2366 (+ V2367 1) V2368 (- V2369 1))))))))))) -(defun shen.atom->str (V2286) (trap-error (str V2286) (lambda E (shen.funexstring)))) +(defun shen.atom->str (V2370) (trap-error (str V2370) (lambda E (shen.funexstring)))) (defun shen.funexstring () (@s "" (@s "f" (@s "u" (@s "n" (@s "e" (@s (shen.arg->str (gensym (intern "x")) shen.a) ""))))))) -(defun shen.list? (V2287) (or (empty? V2287) (cons? V2287))) +(defun shen.list? (V2371) (or (empty? V2371) (cons? V2371))) diff --git a/shen/klambda/yacc.kl b/shen/klambda/yacc.kl index 4d207cf..267846e 100644 --- a/shen/klambda/yacc.kl +++ b/shen/klambda/yacc.kl @@ -47,65 +47,67 @@ * explains this license in full. * * * ***************************************************************************************** -"(defun shen.yacc (V2126) (cond ((and (cons? V2126) (and (= defcc (hd V2126)) (and (cons? (tl V2126)) (and (cons? (tl (tl V2126))) (and (= { (hd (tl (tl V2126)))) (and (cons? (tl (tl (tl V2126)))) (and (cons? (tl (tl (tl (tl V2126))))) (and (= ==> (hd (tl (tl (tl (tl V2126)))))) (and (cons? (tl (tl (tl (tl (tl V2126)))))) (and (cons? (tl (tl (tl (tl (tl (tl V2126))))))) (= } (hd (tl (tl (tl (tl (tl (tl V2126)))))))))))))))))) (shen.yacc (cons defcc (cons (hd (tl V2126)) (tl (tl (tl (tl (tl (tl (tl V2126))))))))))) ((and (cons? V2126) (and (= defcc (hd V2126)) (cons? (tl V2126)))) (shen.yacc->shen (hd (tl V2126)) (tl (tl V2126)))) (true (shen.sys-error shen.yacc)))) +"(defun shen.yacc (V2187) (cond ((and (cons? V2187) (and (= defcc (hd V2187)) (and (cons? (tl V2187)) (and (cons? (tl (tl V2187))) (and (= { (hd (tl (tl V2187)))) (and (cons? (tl (tl (tl V2187)))) (and (cons? (tl (tl (tl (tl V2187))))) (and (= ==> (hd (tl (tl (tl (tl V2187)))))) (and (cons? (tl (tl (tl (tl (tl V2187)))))) (and (cons? (tl (tl (tl (tl (tl (tl V2187))))))) (= } (hd (tl (tl (tl (tl (tl (tl V2187)))))))))))))))))) (shen.yacc (cons defcc (cons (hd (tl V2187)) (tl (tl (tl (tl (tl (tl (tl V2187))))))))))) ((and (cons? V2187) (and (= defcc (hd V2187)) (cons? (tl V2187)))) (shen.yacc->shen (hd (tl V2187)) (tl (tl V2187)))) (true (shen.sys-error shen.yacc)))) -(defun shen.yacc->shen (V2127 V2128) (let CCRules (shen.split_cc_rules V2128 ()) (let CCBody (map shen.cc_body CCRules) (let YaccCases (shen.yacc_cases CCBody) (let CatchKill (shen.catchkill YaccCases) (cons define (cons V2127 (cons Stream (cons -> (cons CatchKill ())))))))))) +(defun shen.yacc->shen (V2188 V2189) (let CCRules (shen.split_cc_rules true V2189 ()) (let CCBody (map (lambda X2185 (shen.cc_body X2185)) CCRules) (let YaccCases (shen.yacc_cases CCBody) (cons define (cons V2188 (cons Stream (cons -> (cons (shen.kill-code YaccCases) ()))))))))) -(defun shen.split_cc_rules (V2129 V2130) (cond ((and (= () V2129) (= () V2130)) ()) ((= () V2129) (cons (shen.split_cc_rule (reverse V2130) ()) ())) ((and (cons? V2129) (= ; (hd V2129))) (cons (shen.split_cc_rule (reverse V2130) ()) (shen.split_cc_rules (tl V2129) ()))) ((cons? V2129) (shen.split_cc_rules (tl V2129) (cons (hd V2129) V2130))) (true (shen.sys-error shen.split_cc_rules)))) +(defun shen.kill-code (V2190) (cond ((> (occurrences kill V2190) 0) (cons trap-error (cons V2190 (cons (cons lambda (cons E (cons (cons shen.analyse-kill (cons E ())) ()))) ())))) (true V2190))) -(defun shen.split_cc_rule (V2131 V2132) (cond ((and (cons? V2131) (and (= := (hd V2131)) (and (cons? (tl V2131)) (= () (tl (tl V2131)))))) (cons (reverse V2132) (tl V2131))) ((and (cons? V2131) (and (= := (hd V2131)) (and (cons? (tl V2131)) (and (cons? (tl (tl V2131))) (and (= where (hd (tl (tl V2131)))) (and (cons? (tl (tl (tl V2131)))) (= () (tl (tl (tl (tl V2131))))))))))) (cons (reverse V2132) (cons (cons where (cons (hd (tl (tl (tl V2131)))) (cons (hd (tl V2131)) ()))) ()))) ((= () V2131) (do (shen.prhush "warning: " (stoutput)) (do (map (lambda X (shen.prhush (shen.app X " " shen.a) (stoutput))) (reverse V2132)) (do (shen.prhush "has no semantics. -" (stoutput)) (shen.split_cc_rule (cons := (cons (shen.default_semantics (reverse V2132)) ())) V2132))))) ((cons? V2131) (shen.split_cc_rule (tl V2131) (cons (hd V2131) V2132))) (true (shen.sys-error shen.split_cc_rule)))) +(defun kill () (simple-error "yacc kill")) -(defun shen.default_semantics (V2133) (cond ((= () V2133) ()) ((and (cons? V2133) (shen.grammar_symbol? (hd V2133))) (cons append (cons (hd V2133) (cons (shen.default_semantics (tl V2133)) ())))) ((cons? V2133) (cons cons (cons (hd V2133) (cons (shen.default_semantics (tl V2133)) ())))) (true (shen.sys-error shen.default_semantics)))) +(defun shen.analyse-kill (V2191) (let String (error-to-string V2191) (if (= String "yacc kill") (fail) V2191))) -(defun shen.grammar_symbol? (V2134) (and (symbol? V2134) (let Cs (shen.strip-pathname (explode V2134)) (and (= (hd Cs) "<") (= (hd (reverse Cs)) ">"))))) +(defun shen.split_cc_rules (V2194 V2195 V2196) (cond ((and (= () V2195) (= () V2196)) ()) ((= () V2195) (cons (shen.split_cc_rule V2194 (reverse V2196) ()) ())) ((and (cons? V2195) (= ; (hd V2195))) (cons (shen.split_cc_rule V2194 (reverse V2196) ()) (shen.split_cc_rules V2194 (tl V2195) ()))) ((cons? V2195) (shen.split_cc_rules V2194 (tl V2195) (cons (hd V2195) V2196))) (true (shen.sys-error shen.split_cc_rules)))) -(defun shen.yacc_cases (V2135) (cond ((and (cons? V2135) (= () (tl V2135))) (hd V2135)) ((cons? V2135) (let P YaccParse (cons let (cons P (cons (hd V2135) (cons (cons if (cons (cons = (cons P (cons (cons fail ()) ()))) (cons (shen.yacc_cases (tl V2135)) (cons P ())))) ())))))) (true (shen.sys-error shen.yacc_cases)))) +(defun shen.split_cc_rule (V2201 V2202 V2203) (cond ((and (cons? V2202) (and (= := (hd V2202)) (and (cons? (tl V2202)) (= () (tl (tl V2202)))))) (cons (reverse V2203) (tl V2202))) ((and (cons? V2202) (and (= := (hd V2202)) (and (cons? (tl V2202)) (and (cons? (tl (tl V2202))) (and (= where (hd (tl (tl V2202)))) (and (cons? (tl (tl (tl V2202)))) (= () (tl (tl (tl (tl V2202))))))))))) (cons (reverse V2203) (cons (cons where (cons (hd (tl (tl (tl V2202)))) (cons (hd (tl V2202)) ()))) ()))) ((= () V2202) (do (shen.semantic-completion-warning V2201 V2203) (shen.split_cc_rule V2201 (cons := (cons (shen.default_semantics (reverse V2203)) ())) V2203))) ((cons? V2202) (shen.split_cc_rule V2201 (tl V2202) (cons (hd V2202) V2203))) (true (shen.sys-error shen.split_cc_rule)))) -(defun shen.cc_body (V2136) (cond ((and (cons? V2136) (and (cons? (tl V2136)) (= () (tl (tl V2136))))) (shen.syntax (hd V2136) Stream (hd (tl V2136)))) (true (shen.sys-error shen.cc_body)))) +(defun shen.semantic-completion-warning (V2212 V2213) (cond ((= true V2212) (do (shen.prhush "warning: " (stoutput)) (do (map (lambda X (shen.prhush (shen.app X " " shen.a) (stoutput))) (reverse V2213)) (shen.prhush "has no semantics. +" (stoutput))))) (true shen.skip))) -(defun shen.syntax (V2137 V2138 V2139) (cond ((and (= () V2137) (and (cons? V2139) (and (= where (hd V2139)) (and (cons? (tl V2139)) (and (cons? (tl (tl V2139))) (= () (tl (tl (tl V2139))))))))) (cons if (cons (shen.semantics (hd (tl V2139))) (cons (cons shen.pair (cons (cons hd (cons V2138 ())) (cons (shen.semantics (hd (tl (tl V2139)))) ()))) (cons (cons fail ()) ()))))) ((= () V2137) (cons shen.pair (cons (cons hd (cons V2138 ())) (cons (shen.semantics V2139) ())))) ((cons? V2137) (if (shen.grammar_symbol? (hd V2137)) (shen.recursive_descent V2137 V2138 V2139) (if (variable? (hd V2137)) (shen.variable-match V2137 V2138 V2139) (if (shen.jump_stream? (hd V2137)) (shen.jump_stream V2137 V2138 V2139) (if (shen.terminal? (hd V2137)) (shen.check_stream V2137 V2138 V2139) (if (shen.list_stream? (hd V2137)) (shen.list_stream (shen.decons (hd V2137)) (tl V2137) V2138 V2139) (simple-error (shen.app (hd V2137) " is not legal syntax -" shen.a)))))))) (true (shen.sys-error shen.syntax)))) +(defun shen.default_semantics (V2214) (cond ((= () V2214) ()) ((and (cons? V2214) (and (= () (tl V2214)) (shen.grammar_symbol? (hd V2214)))) (hd V2214)) ((and (cons? V2214) (shen.grammar_symbol? (hd V2214))) (cons append (cons (hd V2214) (cons (shen.default_semantics (tl V2214)) ())))) ((cons? V2214) (cons cons (cons (hd V2214) (cons (shen.default_semantics (tl V2214)) ())))) (true (shen.sys-error shen.default_semantics)))) -(defun shen.list_stream? (V2148) (cond ((cons? V2148) true) (true false))) +(defun shen.grammar_symbol? (V2215) (and (symbol? V2215) (let Cs (shen.strip-pathname (explode V2215)) (and (= (hd Cs) "<") (= (hd (reverse Cs)) ">"))))) -(defun shen.decons (V2149) (cond ((and (cons? V2149) (and (= cons (hd V2149)) (and (cons? (tl V2149)) (and (cons? (tl (tl V2149))) (= () (tl (tl (tl V2149)))))))) (cons (hd (tl V2149)) (shen.decons (hd (tl (tl V2149)))))) (true V2149))) +(defun shen.yacc_cases (V2216) (cond ((and (cons? V2216) (= () (tl V2216))) (hd V2216)) ((cons? V2216) (let P YaccParse (cons let (cons P (cons (hd V2216) (cons (cons if (cons (cons = (cons P (cons (cons fail ()) ()))) (cons (shen.yacc_cases (tl V2216)) (cons P ())))) ())))))) (true (shen.sys-error shen.yacc_cases)))) -(defun shen.list_stream (V2150 V2151 V2152 V2153) (let Test (cons and (cons (cons cons? (cons (cons hd (cons V2152 ())) ())) (cons (cons cons? (cons (cons hd (cons (cons hd (cons V2152 ())) ())) ())) ()))) (let Action (cons shen.snd-or-fail (cons (shen.syntax V2150 (cons shen.pair (cons (cons hd (cons (cons hd (cons V2152 ())) ())) (cons (cons shen.hdtl (cons V2152 ())) ()))) (cons shen.leave! (cons (shen.syntax V2151 (cons shen.pair (cons (cons tl (cons (cons hd (cons V2152 ())) ())) (cons (cons shen.hdtl (cons V2152 ())) ()))) V2153) ()))) ())) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) +(defun shen.cc_body (V2217) (cond ((and (cons? V2217) (and (cons? (tl V2217)) (= () (tl (tl V2217))))) (shen.syntax (hd V2217) Stream (hd (tl V2217)))) (true (shen.sys-error shen.cc_body)))) -(defun shen.snd-or-fail (V2160) (cond ((and (cons? V2160) (and (cons? (tl V2160)) (= () (tl (tl V2160))))) (hd (tl V2160))) (true (fail)))) +(defun shen.syntax (V2218 V2219 V2220) (cond ((and (= () V2218) (and (cons? V2220) (and (= where (hd V2220)) (and (cons? (tl V2220)) (and (cons? (tl (tl V2220))) (= () (tl (tl (tl V2220))))))))) (cons if (cons (shen.semantics (hd (tl V2220))) (cons (cons shen.pair (cons (cons hd (cons V2219 ())) (cons (shen.semantics (hd (tl (tl V2220)))) ()))) (cons (cons fail ()) ()))))) ((= () V2218) (cons shen.pair (cons (cons hd (cons V2219 ())) (cons (shen.semantics V2220) ())))) ((cons? V2218) (if (shen.grammar_symbol? (hd V2218)) (shen.recursive_descent V2218 V2219 V2220) (if (variable? (hd V2218)) (shen.variable-match V2218 V2219 V2220) (if (shen.jump_stream? (hd V2218)) (shen.jump_stream V2218 V2219 V2220) (if (shen.terminal? (hd V2218)) (shen.check_stream V2218 V2219 V2220) (if (cons? (hd V2218)) (shen.list-stream (shen.decons (hd V2218)) (tl V2218) V2219 V2220) (simple-error (shen.app (hd V2218) " is not legal syntax +" shen.a)))))))) (true (shen.sys-error shen.syntax)))) -(defun shen.strip-pathname (V2165) (cond ((not (element? "." V2165)) V2165) ((cons? V2165) (shen.strip-pathname (tl V2165))) (true (shen.sys-error shen.strip-pathname)))) +(defun shen.list-stream (V2221 V2222 V2223 V2224) (let Test (cons and (cons (cons cons? (cons (cons hd (cons V2223 ())) ())) (cons (cons cons? (cons (cons hd (cons (cons hd (cons V2223 ())) ())) ())) ()))) (let Placeholder (gensym shen.place) (let RunOn (shen.syntax V2222 (cons shen.pair (cons (cons tl (cons (cons hd (cons V2223 ())) ())) (cons (cons hd (cons (cons tl (cons V2223 ())) ())) ()))) V2224) (let Action (shen.insert-runon RunOn Placeholder (shen.syntax V2221 (cons shen.pair (cons (cons hd (cons (cons hd (cons V2223 ())) ())) (cons (cons hd (cons (cons tl (cons V2223 ())) ())) ()))) Placeholder)) (cons if (cons Test (cons Action (cons (cons fail ()) ()))))))))) -(defun shen.recursive_descent (V2166 V2167 V2168) (cond ((cons? V2166) (let Test (cons (hd V2166) (cons V2167 ())) (let Action (shen.syntax (tl V2166) (concat Parse_ (hd V2166)) V2168) (let Else (cons fail ()) (cons let (cons (concat Parse_ (hd V2166)) (cons Test (cons (cons if (cons (cons not (cons (cons = (cons (cons fail ()) (cons (concat Parse_ (hd V2166)) ()))) ())) (cons Action (cons Else ())))) ())))))))) (true (shen.sys-error shen.recursive_descent)))) +(defun shen.decons (V2225) (cond ((and (cons? V2225) (and (= cons (hd V2225)) (and (cons? (tl V2225)) (and (cons? (tl (tl V2225))) (and (= () (hd (tl (tl V2225)))) (= () (tl (tl (tl V2225))))))))) (cons (hd (tl V2225)) ())) ((and (cons? V2225) (and (= cons (hd V2225)) (and (cons? (tl V2225)) (and (cons? (tl (tl V2225))) (= () (tl (tl (tl V2225)))))))) (cons (hd (tl V2225)) (shen.decons (hd (tl (tl V2225)))))) (true V2225))) -(defun shen.variable-match (V2169 V2170 V2171) (cond ((cons? V2169) (let Test (cons cons? (cons (cons hd (cons V2170 ())) ())) (let Action (cons let (cons (concat Parse_ (hd V2169)) (cons (cons hd (cons (cons hd (cons V2170 ())) ())) (cons (shen.syntax (tl V2169) (cons shen.pair (cons (cons tl (cons (cons hd (cons V2170 ())) ())) (cons (cons shen.hdtl (cons V2170 ())) ()))) V2171) ())))) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.sys-error shen.variable-match)))) +(defun shen.insert-runon (V2236 V2237 V2238) (cond ((and (cons? V2238) (and (= shen.pair (hd V2238)) (and (cons? (tl V2238)) (and (cons? (tl (tl V2238))) (and (= () (tl (tl (tl V2238)))) (= (hd (tl (tl V2238))) V2237)))))) V2236) ((cons? V2238) (map (lambda Z (shen.insert-runon V2236 V2237 Z)) V2238)) (true V2238))) -(defun shen.terminal? (V2180) (cond ((cons? V2180) false) ((variable? V2180) false) (true true))) +(defun shen.strip-pathname (V2244) (cond ((not (element? "." V2244)) V2244) ((cons? V2244) (shen.strip-pathname (tl V2244))) (true (shen.sys-error shen.strip-pathname)))) -(defun shen.jump_stream? (V2185) (cond ((= V2185 _) true) (true false))) +(defun shen.recursive_descent (V2245 V2246 V2247) (cond ((cons? V2245) (let Test (cons (hd V2245) (cons V2246 ())) (let Action (shen.syntax (tl V2245) (concat Parse_ (hd V2245)) V2247) (let Else (cons fail ()) (cons let (cons (concat Parse_ (hd V2245)) (cons Test (cons (cons if (cons (cons not (cons (cons = (cons (cons fail ()) (cons (concat Parse_ (hd V2245)) ()))) ())) (cons Action (cons Else ())))) ())))))))) (true (shen.sys-error shen.recursive_descent)))) -(defun shen.check_stream (V2186 V2187 V2188) (cond ((cons? V2186) (let Test (cons and (cons (cons cons? (cons (cons hd (cons V2187 ())) ())) (cons (cons = (cons (hd V2186) (cons (cons hd (cons (cons hd (cons V2187 ())) ())) ()))) ()))) (let Action (shen.syntax (tl V2186) (cons shen.pair (cons (cons tl (cons (cons hd (cons V2187 ())) ())) (cons (cons shen.hdtl (cons V2187 ())) ()))) V2188) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.sys-error shen.check_stream)))) +(defun shen.variable-match (V2248 V2249 V2250) (cond ((cons? V2248) (let Test (cons cons? (cons (cons hd (cons V2249 ())) ())) (let Action (cons let (cons (concat Parse_ (hd V2248)) (cons (cons hd (cons (cons hd (cons V2249 ())) ())) (cons (shen.syntax (tl V2248) (cons shen.pair (cons (cons tl (cons (cons hd (cons V2249 ())) ())) (cons (cons shen.hdtl (cons V2249 ())) ()))) V2250) ())))) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.sys-error shen.variable-match)))) -(defun shen.jump_stream (V2189 V2190 V2191) (cond ((cons? V2189) (let Test (cons cons? (cons (cons hd (cons V2190 ())) ())) (let Action (shen.syntax (tl V2189) (cons shen.pair (cons (cons tl (cons (cons hd (cons V2190 ())) ())) (cons (cons shen.hdtl (cons V2190 ())) ()))) V2191) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.sys-error shen.jump_stream)))) +(defun shen.terminal? (V2259) (cond ((cons? V2259) false) ((variable? V2259) false) (true true))) -(defun shen.semantics (V2192) (cond ((and (cons? V2192) (and (= shen.leave! (hd V2192)) (and (cons? (tl V2192)) (= () (tl (tl V2192)))))) (hd (tl V2192))) ((= () V2192) ()) ((shen.grammar_symbol? V2192) (cons shen.hdtl (cons (concat Parse_ V2192) ()))) ((variable? V2192) (concat Parse_ V2192)) ((cons? V2192) (map shen.semantics V2192)) (true V2192))) +(defun shen.jump_stream? (V2264) (cond ((= V2264 _) true) (true false))) -(defun fail () shen.fail!) +(defun shen.check_stream (V2265 V2266 V2267) (cond ((cons? V2265) (let Test (cons and (cons (cons cons? (cons (cons hd (cons V2266 ())) ())) (cons (cons = (cons (hd V2265) (cons (cons hd (cons (cons hd (cons V2266 ())) ())) ()))) ()))) (let Action (shen.syntax (tl V2265) (cons shen.pair (cons (cons tl (cons (cons hd (cons V2266 ())) ())) (cons (cons shen.hdtl (cons V2266 ())) ()))) V2267) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.sys-error shen.check_stream)))) -(defun shen.pair (V2193 V2194) (cons V2193 (cons V2194 ()))) +(defun shen.jump_stream (V2268 V2269 V2270) (cond ((cons? V2268) (let Test (cons cons? (cons (cons hd (cons V2269 ())) ())) (let Action (shen.syntax (tl V2268) (cons shen.pair (cons (cons tl (cons (cons hd (cons V2269 ())) ())) (cons (cons shen.hdtl (cons V2269 ())) ()))) V2270) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.sys-error shen.jump_stream)))) -(defun shen.hdtl (V2195) (hd (tl V2195))) +(defun shen.semantics (V2271) (cond ((= () V2271) ()) ((shen.grammar_symbol? V2271) (cons shen.hdtl (cons (concat Parse_ V2271) ()))) ((variable? V2271) (concat Parse_ V2271)) ((cons? V2271) (map (lambda X2186 (shen.semantics X2186)) V2271)) (true V2271))) -(defun (V2202) (cond ((and (cons? V2202) (and (cons? (tl V2202)) (= () (tl (tl V2202))))) (cons () (cons (hd V2202) ()))) (true (fail)))) +(defun shen.snd-or-fail (V2278) (cond ((and (cons? V2278) (and (cons? (tl V2278)) (= () (tl (tl V2278))))) (hd (tl V2278))) (true (fail)))) + +(defun fail () shen.fail!) -(defun (V2207) (cond ((and (cons? V2207) (and (cons? (tl V2207)) (= () (tl (tl V2207))))) (cons (hd V2207) (cons () ()))) (true (shen.sys-error )))) +(defun shen.pair (V2279 V2280) (cons V2279 (cons V2280 ()))) -(defun shen.catchkill (V2208) (cons trap-error (cons V2208 (cons (cons lambda (cons E (cons (cons shen.analyse-kill (cons E ())) ()))) ())))) +(defun shen.hdtl (V2281) (hd (tl V2281))) -(defun shen.analyse-kill (V2209) (let String (error-to-string V2209) (if (= String "Shen YACC kill") (fail) (simple-error String)))) +(defun (V2288) (cond ((and (cons? V2288) (and (cons? (tl V2288)) (= () (tl (tl V2288))))) (cons () (cons (hd V2288) ()))) (true (fail)))) -(defun kill () (simple-error "Shen YACC kill")) +(defun (V2293) (cond ((and (cons? V2293) (and (cons? (tl V2293)) (= () (tl (tl V2293))))) (cons (hd V2293) (cons () ()))) (true (shen.sys-error )))) diff --git a/shen/src/backend.shen b/shen/src/backend.shen index 826667a..c39dc46 100644 --- a/shen/src/backend.shen +++ b/shen/src/backend.shen @@ -1,102 +1,163 @@ + +\* + +********************************************************************************** +* The License * +* * +* The user is free to produce commercial applications with the software, to * +* distribute these applications in source or binary form, and to charge monies * +* for them as he sees fit and in concordance with the laws of the land subject * +* to the following license. * +* * +* 1. The license applies to all the software and all derived software and * +* must appear on such. * +* * +* 2. It is illegal to distribute the software without this license attached * +* to it and use of the software implies agreement with the license as such. * +* It is illegal for anyone who is not the copyright holder to tamper with * +* or change the license. * +* * +* 3. Neither the names of Lambda Associates or the copyright holder may be used * +* to endorse or promote products built using the software without specific * +* prior written permission from the copyright holder. * +* * +* 4. That possession of this license does not confer on the copyright holder * +* any special contractual obligation towards the user. That in no event * +* shall the copyright holder 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, * +* interruption), however caused and on any theory of liability, whether in * +* contract, strict liability or tort (including negligence) arising in any * +* way out of the use of the software, even if advised of the possibility of * +* such damage. * +* * +* 5. It is permitted for the user to change the software, for the purpose of * +* improving performance, correcting an error, or porting to a new platform, * +* and distribute the derived version of Shen provided the resulting program * +* conforms in all respects to the Shen standard and is issued under that * +* title. The user must make it clear with his distribution that he/she is * +* the author of the changes and what these changes are and why. * +* * +* 6. Derived versions of this software in whatever form are subject to the same * +* restrictions. In particular it is not permitted to make derived copies of * +* this software which do not conform to the Shen standard or appear under a * +* different title. * +* * +* It is permitted to distribute versions of Shen which incorporate libraries,* +* graphics or other facilities which are not part of the Shen standard. * +* * +* For an explication of this license see www.shenlanguage.org/license.htm which * +* explains this license in full. +* * +********************************************************************************* + +*\ + +(package shen [] + (define kl-to-lisp Params Param -> Param where (element? Param Params) Params [type X _] -> (kl-to-lisp Params X) - Params [lambda X Y] -> [FUNCTION [LAMBDA [X] (kl-to-lisp [X | Params] Y)]] - Params [let X Y Z] -> [LET [[X (kl-to-lisp Params Y)]] - (kl-to-lisp [X | Params] Z)] - _ [defun F Params Code] -> [DEFUN F Params (kl-to-lisp Params Code)] - Params [cond | Cond] -> [COND | (map (/. C (cond_code Params C)) (insert-default Cond))] - Params [Param | X] -> (higher-order-code Param - (map (/. Y (kl-to-lisp Params Y)) X)) - where (element? Param Params) - Params [[X | Y] | Z] -> (higher-order-code (kl-to-lisp Params [X | Y]) - (map (/. W (kl-to-lisp Params W)) Z)) - Params [F | X] -> (assemble-application F - (map (/. Y (kl-to-lisp Params Y)) X)) - where (symbol? F) - _ [] -> [] - _ S -> [QUOTE S] where (or (symbol? S) (boolean? S)) - _ X -> X) - -(define insert-default - [] -> [[true [ERROR "error: cond failure~%"]]] - [[true X] | Y] -> [[true X] | Y] - [Case | Cases] -> [Case | (insert-default Cases)]) - -(define higher-order-code - F X -> [let Args [LIST | X] - [let NewF [maplispsym F] - [trap-error [APPLY NewF Args] - [lambda E [COND [[arity-error? F Args] - [funcall [EVAL [nest-lambda F NewF]] Args]] - [[EQ NewF [QUOTE or]] - [funcall [lambda X1 [lambda X2 [or X1 X2]]] Args]] - [[EQ NewF [QUOTE and]] - [funcall [lambda X1 [lambda X2 [and X1 X2]]] Args]] - [[EQ NewF [QUOTE trap-error]] - [funcall [lambda X1 [lambda X2 [trap-error X1 X2]]] Args]] - [[bad-lambda-call? NewF Args] - [funcall NewF Args]] - [T [relay-error E]]]]]]]) - -(define bad-lambda-call? - F Args -> (AND (FUNCTIONP F) (NOT (= (LIST-LENGTH Args) 1)))) - -(define relay-error - E -> (ERROR (error-to-string E))) - -(define funcall - Lambda [] -> Lambda - Lambda [X | Y] -> (funcall (FUNCALL Lambda X) Y)) - -(define arity-error? - F Args -> (AND (SYMBOLP F) - (> (trap-error (arity F) (/. E -1)) (LIST-LENGTH Args))) + Params [lambda X Y] + -> (protect [FUNCTION [LAMBDA [X] (kl-to-lisp [X | Params] Y)]]) + Params [let X Y Z] -> (protect [LET [[X (kl-to-lisp Params Y)]] + (kl-to-lisp [X | Params] Z)]) + _ [defun F Params Code] -> (protect [DEFUN F Params (kl-to-lisp Params Code)]) + Params [cond | Cond] -> (protect [COND | (map (/. C (cond_code Params C)) Cond)]) + Params [F | X] -> (let Arguments (map (/. Y (kl-to-lisp Params Y)) X) + (optimise-application + (cases (element? F Params) + [apply F [(protect LIST) | Arguments]] + (cons? F) [apply (kl-to-lisp Params F) + [(protect LIST) | Arguments]] + (partial-application? F Arguments) + (partially-apply F Arguments) + true [(maplispsym F) | Arguments]))) + _ N -> N where (number? N) + _ S -> S where (string? S) + _ X -> (protect [QUOTE X])) -(define nest-lambda - F NewF -> (nest-lambda-help NewF (trap-error (arity F) (/. E -1)))) - -(define nest-lambda-help - F -1 -> F +(define apply + F Arguments -> (trap-error ((protect APPLY) F Arguments) + (/. E (analyse-application F Arguments)))) + +\\ Very slow if higher-order partial application is used; but accurate. +(define analyse-application + F Arguments -> (let Lambda (if (partial-application? F Arguments) + ((protect EVAL) (mk-lambda F (arity F))) + F) + (curried-apply F Arguments))) + +(define curried-apply + F [] -> F + F [X | Y] -> (curried-apply (F X) Y)) + +(define partial-application? + F Arguments -> (let Arity (trap-error (arity F) (/. E -1)) + (cases (= Arity -1) false + (= Arity (length Arguments)) false + (> (length Arguments) Arity) false + true true))) + +(define partially-apply + F Arguments -> (let Arity (arity F) + Lambda (mk-lambda [(maplispsym F)] Arity) + (build-partial-application Lambda Arguments))) + +(define optimise-application + [hd X] -> (protect [CAR X]) + [tl X] -> (protect [CDR X]) + [cons X Y] -> (protect [CONS X Y]) + [append X Y] -> (protect [APPEND X Y]) + [reverse X] -> (protect [REVERSE X]) + [if P Q R] -> (protect [IF (wrap P) Q R]) + [+ 1 X] -> [1+ X] + [+ X 1] -> [1+ X] + [- X 1] -> [1- X] + [value [Quote X]] -> X where (= Quote (protect QUOTE)) + [set [Quote X] [1+ X]] -> [(protect INCF) X] where (= Quote (protect QUOTE)) + [set [Quote X] [1- X]] -> [(protect DECF) X] where (= Quote (protect QUOTE)) + X -> X) + +(define mk-lambda F 0 -> F - F N -> (let X (GENSYM "Y") - [lambda X (nest-lambda-help (add-p F X) (- N 1))])) - -(define add-p - [F | X] Y -> (append [F | X] [Y]) - F X -> [F X]) - + F N -> (let X (gensym (protect V)) + [lambda X (mk-lambda (append F [X]) (- N 1))])) + +(define build-partial-application + F [] -> F + F [Argument | Arguments] + -> (build-partial-application [(protect FUNCALL) F Argument] Arguments)) + (define cond_code Params [Test Result] -> [(lisp_test Params Test) (kl-to-lisp Params Result)]) (define lisp_test - _ true -> T - Params [and | Tests] -> [AND | (map (/. X (wrap (kl-to-lisp Params X))) Tests)] + _ true -> (protect T) + Params [and | Tests] + -> [(protect AND) | (map (/. X (wrap (kl-to-lisp Params X))) Tests)] Params Test -> (wrap (kl-to-lisp Params Test))) (define wrap - [cons? X] -> [CONSP X] - [string? X] -> [STRINGP X] - [number? X] -> [NUMBERP X] - [empty? X] -> [NULL X] - [and P Q] -> [AND (wrap P) (wrap Q)] - [or P Q] -> [OR (wrap P) (wrap Q)] - [not P] -> [NOT (wrap P)] - [equal? X []] -> [NULL X] - [equal? [] X] -> [NULL X] - [equal? X [Quote Y]] -> [EQ X [Quote Y]] - where (and (= (SYMBOLP Y) T) (= Quote QUOTE)) - [equal? [Quote Y] X] -> [EQ [Quote Y] X] - where (and (= (SYMBOLP Y) T) (= Quote QUOTE)) - [equal? [fail] X] -> [EQ [fail] X] - [equal? X [fail]] -> [EQ X [fail]] - [equal? S X] -> [EQUAL S X] where (string? S) - [equal? X S] -> [EQUAL X S] where (string? S) - [equal? X Y] -> [shen-ABSEQUAL X Y] - [shen-+string? [tlstr X]] -> [NOT [STRING-EQUAL [tlstr X] ""]] - [shen-pvar? X] -> [AND [ARRAYP X] [NOT [STRINGP X]] [EQ [AREF X 0] [QUOTE shen-pvar]]] - [tuple? X] -> [AND [ARRAYP X] [NOT [STRINGP X]] [EQ [AREF X 0] [QUOTE shen-tuple]]] + [cons? X] -> [(protect CONSP) X] + [string? X] -> [(protect STRINGP) X] + [number? X] -> [(protect NUMBERP) X] + [empty? X] -> [(protect NULL) X] + [and P Q] -> [(protect AND) (wrap P) (wrap Q)] + [or P Q] -> [(protect OR) (wrap P) (wrap Q)] + [not P] -> [(protect NOT) (wrap P)] + [equal? X []] -> [(protect NULL) X] + [equal? [] X] -> [(protect NULL) X] + [equal? X [Quote Y]] -> [(protect EQ) X [Quote Y]] + where (and (= ((protect SYMBOLP) Y) (protect T)) (= Quote (protect QUOTE))) + [equal? [Quote Y] X] -> [(protect EQ) [Quote Y] X] + where (and (= ((protect SYMBOLP) Y) (protect T)) (= Quote (protect QUOTE))) + [equal? [fail] X] -> [(protect EQ) [fail] X] + [equal? X [fail]] -> [(protect EQ) X [fail]] + [equal? S X] -> [(protect EQUAL) S X] where (string? S) + [equal? X S] -> [(protect EQUAL) X S] where (string? S) + [equal? X Y] -> [ABSEQUAL X Y] [greater? X Y] -> [> X Y] [greater-than-or-equal-to? X Y] -> [>= X Y] [less? X Y] -> [< X Y] @@ -104,30 +165,10 @@ X -> [wrapper X]) (define wrapper - true -> T + true -> (protect T) false -> [] X -> (error "boolean expected: not ~S~%" X)) - - (define assemble-application - hd [X] -> [CAR X] - tl [X] -> [CDR X] - cons [X Y] -> [CONS X Y] - append [X Y] -> [APPEND X Y] - reverse [X] -> [REVERSE X] - if [P Q R] -> [IF (wrap P) Q R] - \ do [X Y] -> [PROG2 X Y]\ - + [1 X] -> [1+ X] - + [X 1] -> [1+ X] - - [X 1] -> [1- X] - value [[Quote X]] -> X where (= Quote QUOTE) - set [[Quote X] [1+ X]] -> [INCF X] where (= Quote QUOTE) - set [[Quote X] [1- X]] -> [DECF X] where (= Quote QUOTE) - F X -> (let NewF (maplispsym F) - Arity (trap-error (arity F) (/. E -1)) - (if (or (= Arity (length X)) (= Arity -1)) - [NewF | X] - [funcall (nest-lambda F NewF) [LIST | X]]))) - + (define maplispsym = -> equal? > -> greater? @@ -139,57 +180,5 @@ / -> divide * -> multiply F -> F) - - (define factorh - [Defun F Params [Cond | Code]] -> [Defun F Params [BLOCK [] (process-tree (tree (map returns Code)))]] - where (and (= Cond COND) (= Defun DEFUN)) - Code -> Code) - -(define returns - [Test Result] -> [Test [RETURN Result]]) - -(define process-tree - (@p P Q R no-tag) -> [IF P (optimise-selectors P (process-tree Q)) (process-tree R)] - (@p P Q R Tag) -> [TAGBODY [IF P (optimise-selectors P (process-tree Q))] Tag (process-tree R)] - Q -> Q where (not (tuple? Q))) -(define optimise-selectors - Test Code -> (optimise-selectors-help (selectors-from Test) Code)) - -(define selectors-from - [Consp X] -> [[CAR X] [CDR X]] where (= Consp CONSP) - [tuple? X] -> [[fst X] [snd X]] - _ -> []) - -(define optimise-selectors-help - [] Code -> Code - [S1 S2] Code -> (let O1 (occurrences S1 Code) - O2 (occurrences S2 Code) - V1 (gensym V) - V2 (gensym V) - (if (and (> O1 1) (> O2 1)) - [LET [[V1 S1] [V2 S2]] - (subst V1 S1 (subst V2 S2 Code))] - (if (> O1 1) - [LET [[V1 S1]] (subst V1 S1 Code)] - (if (> O2 1) - [LET [[V2 S2]] (subst V2 S2 Code)] - Code))))) - -(define tree - [[[And P Q] R] | S] -> (let Tag (gensym tag) - Left (tree (append (branch-by P [[[And P Q] R] | S]) [[T [GO Tag]]])) - Right (tree (branch-by-not P [[[And P Q] R] | S])) - (@p P Left Right Tag)) where (= And AND) - [[True Q] | _] -> Q where (= True T) - [[P Q] | R] -> (@p P Q (tree R) no-tag)) - -(define branch-by - P [[[And P Q] R] | S] -> [[Q R] | (branch-by P S)] where (= And AND) - P [[P R] | S] -> [[T R]] - _ Code -> []) - -(define branch-by-not - P [[[And P Q] R] | S] -> (branch-by-not P S) where (= And AND) - P [[P R] | S] -> S - _ Code -> Code) \ No newline at end of file + ) \ No newline at end of file diff --git a/shen/src/declarations.shen b/shen/src/declarations.shen index 5121dc8..49b0b32 100644 --- a/shen/src/declarations.shen +++ b/shen/src/declarations.shen @@ -67,7 +67,7 @@ (set *tracking* []) (set *home-directory* "") (set *alphabet* [A B C D E F G H I J K L M N O P Q R S T U V W X Y Z]) -(set *special* [@p @s @v cons lambda let type where set open]) +(set *special* [@p @s @v cons lambda let where set open]) (set *extraspecial* [define process-datatype input+ defcc read+ defmacro]) (set *spy* false) (set *datatypes* []) @@ -85,6 +85,7 @@ (set *infs* 0) (set *hush* false) (set *optimise* false) +(set *version* "version 16") (define initialise_arity_table [] -> [] @@ -93,22 +94,24 @@ (define arity F -> (trap-error (get F arity) (/. E -1))) - + + (initialise_arity_table [absvector 1 adjoin 2 and 2 append 2 arity 1 assoc 2 boolean? 1 cd 1 compile 3 concat 2 cons 2 cons? 1 cn 2 declare 2 destroy 1 difference 2 do 2 element? 2 empty? 1 enable-type-theory 1 interror 2 eval 1 eval-kl 1 explode 1 external 1 fail-if 2 fail 0 fix 2 findall 5 freeze 1 fst 1 gensym 1 get 3 get-time 1 address-> 3 <-address 2 <-vector 2 > 2 >= 2 = 2 hd 1 hdv 1 hdstr 1 head 1 if 3 integer? 1 - intern 1 identical 4 inferences 0 input 1 input+ 2 intersection 2 kill 0 length 1 lineread 1 load 1 < 2 - <= 2 vector 1 macroexpand 1 map 2 mapcan 2 maxinferences 1 not 1 nth 2 n->string 1 number? 1 occurs-check 1 - occurrences 2 occurs-check 1 optimise 1 or 2 package 3 pos 2 print 1 profile 1 profile-results 0 pr 2 ps 1 - preclude 1 preclude-all-but 1 protect 1 address-> 3 put 4 reassemble 2 read-file-as-string 1 read-file 1 - read 1 read-byte 1 read-from-string 1 remove 2 reverse 1 set 2 simple-error 1 snd 1 specialise 1 spy 1 - step 1 stinput 0 stoutput 0 string->n 1 string->symbol 1 string? 1 strong-warning 1 subst 3 sum 1 - symbol? 1 tail 1 tl 1 tc 1 tc? 1 thaw 1 tlstr 1 track 1 trap-error 2 tuple? 1 type 1 return 3 - undefmacro 1 unprofile 1 unify 4 unify! 4 union 2 untrack 1 unspecialise 1 undefmacro 1 vector 1 - vector-> 3 value 1 variable? 1 version 1 warn 1 write-byte 2 write-to-file 2 y-or-n? 1 + 2 * 2 / 2 - 2 == 2 1 - @p 2 @v 2 @s 2 preclude 1 include 1 preclude-all-but 1 include-all-but 1 where 2]) + intern 1 identical 4 inferences 0 input 1 input+ 2 implementation 0 intersection 2 it 0 kill 0 language 0 + length 1 lineread 1 load 1 < 2 <= 2 vector 1 macroexpand 1 map 2 mapcan 2 maxinferences 1 not 1 nth 2 + n->string 1 number? 1 occurs-check 1 occurrences 2 occurs-check 1 optimise 1 or 2 os 0 package 3 port 0 + porters 0 pos 2 print 1 profile 1 profile-results 1 pr 2 ps 1 preclude 1 preclude-all-but 1 protect 1 + address-> 3 put 4 reassemble 2 read-file-as-string 1 read-file 1 read 1 read-byte 1 read-from-string 1 + release 0 remove 2 reverse 1 set 2 simple-error 1 snd 1 specialise 1 spy 1 step 1 stinput 0 stoutput 0 + string->n 1 string->symbol 1 string? 1 strong-warning 1 subst 3 sum 1 symbol? 1 tail 1 tl 1 tc 1 tc? 0 + thaw 1 tlstr 1 track 1 trap-error 2 tuple? 1 type 2 return 3 undefmacro 1 unprofile 1 unify 4 unify! 4 + union 2 untrack 1 unspecialise 1 undefmacro 1 vector 1 vector-> 3 value 1 variable? 1 version 0 warn 1 + write-byte 2 write-to-file 2 y-or-n? 1 + 2 * 2 / 2 - 2 == 2 1 @p 2 @v 2 @s 2 preclude 1 include 1 + preclude-all-but 1 include-all-but 1 where 2]) (define systemf F -> (let Shen (intern "shen") @@ -119,16 +122,17 @@ X Y -> (if (element? X Y) Y [X | Y])) (put (intern "shen") external-symbols - [! } { --> <-- && : ; :- := _ *language* *implementation* *stinput* *home-directory* *version* *maximum-print-sequence-size* *macros* *os* *release* *property-vector* @v @p @s *port* *porters* *hush* - <- -> == = >= > /. =! $ - / * + <= < >> <> ==> y-or-n? write-to-file write-byte where when warn version verified variable? value vector-> <-vector vector vector? unspecialise untrack unit unix union unify + [! } { --> <-- && : ; :- := _ *language* *implementation* *stinput* *home-directory* *version* + *maximum-print-sequence-size* *macros* *os* *release* *property-vector* @v @p @s *port* *porters* *hush* + <- -> == = >= > /. =! $ - / * + <= < >> <> ==> y-or-n? write-to-file write-byte where when warn version verified variable? value vector-> <-vector vector vector? unspecialise untrack unit unix union unify unify! unprofile undefmacro return type tuple? true trap-error track time thaw tc? tc tl tlstr tlv tail systemf synonyms symbol symbol? string->symbol subst string? string->n stream string stinput - stoutput step spy specialise snd simple-error set save str run reverse remove read read+ read-file + stoutput step spy specialise snd simple-error set save str run reverse remove release read read-file read-file-as-bytelist read-file-as-string read-byte read-from-string quit put preclude - preclude-all-but ps prolog? protect profile-results profile print pr pos package output out or - open occurrences occurs-check n->string number? number null nth not nl mode macro macroexpand - maxinferences mapcan map make-string load loaded list lineread limit length let lazy lambda kill is - intersection inferences intern integer? input input+ include include-all-but in if identical head + preclude-all-but ps prolog? protect profile-results profile print pr pos porters port package output out os or + optimise open occurrences occurs-check n->string number? number null nth not nl mode macro macroexpand + maxinferences mapcan map make-string load loaded list lineread limit length let lazy lambda language kill is + intersection inferences intern integer? input input+ include include-all-but it in implementation if identical head hd hdv hdstr hash get get-time gensym function fst freeze fix file fail fail-if fwhen findall false enable-type-theory explode external exception eval-kl eval error-to-string error empty? element? do difference destroy defun define defmacro defcc defprolog declare datatype cut cn diff --git a/shen/src/load.shen b/shen/src/load.shen index f748d39..cb561e4 100644 --- a/shen/src/load.shen +++ b/shen/src/load.shen @@ -105,7 +105,7 @@ := ;) (define write-to-file - File Text -> (let Stream (open file File out) + File Text -> (let Stream (open File out) String (if (string? Text) (make-string "~A~%~%" Text) (make-string "~S~%~%" Text)) diff --git a/shen/src/macros.shen b/shen/src/macros.shen index 375df69..975f9eb 100644 --- a/shen/src/macros.shen +++ b/shen/src/macros.shen @@ -85,7 +85,7 @@ [input] -> [input [stinput]] [read] -> [read [stinput]] [input+ Type] -> [input+ Type [stinput]] - [read+ Type] -> [read+ Type [stinput]] + [read-byte] -> [read-byte [stinput]] X -> X) (define compose @@ -99,16 +99,27 @@ X -> X) (define prolog-macro - [prolog? | X] -> [intprolog (prolog-form X)] + [prolog? | Literals] -> (let F (gensym f) + Receive (receive-terms Literals) + PrologDef (eval (append [defprolog F] Receive [<--] (pass-literals Literals) [;])) + Query [F | (append Receive [[start-new-prolog-process] [freeze true]])] + Query) X -> X) +(define receive-terms + [] -> [] + [[receive X] | Terms] -> [X | (receive-terms Terms)] + [_ | Terms] -> (receive-terms Terms)) + +(define pass-literals + [] -> [] + [[receive _] | Literals] -> (pass-literals Literals) + [Literal | Literals] -> [Literal | (pass-literals Literals)]) + (define defprolog-macro [defprolog F | X] -> (compile (function ) [F | X] (/. Y (prolog-error F Y))) X -> X) -(define prolog-form - X -> (cons_form (map (function cons_form) X))) - (define datatype-macro [datatype F | Rules] -> [process-datatype (intern-type F) @@ -119,22 +130,6 @@ (define intern-type F -> (intern (cn "type#" (str F)))) -"(defcc - := [define | ];) - -(defcc - ; - := (append [(protect X) -> (protect X)]);) - -(defcc - -> where ; - -> ; - <- where ; - <- ;) - -(defcc - := [[walk [function macroexpand] ]];)" - (define @s-macro [@s W X Y | Z] -> [@s W (@s-macro [@s X Y | Z])] [@s X Y] -> (let E (explode X) @@ -144,9 +139,12 @@ X -> X) (define synonyms-macro - [synonyms | X] -> [synonyms-help (rcons_form X)] + [synonyms | X] -> [synonyms-help (rcons_form (curry-synonyms X))] X -> X) +(define curry-synonyms + Synonyms -> (map (function curry-type) Synonyms)) + (define nl-macro [nl] -> [nl 1] X -> X) diff --git a/shen/src/prolog.shen b/shen/src/prolog.shen index b1131c5..15f821b 100644 --- a/shen/src/prolog.shen +++ b/shen/src/prolog.shen @@ -432,7 +432,7 @@ N -> (address-> (address-> (absvector 2) 0 pvar) 1 N)) (define pvar? - X -> (and (absvector? X) (= (<-address X 0) pvar))) + X -> (trap-error (and (absvector? X) (= (<-address X 0) pvar)) (/. E false))) (define bindv Var Val N -> (let Vector (<-address (value *prologvectors*) N) diff --git a/shen/src/reader.shen b/shen/src/reader.shen index 6c82cf6..2c67517 100644 --- a/shen/src/reader.shen +++ b/shen/src/reader.shen @@ -79,7 +79,7 @@ (define input+ Type Stream -> (let Mono? (monotype Type) Input (read Stream) - (if (= false (typecheck Input Type)) + (if (= false (typecheck Input (demodulate Type))) (error "type error: ~R is not of type ~R~%" Input Type) (eval-kl Input)))) @@ -89,12 +89,17 @@ (define read Stream -> (hd (read-loop Stream (read-byte Stream) []))) + +(define it + -> (value *it*)) (define read-loop + _ 94 Bytes -> (error "read aborted") _ -1 Bytes -> (if (empty? Bytes) (simple-error "error: empty stream") (compile (function ) Bytes (/. E E))) Stream Byte Bytes -> (let AllBytes (append Bytes [Byte]) + It (record-it AllBytes) Read (compile (function ) AllBytes (/. E nextbyte)) (if (or (= Read nextbyte) (empty? Read)) (read-loop Stream (read-byte Stream) AllBytes) @@ -113,11 +118,29 @@ (compile (function ) Bytes (/. E E))) Byte _ Stream -> (error "line read aborted") where (= Byte (hat)) Byte Bytes Stream -> (let Line (compile (function ) Bytes (/. E nextline)) - (if (or (= Line nextline) (empty? Line)) - (lineread-loop (read-byte Stream) (append Bytes [Byte]) Stream) - Line)) where (element? Byte [(newline) (carriage-return)]) + It (record-it Bytes) + (if (or (= Line nextline) (empty? Line)) + (lineread-loop (read-byte Stream) (append Bytes [Byte]) Stream) + Line)) where (element? Byte [(newline) (carriage-return)]) Byte Bytes Stream -> (lineread-loop (read-byte Stream) (append Bytes [Byte]) Stream)) +(define record-it + Bytes -> (let TrimLeft (trim-whitespace Bytes) + TrimRight (trim-whitespace (reverse TrimLeft)) + Trimmed (reverse TrimRight) + (record-it-h Trimmed))) + +(define trim-whitespace + [Byte | Bytes] -> (trim-whitespace Bytes) where (element? Byte [9 10 13 32]) + Bytes -> Bytes) + +(define record-it-h + Bytes -> (do (set *it* (cn-all (map (function n->string) Bytes))) Bytes)) + +(define cn-all + [] -> "" + [S | Ss] -> (cn S (cn-all Ss))) + (define read-file File -> (let Bytelist (read-file-as-bytelist File) (compile (function ) Bytelist (function read-error)))) diff --git a/shen/src/sequent.shen b/shen/src/sequent.shen index ffd5db9..4088da2 100644 --- a/shen/src/sequent.shen +++ b/shen/src/sequent.shen @@ -147,8 +147,8 @@ (define remember-datatype [D | _] -> (do (set *datatypes* (adjoin D (value *datatypes*))) - (set *alldatatypes* (adjoin D (value *alldatatypes*))) - D)) + (set *alldatatypes* (adjoin D (value *alldatatypes*))) + D)) (define rules->horn-clauses _ [] -> [] @@ -259,12 +259,29 @@ Types -> (include-h (difference (value *alldatatypes*) (map (function intern-type) Types)))) (define synonyms-help - [] -> synonyms - [S1 S2 | S] -> (do (pushnew [S1 | (curry-type S2)] *synonyms*) - (synonyms-help S)) - _ -> (error "odd number of synonyms~%" [])) - + [] -> (demodulation-function (value *tc*) + (mapcan (function demod-rule) (value *synonyms*))) + [S1 S2 | S] -> (let Vs (difference (extract_vars S2) (extract_vars S1)) + (if (empty? Vs) + (do (pushnew [S1 S2] *synonyms*) + (synonyms-help S)) + (free_variable_warnings S2 Vs))) + _ -> (error "odd number of synonyms~%")) + (define pushnew X Global -> (if (element? X (value Global)) - (value Global) - (set Global [X | (value Global)]))) ) \ No newline at end of file + (value Global) + (set Global [X | (value Global)]))) + +(define demod-rule + [S1 S2] -> [(rcons_form S1) -> (rcons_form S2)]) + +(define demodulation-function + TC? Rules -> (do (tc -) + (eval [define demod | (append Rules (default-rule))]) + (if TC? (tc +) skip) + synonyms)) + +(define default-rule + -> (protect [X -> X])) + ) \ No newline at end of file diff --git a/shen/src/sys.shen b/shen/src/sys.shen index 80eb999..590f8e7 100644 --- a/shen/src/sys.shen +++ b/shen/src/sys.shen @@ -374,7 +374,7 @@ (define subst X Y Y -> X - X Y [W | Z] -> [(subst X Y W) | (subst X Y Z)] + X Y Z -> (map (/. W (subst X Y W)) Z) where (cons? Z) _ _ Z -> Z) (define explode @@ -475,6 +475,24 @@ - -> (set *optimise* false) _ -> (error "optimise expects a + or a -.~%"))) +(define os + -> (value *os*)) +(define language + -> (value *language*)) +(define version + -> (value *version*)) + +(define port + -> (value *port*)) + +(define porters + -> (value *porters*)) + +(define implementation + -> (value *implementation*)) + +(define release + -> (value *release*)) diff --git a/shen/src/t-star.shen b/shen/src/t-star.shen index ab4fc24..56d1319 100644 --- a/shen/src/t-star.shen +++ b/shen/src/t-star.shen @@ -64,6 +64,7 @@ (define curry [F | X] -> [F | (map (function curry) X)] where (special? F) [Def F | X] -> [Def F | X] where (extraspecial? Def) + [type X A] -> [type (curry X) A] [F X Y | Z] -> (curry [[F X] Y | Z]) [F X] -> [(curry F) (curry X)] X -> X) @@ -116,25 +117,17 @@ (bind X&& (placeholder)) (bind Z (ebr X&& X Y)) (th* Z B [[X&& : A] | Hyp]); - (mode [let X Y Z] -) A Hyp <-- ! (th* Y B Hyp) + (mode [let X Y Z] -) A Hyp <-- (th* Y B Hyp) (bind X&& (placeholder)) (bind W (ebr X&& X Z)) (th* W A [[X&& : B] | Hyp]); (mode [open FileName Direction] -) [stream Direction] Hyp <-- ! (th* FileName string Hyp); (mode [type X A] -) B Hyp <-- ! (unify A B) (th* X A Hyp); (mode [input+ A Stream] -) B Hyp <-- (bind C (demodulate A)) (unify B C) (th* Stream [stream in] Hyp); - (mode [read+ : A Stream] -) B Hyp <-- (bind C (demodulate A)) (unify B C) (th* Stream [stream in] Hyp); (mode [set Var Val] -) A Hyp <-- ! (th* Var symbol Hyp) ! (th* [value Var] A Hyp) (th* Val A Hyp); - (mode [<-sem F] -) C Hyp <-- ! - (th* F [A ==> B] Hyp) - ! - (bind F&& (concat && F)) - ! - (th* F&& C [[F&& : B] | Hyp]); (mode [fail] -) symbol _ <--; X A Hyp <-- (t*-hyps Hyp NewHyp) (th* X A NewHyp); (mode [define F | X] -) A Hyp <-- ! (t*-def [define F | X] A Hyp); - (mode [defcc F | X] -) A Hyp <-- ! (t*-defcc [defcc F | X] A Hyp); (mode [defmacro | _] -) unit Hyp <-- !; (mode [process-datatype | _] -) symbol _ <--; (mode [synonyms-help | _] -) symbol _ <--; @@ -172,7 +165,7 @@ (define show-p [X : A] -> (output "~R : ~R" X A) P -> (output "~R" P)) - + \* Enumerate assumptions. *\ (define show-assumptions [] _ -> skip @@ -180,7 +173,7 @@ \* Pauses for user *\ (define pause-for-user - -> (let Byte (read-byte (stinput)) + -> (let Byte (read-byte (stinput)) (if (= Byte 94) (error "input aborted~%") (nl)))) @@ -212,7 +205,7 @@ (mode [define F | X] -) A Hyp <-- (t*-defh (compile (function ) X) F A Hyp);) (defprolog t*-defh - (mode [Sig | Rules] -) F A Hyp <-- (t*-defhh Sig (ue Sig) F A Hyp Rules);) + (mode [Sig | Rules] -) F A Hyp <-- (t*-defhh Sig (ue-sig Sig) F A Hyp Rules);) (defprolog t*-defhh Sig Sig&& F A Hyp Rules <-- (t*-rules Rules Sig&& 1 F [[F : Sig&&] | Hyp]) @@ -230,6 +223,11 @@ X -> (concat && X) where (variable? X) X -> X) +(define ue-sig + [X | Y] -> (map (function ue-sig) [X | Y]) + X -> (concat &&& X) where (variable? X) + X -> X) + (define ues X -> [X] where (ue? X) [X | Y] -> (union (ues X) (ues Y)) @@ -286,94 +284,6 @@ _ _ X A <-- (bind X (value A));) (defprolog remember - A Pattern <-- (is B (set A [Pattern | (value A)]));) - -(defprolog t*-defcc - (mode [defcc F { [list A] ==> B } | Rest] -) C Hyp - <-- (bind Sig (ue [[list A] ==> B])) - (bind ListA&& (hd Sig)) - (bind B&& (hd (tl (tl Sig)))) - (bind Rest& (plug-wildcards Rest)) - (bind Rest&& (ue Rest&)) - (get-rules Rules Rest&&) - ! - (tc-rules F Rules ListA&& B&& [[F : Sig] | Hyp] 1) - (unify C [[list A] ==> B]) - (bind Declare (declare F [[list A] ==> B]));) - -(define plug-wildcards - [X | Y] -> (map (function plug-wildcards) [X | Y]) - X -> (gensym (intern "X")) where (= X _) - X -> X) - -(defprolog get-rules - [] (mode [] -) <-- !; - [Rule | Rules] Rest <-- (first-rule Rest Rule Other) - ! - (get-rules Rules Other);) - -(defprolog first-rule - (mode [; | Other] -) [] Other <-- !; - (mode [X | Rest] -) [X | Rule] Other <-- (first-rule Rest Rule Other);) - -(defprolog tc-rules - _ (mode [] -) _ _ _ _ <--; - F (mode [Rule | Rules] -) (mode [list A] -) B Hyps N - <-- (tc-rule F Rule A B Hyps N) - (is M (+ N 1)) - ! - (tc-rules F Rules [list A] B Hyps M);) - -(defprolog tc-rule - _ Rule A B Hyps _ <-- (check-defcc-rule Rule A B Hyps); - F _ _ _ _ N <-- (bind Err (error "type error in rule ~A of ~A" N F));) - -(defprolog check-defcc-rule - Rule A B Hyps <-- - (get-syntax+semantics Syntax Semantics Rule) - ! - (syntax-hyps Syntax Hyps SynHyps A) - ! - (syntax-check Syntax A SynHyps) - ! - (semantics-check Semantics B SynHyps);) - -(defprolog syntax-hyps - (mode [] -) SynHyps SynHyps A <--; - (mode [X | Y] -) Hyps [[X : A] | SynHyps] A <-- (when (ue? X)) - ! - (syntax-hyps Y Hyps SynHyps A); - (mode [_ | Y] -) Hyps SynHyps A <-- (syntax-hyps Y Hyps SynHyps A);) - -(defprolog get-syntax+semantics - [] S (mode [:= Semantics] -) <-- ! (bind S Semantics); - [] S (mode [:= Semantics where G] -) <-- ! (bind S [where G Semantics]); - [X | Syntax] Semantics (mode [X | Rule] -) - <-- (get-syntax+semantics Syntax Semantics Rule);) - -(defprolog syntax-check - (mode [] -) _ _ <--; - (mode [X | Syntax] -) A Hyps <-- (fwhen (grammar_symbol? X)) - ! - (t* [X : [[list B] ==> C]] Hyps) - ! - (bind X&& (concat && X)) - ! - (t* [X&& : [list A]] [[X&& : [list B]] | Hyps]) - ! - (syntax-check Syntax A Hyps); - (mode [X | Syntax] -) A Hyps <-- (t* [X : A] Hyps) - ! - (syntax-check Syntax A Hyps);) + A Pattern <-- (is B (set A [Pattern | (value A)]));) ) -(defprolog semantics-check - Semantics B Hyps <-- (is Semantics* (curry (rename-semantics Semantics))) - (t* [Semantics* : B] Hyps);) - -(define rename-semantics - [X | Y] -> [(rename-semantics X) | (rename-semantics Y)] - X -> [<-sem X] where (grammar_symbol? X) - X -> X) - ) - - \ No newline at end of file + \ No newline at end of file diff --git a/shen/src/toplevel.shen b/shen/src/toplevel.shen index 540eb81..a13ecce 100644 --- a/shen/src/toplevel.shen +++ b/shen/src/toplevel.shen @@ -63,11 +63,6 @@ (trap-error (read-evaluate-print) (/. E (pr (error-to-string E) (stoutput)))) (loop))) -(define version - S -> (set *version* S)) - -(version "version 13") - (define credits -> (do (output "~%Shen 2010, copyright (C) 2010 Mark Tarver~%") (output "released under the Shen license~%") @@ -83,7 +78,7 @@ [S V | M] -> (do (set S V) (multiple-set M))) (define destroy - F -> (declare F [])) + F -> (declare F symbol)) (set *history* []) @@ -129,7 +124,7 @@ (define toplineread_loop Byte _ -> (error "line read aborted") where (= Byte (hat)) - Byte Bytes -> (let Line (compile (function ) Bytes (/. E nextline)) + Byte Bytes -> (let Line (compile (function ) (record-it Bytes) (/. E nextline)) (if (or (= Line nextline) (empty? Line)) (toplineread_loop (read-byte (stinput)) (append Bytes [Byte])) (@p Line Bytes))) diff --git a/shen/src/track.shen b/shen/src/track.shen index 7c5ee17..809b3db 100644 --- a/shen/src/track.shen +++ b/shen/src/track.shen @@ -72,7 +72,7 @@ (define track-function [defun F Params Body] -> (let KL [defun F Params (insert-tracking-code F Params Body)] - Ob (eval KL) + Ob (eval-kl KL) Tr (set *tracking* [Ob | (value *tracking*)]) Ob)) diff --git a/shen/src/types.shen b/shen/src/types.shen index 1c91adc..2a43d7b 100644 --- a/shen/src/types.shen +++ b/shen/src/types.shen @@ -70,18 +70,11 @@ F)) (define demodulate - X -> (fix (function demodh) X)) - -(define demodh - [X | Y] -> (map (function demodh) [X | Y]) - X -> (demod-atom X)) - -(define demod-atom - X -> (let Val (assoc X (value *synonyms*)) - (if (empty? Val) - X - (tl Val)))) - + X -> (trap-error (let Demod (walk (function demod) X) + (if (= Demod X) + X + (demodulate Demod))) (/. E X))) + (define variancy-test F A -> (let TypeF (typecheck F (protect B)) Check (cases (= symbol TypeF) skip @@ -108,9 +101,9 @@ (declare cd [string --> string]) (declare close [[stream A] --> [list B]]) (declare cn [string --> [string --> string]]) -(declare compile [[[list A] ==> B] --> [[list A] --> [[[list A] --> B] --> B]]]) +(declare compile [[A ==> B] --> [A --> [[A --> B] --> B]]]) (declare cons? [A --> boolean]) -(declare destroy [[A --> B] --> [A --> B]]) +(declare destroy [[A --> B] --> symbol]) (declare difference [[list A] --> [[list A] --> [list A]]]) (declare do [A --> [B --> B]]) (declare [[list A] ==> [list B]]) @@ -135,6 +128,8 @@ (declare hdv [[vector A] --> A]) (declare hdstr [string --> string]) (declare if [boolean --> [A --> [A --> A]]]) +(declare it [--> string]) +(declare implementation [--> string]) (declare include [[list symbol] --> [list symbol]]) (declare include-all-but [[list symbol] --> [list symbol]]) (declare inferences [--> number]) @@ -142,6 +137,7 @@ (declare integer? [A --> boolean]) (declare intersection [[list A] --> [[list A] --> [list A]]]) (declare kill [--> A]) +(declare language [--> string]) (declare length [[list A] --> number]) (declare limit [[vector A] --> number]) (declare load [string --> symbol]) @@ -156,14 +152,17 @@ (declare occurrences [A --> [B --> number]]) (declare occurs-check [symbol --> boolean]) (declare optimise [symbol --> boolean]) -(declare or [boolean --> [boolean --> boolean]]) +(declare or [boolean --> [boolean --> boolean]]) +(declare os [--> string]) +(declare port [--> string]) +(declare porters [--> string]) (declare pos [string --> [number --> string]]) (declare pr [string --> [[stream out] --> string]]) (declare print [A --> A]) (declare profile [[A --> B] --> [A --> B]]) (declare preclude [[list symbol] --> [list symbol]]) (declare proc-nl [string --> string]) -(declare profile-results [A --> symbol]) +(declare profile-results [[A --> B] --> [[A --> B] * number]]) (declare protect [symbol --> symbol]) (declare preclude-all-but [[list symbol] --> [list symbol]]) (declare prhush [string --> [[stream out] --> string]]) @@ -173,6 +172,7 @@ (declare read-file-as-string [string --> string]) (declare read-file [string --> [list unit]]) (declare read-from-string [string --> [list unit]]) +(declare release [--> string]) (declare remove [A --> [[list A] --> [list A]]]) (declare reverse [[list A] --> [list A]]) (declare simple-error [string --> A]) @@ -197,7 +197,6 @@ (declare thaw [[lazy A] --> A]) (declare track [symbol --> symbol]) (declare trap-error [A --> [[exception --> A] --> A]]) -(declare truncate [string --> string]) (declare tuple? [A --> boolean]) (declare undefmacro [symbol --> symbol]) (declare union [[list A] --> [[list A] --> [list A]]]) @@ -206,7 +205,7 @@ (declare unspecialise [symbol --> symbol]) (declare variable? [A --> boolean]) (declare vector? [A --> boolean]) -(declare version [string --> string]) +(declare version [--> string]) (declare write-to-file [string --> [A --> A]]) (declare write-byte [number --> [[stream out] --> number]]) (declare y-or-n? [string --> boolean]) @@ -219,7 +218,10 @@ (declare / [number --> [number --> number]]) (declare - [number --> [number --> number]]) (declare * [number --> [number --> number]]) -(declare == [A --> [B --> boolean]]) ) +(declare == [A --> [B --> boolean]]) +(declare in-> [[A ==> B] --> A]) +(declare <-out [[A ==> B] --> B]) +) diff --git a/shen/src/yacc.shen b/shen/src/yacc.shen index 0290e66..04620bc 100644 --- a/shen/src/yacc.shen +++ b/shen/src/yacc.shen @@ -55,36 +55,53 @@ (package shen. [] (define yacc - [defcc S { A ==> B } | CC_Stuff] -> (yacc [defcc S | CC_Stuff]) + [defcc S { A ==> B } | CC_Stuff] -> (yacc [defcc S | CC_Stuff]) [defcc S | CC_Stuff] -> (yacc->shen S CC_Stuff)) (define yacc->shen - S CC_Stuff -> (let CCRules (split_cc_rules CC_Stuff []) + S CC_Stuff -> (let CCRules (split_cc_rules true CC_Stuff []) CCBody (map (function cc_body) CCRules) YaccCases (yacc_cases CCBody) - CatchKill (catchkill YaccCases) - [define S (protect Stream) -> CatchKill])) + [define S (protect Stream) -> (kill-code YaccCases)])) + +(define kill-code + YaccCases -> (protect [trap-error YaccCases [lambda E [analyse-kill E]]]) where (> (occurrences kill YaccCases) 0) + YaccCases -> YaccCases) + +(define kill + -> (simple-error "yacc kill")) + +(define analyse-kill + Exception -> (let String (error-to-string Exception) + (if (= String "yacc kill") + (fail) + Exception))) (define split_cc_rules - [] [] -> [] - [] RevRule -> [(split_cc_rule (reverse RevRule) [])] - [; | CC_Stuff] RevRule - -> [(split_cc_rule (reverse RevRule) []) | (split_cc_rules CC_Stuff [])] - [X | CC_Stuff] RevRule -> (split_cc_rules CC_Stuff [X | RevRule])) + _ [] [] -> [] + Flag [] RevRule -> [(split_cc_rule Flag (reverse RevRule) [])] + Flag [; | CC_Stuff] RevRule + -> [(split_cc_rule Flag (reverse RevRule) []) | (split_cc_rules Flag CC_Stuff [])] + Flag [X | CC_Stuff] RevRule -> (split_cc_rules Flag CC_Stuff [X | RevRule])) (define split_cc_rule - [:= Semantics] RevSyntax -> [(reverse RevSyntax) Semantics] - [:= Semantics where Guard] RevSyntax + _ [:= Semantics] RevSyntax -> [(reverse RevSyntax) Semantics] + _ [:= Semantics where Guard] RevSyntax -> [(reverse RevSyntax) [where Guard Semantics]] - [] RevSyntax - -> (do (output "warning: ") - (map (/. X (output "~A " X)) (reverse RevSyntax)) - (output "has no semantics.~%") - (split_cc_rule [:= (default_semantics (reverse RevSyntax))] RevSyntax)) - [Syntax | Rule] RevSyntax -> (split_cc_rule Rule [Syntax | RevSyntax])) + Flag [] RevSyntax + -> (do (semantic-completion-warning Flag RevSyntax) + (split_cc_rule Flag [:= (default_semantics (reverse RevSyntax))] RevSyntax)) + Flag [Syntax | Rule] RevSyntax -> (split_cc_rule Flag Rule [Syntax | RevSyntax])) + +(define semantic-completion-warning + true RevSyntax -> (do (output "warning: ") + (map (/. X (output "~A " X)) (reverse RevSyntax)) + (output "has no semantics.~%")) + _ _ -> skip) (define default_semantics [] -> [] + [S] -> S where (grammar_symbol? S) [S | Syntax] -> [append S (default_semantics Syntax)] where (grammar_symbol? S) [S | Syntax] -> [cons S (default_semantics Syntax)]) @@ -114,33 +131,32 @@ (variable? S) (variable-match [S | Syntax] Stream Semantics) (jump_stream? S) (jump_stream [S | Syntax] Stream Semantics) (terminal? S) (check_stream [S | Syntax] Stream Semantics) - (list_stream? S) (list_stream (decons S) Syntax Stream Semantics) - true (error "~A is not legal syntax~%" S))) - -(define list_stream? - [_ | _] -> true - _ -> false) + (cons? S) (list-stream (decons S) Syntax Stream Semantics) + true (error "~A is not legal syntax~%" S))) +(define list-stream + S Syntax Stream Semantics + -> (let Test [and [cons? [hd Stream]] [cons? [hd [hd Stream]]]] + Placeholder (gensym place) + RunOn (syntax Syntax [pair [tl [hd Stream]] [hd [tl Stream]]] Semantics) + Action (insert-runon RunOn Placeholder + (syntax S + [pair [hd [hd Stream]] [hd [tl Stream]]] + Placeholder)) + [if Test + Action + [fail]])) + (define decons + [cons X []] -> [X] [cons X Y] -> [X | (decons Y)] - X -> X) + X -> X) + +(define insert-runon + Runon Placeholder [pair _ Placeholder] -> Runon + Runon Placeholder [X | Y] -> (map (/. Z (insert-runon Runon Placeholder Z)) [X | Y]) + _ _ X -> X) -(define list_stream - S Syntax Stream Semantics - -> (let Test [and [cons? [hd Stream]] [cons? [hd [hd Stream]]]] - Action [snd-or-fail (syntax S - [pair [hd [hd Stream]] [hdtl Stream]] - [leave! (syntax Syntax - [pair [tl [hd Stream]] - [hdtl Stream]] - Semantics)])] - Else [fail] - [if Test Action Else])) - -(define snd-or-fail - [_ Y] -> Y - _ -> (fail)) - (define strip-pathname Cs -> Cs where (not (element? "." Cs)) [_ | Cs] -> (strip-pathname Cs)) @@ -190,12 +206,15 @@ [if Test Action Else])) (define semantics - [leave! S] -> S [] -> [] S -> [hdtl (concat (protect Parse_) S)] where (grammar_symbol? S) S -> (concat (protect Parse_) S) where (variable? S) [X | Y] -> (map (function semantics) [X | Y]) - X -> X) + X -> X) + +(define snd-or-fail + [_ Y] -> Y + _ -> (fail)) (define fail -> fail!) @@ -212,17 +231,6 @@ (define [X _] -> [X []]) - -(define catchkill - Code -> [trap-error Code [lambda (protect E) [analyse-kill (protect E)]]]) - -(define analyse-kill - Exception -> (let String (error-to-string Exception) - (if (= String "Shen YACC kill") - (fail) - (simple-error String)))) - -(define kill - -> (simple-error "Shen YACC kill")) + ) \ No newline at end of file diff --git a/src/shen/Compiler.java b/src/shen/Compiler.java new file mode 100644 index 0000000..aaa2ecb --- /dev/null +++ b/src/shen/Compiler.java @@ -0,0 +1,582 @@ +package shen; + +import jdk.internal.org.objectweb.asm.*; +import jdk.internal.org.objectweb.asm.commons.GeneratorAdapter; +import jdk.internal.org.objectweb.asm.tree.ClassNode; +import jdk.internal.org.objectweb.asm.util.ASMifier; +import jdk.internal.org.objectweb.asm.util.TraceClassVisitor; +import sun.invoke.anon.AnonymousClassLoader; +import sun.misc.Unsafe; + +import java.io.PrintWriter; +import java.lang.invoke.MethodHandle; +import java.lang.invoke.MethodHandles; +import java.lang.invoke.MethodType; +import java.lang.reflect.Field; +import java.lang.reflect.Method; +import java.util.*; +import java.util.stream.Stream; + +import static java.lang.System.err; +import static java.lang.invoke.MethodType.methodType; +import static java.util.Arrays.asList; +import static java.util.Arrays.stream; +import static java.util.Collections.nCopies; +import static java.util.Collections.singleton; +import static java.util.stream.Stream.concat; +import static java.util.stream.Stream.empty; +import static jdk.internal.org.objectweb.asm.ClassReader.SKIP_DEBUG; +import static jdk.internal.org.objectweb.asm.ClassWriter.COMPUTE_FRAMES; +import static jdk.internal.org.objectweb.asm.Type.*; +import static jdk.internal.org.objectweb.asm.Type.getType; + +import static sun.invoke.util.BytecodeName.toBytecodeName; +import static sun.invoke.util.Wrapper.asPrimitiveType; +import static sun.invoke.util.Wrapper.forBasicType; + +public class Compiler implements Opcodes { + static final AnonymousClassLoader loader = AnonymousClassLoader.make(unsafe(), RT.class); + static final Map macros = new HashMap<>(); + static final List> literals = asList(Long.class, String.class, Boolean.class, Handle.class); + static final Handle + applyBSM = handle(RT.class, "applyBSM"), invokeBSM = handle(RT.class, "invokeBSM"), + symbolBSM = handle(RT.class, "symbolBSM"), or = handle(Primitives.class, "or"), + and = handle(Primitives.class, "and"); + static final Map push = new HashMap<>(); + + static { + RT.register(Macros.class, Compiler::macro); + } + + static int id = 1; + + String className; + ClassWriter cw; + + byte[] bytes; + GeneratorAdapter mv; + Object kl; + static ThreadLocal typeHint = new ThreadLocal<>(); + + Symbol self; + jdk.internal.org.objectweb.asm.commons.Method method; + Map locals; + List args; + List argTypes; + Type topOfStack; + Label recur; + + static class TypedValue { + final Type type; + final Object value; + + TypedValue(Type type, Object value) { + this.type = type; + this.value = value; + } + } + + public Compiler(Object kl, Symbol... args) throws Throwable { + this(null, "shen/ShenEval" + id++, kl, args); + } + + public Compiler(ClassWriter cn, String className, Object kl, Symbol... args) throws Throwable { + this.cw = cn; + this.className = className; + this.kl = kl; + this.args = Shen.list(args); + this.locals = new HashMap<>(); + } + + static ClassWriter classWriter(String name, Class anInterface) { + ClassWriter cw = new ClassWriter(COMPUTE_FRAMES) { + }; // Needs to be in this package for some reason. + cw.visit(V1_7, ACC_PUBLIC | ACC_FINAL, name, null, getInternalName(Object.class), new String[]{getInternalName(anInterface)}); + return cw; + } + + static jdk.internal.org.objectweb.asm.commons.Method method(String name, String desc) { + return new jdk.internal.org.objectweb.asm.commons.Method(name, desc); + } + + + static String desc(Class returnType, Class... argumentTypes) { + return methodType(returnType, argumentTypes).toMethodDescriptorString(); + } + + static String desc(Type returnType, List argumentTypes) { + return getMethodDescriptor(returnType, argumentTypes.toArray(new Type[argumentTypes.size()])); + } + + static Handle handle(Class declaringClass, String name) { + return handle(getInternalName(declaringClass), name, RT.mh(declaringClass, name).type().toMethodDescriptorString()); + } + + static Handle handle(String className, String name, String desc) { + return new Handle(Opcodes.H_INVOKESTATIC, className, name, desc); + } + + static Type boxedType(Type type) { + if (!isPrimitive(type)) return type; + return getType(forBasicType(type.getDescriptor().charAt(0)).wrapperType()); + } + + static boolean isPrimitive(Type type) { + return type.getSort() < ARRAY; + } + + static void macro(Method m) { + try { + macros.put(Primitives.intern(RT.unscramble(m.getName())), RT.lookup.unreflect(m)); + } catch (IllegalAccessException e) { + throw Shen.uncheck(e); + } + } + + GeneratorAdapter generator(int access, jdk.internal.org.objectweb.asm.commons.Method method) { + return new GeneratorAdapter(access, method, cw.visitMethod(access, method.getName(), method.getDescriptor(), null, null)); + } + + TypedValue compile(Object kl) { + return compile(kl, true); + } + + TypedValue compile(Object kl, boolean tail) { + return compile(kl, getType(Object.class), tail); + } + + TypedValue compile(Object kl, Type returnType, boolean tail) { + return compile(kl, returnType, true, tail); + } + + TypedValue compile(Object kl, Type returnType, boolean handlePrimitives, boolean tail) { + try { + Class literalClass = Shen.find(literals.stream(), c -> c.isInstance(kl)); + if (literalClass != null) push(literalClass, kl); + else if (kl instanceof Symbol) symbol((Symbol) kl); + else if (kl instanceof Collection) { + @SuppressWarnings("unchecked") + List list = new ArrayList<>((Collection) kl); + lineNumber(list); + if (list.isEmpty()) emptyList(); + else { + Object first = list.get(0); + if (first instanceof Symbol && !inScope((Symbol) first)) { + Symbol s = (Symbol) first; + if (macros.containsKey(s)) macroExpand(s, Shen.rest(list), returnType, tail); + else indy(s, Shen.rest(list), returnType, tail); + + } else { + compile(first, tail); + apply(returnType, Shen.rest(list)); + } + } + } else + throw new IllegalArgumentException("Cannot compile: " + kl + " (" + kl.getClass() + ")"); + if (handlePrimitives) handlePrimitives(returnType); + return new TypedValue(topOfStack, kl); + } catch (RuntimeException | Error e) { + throw e; + } catch (Throwable t) { + throw Shen.uncheck(t); + } + } + + void handlePrimitives(Type returnType) { + if (isPrimitive(returnType) && !isPrimitive(topOfStack)) unbox(returnType); + else if (!isPrimitive(returnType) && isPrimitive(topOfStack)) box(); + } + + void lineNumber(List list) { + if (KLReader.lines.containsKey(list)) + mv.visitLineNumber(KLReader.lines.get(list), mv.mark()); + } + + boolean inScope(Symbol x) { + return (locals.containsKey(x) || args.contains(x)); + } + + void macroExpand(Symbol s, List args, Type returnType, boolean tail) throws Throwable { + macros.get(s).invokeWithArguments(Shen.into(asList(new Macros(), tail, returnType), + Shen.vec(args.stream().map(x -> x instanceof Cons ? ((Cons) x).toList() : x)))); + } + + void indy(Symbol s, List args, Type returnType, boolean tail) throws ReflectiveOperationException { + Iterator selfCallTypes = asList(method.getArgumentTypes()).iterator(); + List typedValues = Shen.vec(args.stream().map(o -> compile(o, isSelfCall(s, args) + ? selfCallTypes.next() : getType(Object.class), false, false))); + List argumentTypes = Shen.vec(typedValues.stream().map(t -> t.type)); + if (isSelfCall(s, args)) { + if (tail) { + Shen.debug("recur: %s", s); + recur(argumentTypes); + } else { + Shen.debug("can only recur from tail position: %s", s); + mv.invokeDynamic(toBytecodeName(s.symbol), desc(method.getReturnType(), argumentTypes), invokeBSM); + returnType = method.getReturnType(); + } + } else { + if (Numbers.operators.contains(s) && returnType.equals(getType(Object.class)) && argumentTypes.size() == 2) + returnType = getType(s.fn.get(0).type().returnType()); + mv.invokeDynamic(toBytecodeName(s.symbol), desc(returnType, argumentTypes), invokeBSM); + } + topOfStack = returnType; + } + + void recur(List argumentTypes) { + for (int i = args.size() - 1; i >= 0; i--) { + if (!isPrimitive(method.getArgumentTypes()[i])) mv.valueOf(argumentTypes.get(i)); + mv.storeArg(i); + } + mv.goTo(recur); + } + + boolean isSelfCall(Symbol s, List args) { + return self.equals(s) && args.size() == this.args.size(); + } + + void apply(Type returnType, List args) throws ReflectiveOperationException { + if (!topOfStack.equals(getType(MethodHandle.class))) + mv.invokeStatic(getType(RT.class), method("function", desc(MethodHandle.class, Object.class))); + List argumentTypes = Shen.cons(getType(MethodHandle.class), Shen.vec(args.stream().map(o -> compile(o, false).type))); + mv.invokeDynamic("__apply__", desc(returnType, argumentTypes), applyBSM); + topOfStack = returnType; + } + + class Macros { + public void trap_error(boolean tail, Type returnType, Object x, Object f) throws Throwable { + Label after = mv.newLabel(); + + Label start = mv.mark(); + compile(x, returnType, tail); + mv.goTo(after); + + mv.catchException(start, mv.mark(), getType(Throwable.class)); + compile(f, false); + maybeCast(MethodHandle.class); + mv.swap(); + bindTo(); + + mv.invokeVirtual(getType(MethodHandle.class), method("invokeExact", desc(Object.class))); + if (isPrimitive(returnType)) unbox(returnType); + else topOfStack(Object.class); + mv.visitLabel(after); + } + + public void KL_if(boolean tail, Type returnType, Object test, Object then, Object _else) throws Exception { + if (test == Boolean.TRUE || test == Primitives.intern("true")) { + compile(then, returnType, tail); + return; + } + if (test == Boolean.FALSE || test == Primitives.intern("false")) { + compile(_else, returnType, tail); + return; + } + + Label elseStart = mv.newLabel(); + Label end = mv.newLabel(); + + compile(test, BOOLEAN_TYPE, false); + if (!BOOLEAN_TYPE.equals(topOfStack)) { + popStack(); + mv.throwException(getType(IllegalArgumentException.class), "boolean expected"); + return; + } + mv.visitJumpInsn(IFEQ, elseStart); + + compile(then, returnType, tail); + Type typeOfThenBranch = topOfStack; + mv.goTo(end); + + mv.visitLabel(elseStart); + compile(_else, returnType, tail); + + mv.visitLabel(end); + if (!typeOfThenBranch.equals(topOfStack) && !isPrimitive(returnType)) + topOfStack(Object.class); + } + + public void cond(boolean tail, Type returnType, List... clauses) throws Exception { + if (clauses.length == 0) + mv.throwException(getType(IllegalArgumentException.class), "condition failure"); + else { + List clause = clauses[0]; + KL_if(tail, returnType, clause.get(0), clause.get(1), + Shen.cons(Primitives.intern("cond"), Shen.rest(Shen.list((Object[]) clauses)))); + } + } + + public void or(boolean tail, Type returnType, Object x, Object... clauses) throws Exception { + if (clauses.length == 0) + bindTo(or, x); + else { + KL_if(tail, BOOLEAN_TYPE, x, true, (clauses.length > 1 ? + Shen.cons(Primitives.intern("or"), Shen.list(clauses)) : clauses[0])); + if (!isPrimitive(returnType)) mv.box(returnType); + } + } + + public void and(boolean tail, Type returnType, Object x, Object... clauses) throws Exception { + if (clauses.length == 0) + bindTo(and, x); + else { + KL_if(tail, BOOLEAN_TYPE, x, (clauses.length > 1 ? + Shen.cons(Primitives.intern("and"), Shen.list(clauses)) : clauses[0]), false); + if (!isPrimitive(returnType)) mv.box(returnType); + } + } + + public void lambda(boolean tail, Type returnType, Symbol x, Object y) throws Throwable { + fn("__lambda__", y, x); + } + + public void freeze(boolean tail, Type returnType, Object x) throws Throwable { + fn("__freeze__", x); + } + + public void defun(boolean tail, Type returnType, Symbol name, final List args, Object body) throws Throwable { + push(name); + Shen.debug("compiling: %s%s in %s", name, args, getObjectType(className).getClassName()); + name.source = Cons.toCons(asList(Primitives.intern("defun"), name, args, body)); + if (Shen.booleanProperty("shen-*installing-kl*") && RT.typesForInstallation.containsKey(name)) + typeHint.set(RT.typesForInstallation.get(name)); + fn(name.symbol, body, args.toArray(new Symbol[args.size()])); + mv.invokeStatic(getType(RT.class), method("defun", desc(Symbol.class, Symbol.class, MethodHandle.class))); + topOfStack(Symbol.class); + } + + public void let(boolean tail, Type returnType, Symbol x, Object y, Object z) throws Throwable { + Label start = mv.mark(); + compile(y, false); + Integer hidden = locals.get(x); + int let = hidden != null && tail ? hidden : mv.newLocal(topOfStack); + mv.storeLocal(let); + locals.put(x, let); + compile(z, returnType, tail); + if (hidden != null) locals.put(x, hidden); + else locals.remove(x); + if (!tail) { + mv.push((String) null); + mv.storeLocal(let); + } + mv.visitLocalVariable(x.symbol, mv.getLocalType(let).getDescriptor(), null, start, mv.mark(), let); + } + + public void KL_do(boolean tail, Type returnType, Object... xs) throws Throwable { + for (int i = 0; i < xs.length; i++) { + boolean last = i == xs.length - 1; + compile(xs[i], last ? returnType : getType(Object.class), last && tail); + if (!last) popStack(); + } + } + + public void thaw(boolean tail, Type returnType, Object f) throws Throwable { + compile(f, false); + maybeCast(MethodHandle.class); + mv.invokeVirtual(getType(MethodHandle.class), method("invokeExact", desc(Object.class))); + topOfStack(Object.class); + } + } + + void fn(String name, Object kl, Symbol... args) throws Throwable { + String bytecodeName = toBytecodeName(name) + "_" + id++; + List scope = Shen.vec(closesOver(new HashSet<>(asList(args)), kl).distinct()); + scope.retainAll(Shen.into(locals.keySet(), this.args)); + + if (name.startsWith("__")) typeHint.remove(); + List types = Shen.into(Shen.vec(scope.stream().map(this::typeOf)), typeHint.get() != null + ? Shen.vec(typeHint.get().parameterList().stream().map(Type::getType)) : nCopies(args.length, getType(Object.class))); + Type returnType = typeHint.get() != null ? getType(typeHint.get().returnType()) : getType(Object.class); + typeHint.remove(); + push(handle(className, bytecodeName, desc(returnType, types))); + insertArgs(0, scope); + + scope.addAll(asList(args)); + Compiler fn = new Compiler(cw, className, kl, scope.toArray(new Symbol[scope.size()])); + fn.method(ACC_PUBLIC | ACC_STATIC | ACC_FINAL, Primitives.intern(name), bytecodeName, returnType, types); + } + + @SuppressWarnings({"unchecked"}) + Stream closesOver(Set scope, Object kl) { + if (kl instanceof Symbol && !scope.contains(kl)) + return singleton((Symbol) kl).stream(); + if (kl instanceof Collection) { + List list = new ArrayList<>((Collection) kl); + if (!list.isEmpty()) + switch (list.get(0).toString()) { + case "let": + return concat(closesOver(scope, list.get(2)), closesOver(Shen.conj(scope, list.get(2)), list.get(3))); + case "lambda": + return closesOver(Shen.conj(scope, list.get(2)), list.get(2)); + case "defun": + return closesOver(Shen.into(scope, (Collection) list.get(2)), list.get(3)); + } + return list.stream().flatMap(o -> closesOver(scope, o)); + } + return empty(); + } + + void emptyList() { + mv.getStatic(getType(Collections.class), "EMPTY_LIST", getType(List.class)); + topOfStack(List.class); + } + + void symbol(Symbol s) throws Throwable { + if (asList("true", "false").contains(s.symbol)) { + push(Boolean.class, Boolean.valueOf(s.symbol)); + return; + } else if (locals.containsKey(s)) mv.loadLocal(locals.get(s)); + else if (args.contains(s)) mv.loadArg(args.indexOf(s)); + else push(s); + topOfStack = typeOf(s); + } + + Type typeOf(Symbol s) { + if (locals.containsKey(s)) return mv.getLocalType(locals.get(s)); + else if (args.contains(s)) return argTypes.get(args.indexOf(s)); + return getType(Symbol.class); + } + + void loadArgArray(List args) { + mv.push(args.size()); + mv.newArray(getType(Object.class)); + + for (int i = 0; i < args.size(); i++) { + mv.dup(); + mv.push(i); + compile(args.get(i), false); + box(); + mv.arrayStore(getType(Object.class)); + } + topOfStack(Object[].class); + } + + void push(Symbol kl) { + mv.invokeDynamic(toBytecodeName(kl.symbol), desc(Symbol.class), symbolBSM); + topOfStack(Symbol.class); + } + + void push(Handle handle) { + mv.push(handle); + topOfStack(MethodHandle.class); + } + + void push(Class aClass, Object kl) throws Throwable { + aClass = asPrimitiveType(aClass); + push.computeIfAbsent(aClass, c -> RT.mh(mv.getClass(), "push", c)).invoke(mv, kl); + topOfStack(aClass); + } + + void box() { + Type maybePrimitive = topOfStack; + mv.valueOf(maybePrimitive); + topOfStack = boxedType(maybePrimitive); + } + + void unbox(Type type) { + mv.unbox(type); + topOfStack = type; + } + + void popStack() { + if (topOfStack.getSize() == 1) mv.pop(); + else mv.pop2(); + } + + void maybeCast(Class type) { + maybeCast(getType(type)); + } + + void maybeCast(Type type) { + if (!type.equals(topOfStack)) mv.checkCast(type); + topOfStack = type; + } + + void topOfStack(Class aClass) { + topOfStack = getType(aClass); + } + + public Class load(String source, Class anInterface) throws Exception { + try { + cw = classWriter(className, anInterface); + cw.visitSource(source, null); + constructor(); + Method sam = RT.findSAM(anInterface); + List types = Shen.vec(stream(sam.getParameterTypes()).map(Type::getType)); + method(ACC_PUBLIC, Primitives.intern(sam.getName()), toBytecodeName(sam.getName()), getType(sam.getReturnType()), types); + bytes = cw.toByteArray(); + if (Shen.booleanProperty("*debug-asm*")) printASM(bytes, sam); + //noinspection unchecked + return (Class) loader.loadClass(bytes); + } catch (VerifyError e) { + printASM(bytes, null); + throw e; + } + } + + void method(int modifiers, Symbol name, String bytecodeName, Type returnType, List argumentTypes) { + this.self = name; + this.argTypes = argumentTypes; + this.method = method(bytecodeName, desc(returnType, argumentTypes)); + mv = generator(modifiers, method); + recur = mv.mark(); + compile(kl, returnType, true); + maybeCast(returnType); + mv.returnValue(); + mv.endMethod(); + } + + void constructor() { + GeneratorAdapter ctor = generator(ACC_PUBLIC, method("", desc(void.class))); + ctor.loadThis(); + ctor.invokeConstructor(getType(Object.class), method("", desc(void.class))); + ctor.returnValue(); + ctor.endMethod(); + } + + void bindTo(Handle handle, Object arg) { + push(handle); + compile(arg, false); + box(); + bindTo(); + } + + void bindTo() { + mv.invokeStatic(getType(RT.class), method("bindTo", desc(MethodHandle.class, MethodHandle.class, Object.class))); + topOfStack(MethodHandle.class); + } + + void insertArgs(int pos, List args) { + if (args.isEmpty()) return; + mv.push(pos); + loadArgArray(args); + mv.invokeStatic(getType(MethodHandles.class), method("insertArguments", + desc(MethodHandle.class, MethodHandle.class, int.class, Object[].class))); + topOfStack(MethodHandle.class); + } + + static void printASM(byte[] bytes, Method method) { + ASMifier asm = new ASMifier(); + PrintWriter pw = new PrintWriter(err); + TraceClassVisitor printer = new TraceClassVisitor(null, asm, pw); + if (method == null) + new ClassReader(bytes).accept(printer, SKIP_DEBUG); + else { + ClassNode cn = new ClassNode(); + new ClassReader(bytes).accept(cn, SKIP_DEBUG); + Shen.find(cn.methods.stream(), mn -> mn.name.equals(method.getName())).accept(printer); + asm.print(pw); + pw.flush(); + } + } + + static Unsafe unsafe() { + try { + Field unsafe = Unsafe.class.getDeclaredField("theUnsafe"); + unsafe.setAccessible(true); + return (Unsafe) unsafe.get(null); + } catch (Exception e) { + throw Shen.uncheck(e); + } + } +} \ No newline at end of file diff --git a/src/shen/Cons.java b/src/shen/Cons.java new file mode 100644 index 0000000..c1db18d --- /dev/null +++ b/src/shen/Cons.java @@ -0,0 +1,85 @@ +package shen; + +import java.util.*; + +import static java.util.Collections.EMPTY_LIST; +import static java.util.Collections.reverse; + +public class Cons extends AbstractCollection { + public final Object car, cdr; + public final int size; + + public Cons(Object car, Object cdr) { + this.car = car; + this.cdr = cdr; + this.size = cdr instanceof Cons ? 1 + (((Cons) cdr).size) : EMPTY_LIST.equals(cdr) ? 1 : 2; + } + + public boolean equals(Object o) { + if (this == o) return true; + if (o instanceof List && isList()) //noinspection unchecked + return Shen.vec(toList().stream().map(Numbers::maybeNumber)).equals(o); + if (o == null || getClass() != o.getClass()) return false; + //noinspection ConstantConditions + Cons cons = (Cons) o; + return Primitives.EQ(car, cons.car) && cdr.equals(cons.cdr); + } + + boolean isList() { + return cdr instanceof Cons || EMPTY_LIST.equals(cdr); + } + + public int hashCode() { + return 31 * car.hashCode() + cdr.hashCode(); + } + + @SuppressWarnings("NullableProblems") + public Iterator iterator() { + if (!isList()) throw new IllegalStateException("cons pair is not a list: " + this); + return new ConsIterator(); + } + + public int size() { + return size; + } + + public String toString() { + if (isList()) return Shen.vec(toList().stream().map(Numbers::maybeNumber)).toString(); + return "[" + Numbers.maybeNumber(car) + " | " + Numbers.maybeNumber(cdr) + "]"; + } + + public List toList() { + return new ArrayList(this); + } + + public static Collection toCons(List list) { + if (list.isEmpty()) return list; + Cons cons = null; + list = new ArrayList<>(list); + reverse(list); + for (Object o : list) { + if (o instanceof List) o = toCons((List) o); + if (cons == null) cons = new Cons(o, EMPTY_LIST); + else cons = new Cons(o, cons); + } + return cons; + } + + class ConsIterator implements Iterator { + Cons cons = Cons.this; + + public boolean hasNext() { + return cons != null; + } + + public Object next() { + if (cons == null) throw new NoSuchElementException(); + try { + if (!cons.isList()) return cons; + return cons.car; + } finally { + cons = !cons.isList() || EMPTY_LIST.equals(cons.cdr) ? null : (Cons) cons.cdr; + } + } + } +} \ No newline at end of file diff --git a/src/shen/KLReader.java b/src/shen/KLReader.java new file mode 100644 index 0000000..7679438 --- /dev/null +++ b/src/shen/KLReader.java @@ -0,0 +1,57 @@ +package shen; + +import java.io.IOException; +import java.io.Reader; +import java.util.IdentityHashMap; +import java.util.List; +import java.util.Map; +import java.util.Scanner; + +public class KLReader { + static Map lines = new IdentityHashMap<>(); + static int currentLine; + + static List read(Reader reader) throws Exception { + lines.clear(); + currentLine = 1; + return tokenizeAll(new Scanner(reader).useDelimiter("(\\s|\\)|\")")); + } + + static Object tokenize(Scanner sc) throws Exception { + whitespace(sc); + if (find(sc, "\\(")) return tokenizeAll(sc); + if (find(sc, "\"")) return nextString(sc); + if (find(sc, "\\)")) return null; + if (sc.hasNextBoolean()) return sc.nextBoolean(); + if (sc.hasNextLong()) return Numbers.integer(sc.nextLong()); + if (sc.hasNextDouble()) return Numbers.real(sc.nextDouble()); + if (sc.hasNext()) return Primitives.intern(sc.next()); + return null; + } + + static void whitespace(Scanner sc) { + sc.skip("[^\\S\\n]*"); + while (find(sc, "\\n")) { + currentLine++; + sc.skip("[^\\S\\n]*"); + } + } + + static boolean find(Scanner sc, String pattern) { + return sc.findWithinHorizon(pattern, 1) != null; + } + + static Object nextString(Scanner sc) throws IOException { + String s = sc.findWithinHorizon("(?s).*?\"", 0); + currentLine += s.replaceAll("[^\n]", "").length(); + return s.substring(0, s.length() - 1); + } + + static List tokenizeAll(Scanner sc) throws Exception { + List list = Shen.list(); + lines.put(list, currentLine); + Object x; + while ((x = tokenize(sc)) != null) list.add(x); + return list; + } +} \ No newline at end of file diff --git a/src/shen/Numbers.java b/src/shen/Numbers.java new file mode 100644 index 0000000..9b2642c --- /dev/null +++ b/src/shen/Numbers.java @@ -0,0 +1,211 @@ +package shen; + +import jdk.internal.org.objectweb.asm.ClassWriter; +import jdk.internal.org.objectweb.asm.Label; +import jdk.internal.org.objectweb.asm.Opcodes; +import jdk.internal.org.objectweb.asm.Type; +import jdk.internal.org.objectweb.asm.commons.GeneratorAdapter; + +import java.lang.reflect.Method; +import java.util.HashSet; +import java.util.Set; +import java.util.function.Consumer; + +import static java.lang.Double.doubleToLongBits; +import static java.lang.Double.longBitsToDouble; +import static java.lang.Math.toIntExact; +import static jdk.internal.org.objectweb.asm.Type.*; +import static jdk.internal.org.objectweb.asm.commons.GeneratorAdapter.*; +import static sun.invoke.util.BytecodeName.toBytecodeName; +import static sun.invoke.util.BytecodeName.toSourceName; + +public class Numbers implements Opcodes { + static final long tag = 1, real = 0, integer = 1; + static final Set operators = new HashSet<>(); + + // longs are either 63 bit signed integers or doubleToLongBits with bit 0 used as tag, 0 = double, 1 = long. + // Java: 5ms, Shen.java: 10ms, Boxed Java: 15ms. Which ever branch that starts will be faster for some reason. + static { + ClassWriter cw = new ClassWriter(ClassWriter.COMPUTE_FRAMES); + cw.visit(V1_7, ACC_PUBLIC | ACC_FINAL, "shen/Shen$Operators", null, getInternalName(Object.class), null); + + binaryOp(cw, "+", ADD); + binaryOp(cw, "-", SUB); + binaryOp(cw, "*", MUL); + binaryOp(cw, "/", realOp(DIV), integerDivision()); + binaryOp(cw, "%", REM); + binaryComp(cw, "<", LT); + binaryComp(cw, "<=", LE); + binaryComp(cw, ">", GT); + binaryComp(cw, ">=", GE); + + RT.register(Compiler.loader.loadClass(cw.toByteArray()), Numbers::op); + } + + static Consumer integerOp(int op) { + return mv -> toInteger(mv, op); + } + + static Consumer realOp(int op) { + return mv -> toReal(mv, op); + } + + static Consumer integerDivision() { + return mv -> { + Label notZero = new Label(); + mv.dup2(); + mv.visitInsn(L2I); + mv.ifZCmp(IFNE, notZero); + mv.newInstance(getType(ArithmeticException.class)); + mv.dup(); + mv.push("Division by zero"); + mv.invokeConstructor(getType(ArithmeticException.class), + Compiler.method("", Compiler.desc(void.class, String.class))); + mv.throwException(); + mv.visitLabel(notZero); + mv.visitInsn(L2D); + mv.swap(DOUBLE_TYPE, LONG_TYPE); + mv.visitInsn(L2D); + mv.swap(DOUBLE_TYPE, DOUBLE_TYPE); + toReal(mv, DIV); + }; + } + + static void toInteger(GeneratorAdapter mv, int op) { + mv.math(op, LONG_TYPE); + mv.push((int) tag); + mv.visitInsn(LSHL); + mv.push(integer); + mv.visitInsn(LOR); + } + + static void toReal(GeneratorAdapter mv, int op) { + mv.math(op, DOUBLE_TYPE); + mv.invokeStatic(getType(Double.class), + Compiler.method("doubleToRawLongBits", Compiler.desc(long.class, double.class))); + mv.push(~integer); + mv.visitInsn(LAND); + } + + static void binaryComp(ClassWriter cw, String op, int test) { + binaryOp(cw, op, boolean.class, comparison(DOUBLE_TYPE, test), comparison(LONG_TYPE, test)); + } + + static Consumer comparison(Type type, int test) { + return mv -> { + Label _else = new Label(); + mv.ifCmp(type, test, _else); + mv.push(false); + mv.returnValue(); + mv.visitLabel(_else); + mv.push(true); + mv.returnValue(); + }; + } + + static void binaryOp(ClassWriter cw, String op, int instruction) { + binaryOp(cw, op, long.class, realOp(instruction), integerOp(instruction)); + } + + static void binaryOp(ClassWriter cw, String op, Consumer realOp, Consumer integerOp) { + binaryOp(cw, op, long.class, realOp, integerOp); + } + + static void binaryOp(ClassWriter cw, String op, Class returnType, Consumer realOp, + Consumer integerOp) { + GeneratorAdapter mv = new GeneratorAdapter(ACC_PUBLIC + ACC_STATIC, + Compiler.method(toBytecodeName(op), Compiler.desc(returnType, long.class, long.class)), null, null, cw); + + isInteger(mv, 0); + Label argOneIsLong = new Label(); + mv.ifZCmp(IFNE, argOneIsLong); + asDouble(mv, 0); + isInteger(mv, 1); + Label argTwoIsLong = new Label(); + mv.ifZCmp(IFNE, argTwoIsLong); + asDouble(mv, 1); + Label doubleOperation = new Label(); + mv.goTo(doubleOperation); + mv.visitLabel(argTwoIsLong); + asLong(mv, 1); + mv.visitInsn(L2D); + mv.goTo(doubleOperation); + mv.visitLabel(argOneIsLong); + isInteger(mv, 1); + Label longOperation = new Label(); + mv.ifZCmp(IFNE, longOperation); + asLong(mv, 0); + mv.visitInsn(L2D); + asDouble(mv, 1); + mv.visitLabel(doubleOperation); + realOp.accept(mv); + mv.returnValue(); + mv.visitLabel(longOperation); + asLong(mv, 0); + asLong(mv, 1); + integerOp.accept(mv); + mv.returnValue(); + mv.endMethod(); + } + + static void asDouble(GeneratorAdapter mv, int arg) { + mv.loadArg(arg); + mv.invokeStatic(getType(Double.class), Compiler.method("longBitsToDouble", + Compiler.desc(double.class, long.class))); + } + + static void asLong(GeneratorAdapter mv, int arg) { + mv.loadArg(arg); + mv.push((int) tag); + mv.visitInsn(LSHR); + } + + static void isInteger(GeneratorAdapter mv, int arg) { + mv.loadArg(arg); + mv.visitInsn(L2I); + mv.push((int) tag); + mv.visitInsn(IAND); + } + + static void op(Method op) { + try { + Symbol symbol = Primitives.intern(toSourceName(op.getName())); + symbol.fn.add(RT.lookup.unreflect(op)); + operators.add(symbol); + } catch (IllegalAccessException e) { + throw Shen.uncheck(e); + } + } + + static Object maybeNumber(Object o) { + return o instanceof Long ? asNumber((Long) o) : o; + } + + public static long number(Number n) { + return n instanceof Double ? real(n.doubleValue()) : integer(n.longValue()); + } + + static long real(double d) { + return ~tag & doubleToLongBits(d); + } + + static long integer(long l) { + return l << tag | tag; + } + + static double asDouble(long l) { + return isInteger(l) ? l >> tag : longBitsToDouble(l); + } + + public static int asInt(long l) { + return toIntExact(asNumber(l).longValue()); + } + + public static Number asNumber(long fp) { //noinspection RedundantCast + return isInteger(fp) ? (Number) (fp >> tag) : (Number) longBitsToDouble(fp); + } + + static boolean isInteger(long l) { + return (tag & l) == integer; + } +} \ No newline at end of file diff --git a/src/shen/Overrides.java b/src/shen/Overrides.java new file mode 100644 index 0000000..4142c87 --- /dev/null +++ b/src/shen/Overrides.java @@ -0,0 +1,44 @@ +package shen; + +import java.util.Collection; + +import static java.lang.Character.isUpperCase; +import static java.lang.Math.floorMod; +import static java.util.Arrays.fill; + +public class Overrides { + static final Symbol _true = Primitives.intern("true"), + _false = Primitives.intern("false"), + shen_tuple = Primitives.intern("shen.tuple"); + + public static boolean variableP(Object x) { + return x instanceof Symbol && isUpperCase(((Symbol) x).symbol.charAt(0)); + } + + public static boolean booleanP(Object x) { + return x instanceof Boolean || _true == x || _false == x; + } + + public static boolean symbolP(Object x) { + return x instanceof Symbol && !booleanP(x); + } + + public static long length(Collection x) { + return Numbers.integer(x.size()); + } + + public static Object[] ATp(Object x, Object y) { + return new Object[]{shen_tuple, x, y}; + } + + public static long hash(Object s, long limit) { + long hash = s.hashCode(); + if (hash == 0) return 1; + return Numbers.integer(floorMod(hash, limit >> Numbers.tag)); + } + + public static Object[] shen_fillvector(Object[] vector, long counter, long n, Object x) { + fill(vector, (int) (counter >> Numbers.tag), (int) (n >> Numbers.tag) + 1, x); + return vector; + } +} \ No newline at end of file diff --git a/src/shen/Primitives.java b/src/shen/Primitives.java new file mode 100644 index 0000000..1691899 --- /dev/null +++ b/src/shen/Primitives.java @@ -0,0 +1,217 @@ +package shen; + +import java.io.*; +import java.lang.invoke.MethodHandle; +import java.util.Objects; +import java.util.concurrent.Callable; + +import static java.lang.System.currentTimeMillis; +import static java.util.Arrays.deepToString; +import static java.util.Arrays.fill; +import static java.util.Collections.EMPTY_LIST; + +public class Primitives { + public static boolean EQ(Object left, Object right) { + if (Objects.equals(left, right)) return true; + if (absvectorP(left) && absvectorP(right)) { + Object[] leftA = (Object[]) left; + Object[] rightA = (Object[]) right; + if (leftA.length != rightA.length) return false; + for (int i = 0; i < leftA.length; i++) + if (!EQ(leftA[i], rightA[i])) + return false; + return true; + } + if (numberP(left) && numberP(right)) { + long a = (Long) left; + long b = (Long) right; + return (Numbers.tag & a) == Numbers.integer && (Numbers.tag & b) == Numbers.integer ? a == b : Numbers.asDouble(a) == Numbers.asDouble(b); + } + return false; + } + + public static Class KL_import(Symbol s) throws ClassNotFoundException { + Class aClass = Class.forName(s.symbol); + return set(intern(aClass.getSimpleName()), aClass); + } + + static Class KL_import(Class type) { + try { + return KL_import(intern(type.getName())); + } catch (ClassNotFoundException e) { + throw Shen.uncheck(e); + } + } + + public static Cons cons(Object x, Object y) { + return new Cons(x, y); + } + + public static boolean consP(Object x) { + return x instanceof Cons; + } + + public static Object simple_error(String s) { + throw new RuntimeException(s, null, false, false) { + }; + } + + public static String error_to_string(Throwable e) { + return e.getMessage() == null ? e.toString() : e.getMessage(); + } + + public static Object hd(Cons cons) { + return cons.car; + } + + public static Object tl(Cons cons) { + return cons.cdr; + } + + public static String str(Object x) { + if (consP(x)) throw new IllegalArgumentException(x + " is not an atom; str cannot convert it to a string."); + if (x != null && x.getClass().isArray()) return deepToString((Object[]) x); + if (x instanceof Long) x = Numbers.asNumber((Long) x); + return String.valueOf(x); + } + + public static String pos(String x, long n) { + return str(x.charAt((int) (n >> Numbers.tag))); + } + + public static String tlstr(String x) { + return x.substring(1); + } + + public static Class type(Object x) { + return x.getClass(); + } + + public static Object[] absvector(long n) { + Object[] objects = new Object[(int) (n >> Numbers.tag)]; + fill(objects, intern("fail!")); + return objects; + } + + public static boolean absvectorP(Object x) { + return x.getClass() == Object[].class; + } + + public static Object LT_address(Object[] vector, long n) { + return vector[((int) (n >> Numbers.tag))]; + } + + public static Object[] address_GT(Object[] vector, long n, Object value) { + vector[((int) (n >> Numbers.tag))] = value; + return vector; + } + + public static boolean numberP(Object x) { + return x instanceof Long; + } + + public static boolean stringP(Object x) { + return x instanceof String; + } + + public static String n_GTstring(long n) { + if (n >> Numbers.tag < 0) throw new IllegalArgumentException(n + " is not a valid character"); + return Character.toString((char) (n >> Numbers.tag)); + } + + public static String byte_GTstring(long n) { + return n_GTstring(n >> Numbers.tag); + } + + public static long string_GTn(String s) { + return Numbers.integer((int) s.charAt(0)); + } + + public static long read_byte(InputStream s) throws IOException { + return Numbers.integer(s.read()); + } + + public static Long convertToLong(Object x) { + return (Long) Numbers.asNumber((Long) x); + } + + public static T write_byte(T x, OutputStream s) throws IOException { + s.write(convertToLong(x).byteValue()); + s.flush(); + return x; + } + + public static Closeable open(String string, Symbol direction) throws IOException { + File file = new File(string); + if (!file.isAbsolute()) { + //noinspection RedundantCast + file = new File((String) intern("*home-directory*").value(), string); + } + + switch (direction.symbol) { + case "in": + return new BufferedInputStream(new FileInputStream(file)); + case "out": + return new BufferedOutputStream(new FileOutputStream(file)); + } + throw new IllegalArgumentException("invalid direction"); + } + + public static Object close(Closeable stream) throws IOException { + stream.close(); + return EMPTY_LIST; + } + + static long startTime = System.currentTimeMillis(); + + public static long get_time(Symbol time) { + switch (time.symbol) { + case "run": + return Numbers.real((currentTimeMillis() - startTime) / 1000.0); + case "unix": + return Numbers.integer(currentTimeMillis() / 1000); + } + throw new IllegalArgumentException("get-time does not understand the parameter " + time); + } + + public static String cn(String s1, String s2) { + return s1 + s2; + } + + public static Symbol intern(String name) { + return Shen.symbols.computeIfAbsent(name, Symbol::new); + } + + public static T value(Symbol x) { + return x.value(); + } + + @SuppressWarnings("unchecked") + public static T set(Symbol x, T y) { + return (T) (x.var = y); + } + + static T set(String x, T y) { + return set(intern(x), y); + } + + public static MethodHandle function(Shen.Invokable x) throws Exception { + return x.invoker(); + } + + static MethodHandle function(String x) throws Exception { + return function(intern(x)); + } + + public static Object eval_kl(Object kl) throws Throwable { + return new Compiler(kl).load("__eval__", Callable.class).newInstance().call(); + } + + public static boolean or(boolean x, boolean y) { + return x || y; + } + + public static boolean and(boolean x, boolean y) { + return x && y; + } +} \ No newline at end of file diff --git a/src/shen/RT.java b/src/shen/RT.java new file mode 100644 index 0000000..4d71fb3 --- /dev/null +++ b/src/shen/RT.java @@ -0,0 +1,485 @@ +package shen; + +import sun.invoke.util.Wrapper; + +import java.lang.invoke.*; +import java.lang.reflect.Constructor; +import java.lang.reflect.Executable; +import java.lang.reflect.Method; +import java.util.*; +import java.util.function.Consumer; + +import static java.lang.String.format; +import static java.lang.invoke.MethodHandleProxies.asInterfaceInstance; +import static java.lang.invoke.MethodHandles.*; +import static java.lang.invoke.MethodHandles.guardWithTest; +import static java.lang.invoke.MethodHandles.insertArguments; +import static java.lang.invoke.MethodType.genericMethodType; +import static java.lang.invoke.MethodType.methodType; +import static java.lang.invoke.SwitchPoint.invalidateAll; +import static java.lang.reflect.Modifier.isPublic; +import static java.util.Arrays.asList; +import static java.util.Arrays.stream; +import static java.util.Objects.deepEquals; +import static java.util.function.Predicate.isEqual; + +import static sun.invoke.util.BytecodeName.toBytecodeName; +import static sun.invoke.util.BytecodeName.toSourceName; +import static sun.invoke.util.Wrapper.*; +import static sun.invoke.util.Wrapper.forBasicType; + +public class RT { + static final MethodHandles.Lookup lookup = lookup(); + static final Set overrides = new HashSet<>(); + static final Set builtins = new HashSet<>(); + static final Map typesForInstallation = new HashMap<>(); + static final Map sites = new HashMap<>(); + static final Map guards = new HashMap<>(); + + static final MethodHandle + link = mh(RT.class, "link"), proxy = mh(RT.class, "proxy"), + checkClass = mh(RT.class, "checkClass"), toIntExact = mh(Math.class, "toIntExact"), + asNumber = mh(Numbers.class, "asNumber"), number = mh(Numbers.class, "number"), + asInt = mh(Numbers.class, "asInt"), toList = mh(Cons.class, "toList"), + partial = mh(RT.class, "partial"), arityCheck = mh(RT.class, "arityCheck"); + + public static Object link(MutableCallSite site, String name, Object... args) throws Throwable { + name = toSourceName(name); + MethodType type = site.type(); + Shen.debug("LINKING: %s%s %s", name, type, Shen.vec(stream(args).map(Numbers::maybeNumber))); + List> actualTypes = Shen.vec(stream(args).map(Object::getClass)); + Shen.debug("actual types: %s", actualTypes); + Symbol symbol = Primitives.intern(name); + Shen.debug("candidates: %s", symbol.fn); + + if (symbol.fn.isEmpty()) { + MethodHandle java = javaCall(site, name, type, args); + if (java != null) { + Shen.debug("calling java: %s", java); + site.setTarget(java.asType(type)); + return java.invokeWithArguments(args); + } + throw new NoSuchMethodException("undefined function " + name + type + + (symbol.fn.isEmpty() ? "" : " in " + Shen.vec(symbol.fn.stream().map(MethodHandle::type)))); + } + + int arity = symbol.fn.get(0).type().parameterCount(); + if (arity > args.length) { + MethodHandle partial = insertArguments(reLinker(name, arity), 0, args); + Shen.debug("partial: %s", partial); + return partial; + } + + MethodHandle match = Shen.find(symbol.fn.stream(), f -> Shen.every(actualTypes, f.type().parameterList(), RT::canCastStrict)); + if (match == null) throw new NoSuchMethodException("undefined function " + name + type); + Shen.debug("match based on argument types: %s", match); + + MethodHandle fallback = linker(site, toBytecodeName(name)).asType(type); + if (symbol.fn.size() > 1 && !match.type().parameterList().stream().allMatch(isEqual(long.class))) { + match = guards.computeIfAbsent(asList(type, symbol.fn), key -> guard(type, symbol.fn)); + Shen.debug("selected: %s", match); + } + + synchronized (symbol.symbol) { + if (symbol.fnGuard == null) symbol.fnGuard = new SwitchPoint(); + site.setTarget(symbol.fnGuard.guardWithTest(match.asType(type), fallback)); + } + Object result = match.invokeWithArguments(args); + + /* + + TODO : + + Originally the code was : + + maybeRecompile(type, symbol, result == null ? Object.class : result.getClass()); + + However if we have this then loading the following into the repl gives : + + (0-) + (define funcLetAndRecurse + X -> (let Z (- X 1) + (if (= Z 1) (* 3 X) (funcLetAndRecurse Z)))) + + (1-)(funcLetAndRecurse 5) + -1 + + Then changed the code to : + + try { + maybeRecompile(type, symbol, result == null ? Object.class : result.getClass()); + } catch (Exception e) { + } + + Now running the code above gives : + + (0-) + (define funcLetAndRecurse + X -> (let Z (- X 1) + (if (= Z 1) (* 3 X) (funcLetAndRecurse Z)))) + + (1-)(funcLetAndRecurse 5) + 6 + + which is the correct result. However the following piece of code now breaks (under Shen 14 onwards) : + + (defprolog mem + X (mode [X | _] -) <--; + X (mode [_ | Y] -) <-- (mem X Y);) + + (prolog? (mem 1 [X | 2]) (return X)) + + in that an ASM exception is thrown. Commenting out this code seems to eliminate the prolog bug. + + The place where the let recursive bug was addressed was : + + https://github.com/artella-coding/Shen.java/commit/bdb0cc112f7d7482ba41c024f8f2f8d60237f1c1 + + and the transition to Shen 14 (which causes the problems with the prolog code) is from + + https://github.com/artella-coding/Shen.java/commit/bdb0cc112f7d7482ba41c024f8f2f8d60237f1c1 + + to + + https://github.com/artella-coding/Shen.java/commit/ff6d45d9f0793554d034760336c822db7afff00e + + Need to reinvestigate the maybeRecompile function at later stage + */ + + /* + //See comments above + + //maybeRecompile(type, symbol, result == null ? Object.class : result.getClass()); + try { + //maybeRecompile(type, symbol, result == null ? Object.class : result.getClass()); + } catch (Exception e) { + } + */ + + return result; + } + + static void maybeRecompile(MethodType type, Symbol symbol, Class returnType) throws Throwable { + if (symbol.source == null || Shen.booleanProperty("shen-*installing-kl*")) return; + MethodType signature = typeSignature(symbol); + type = signature != null ? signature : type.changeReturnType(isWrapperType(returnType) ? wrapper(returnType).primitiveType() + : isPrimitiveType(returnType) ? returnType : Object.class); + if ((signature != null || (type.changeReturnType(Object.class).hasPrimitives() && !builtins.contains(symbol)))) + recompile(type, symbol); + } + + static void recompile(MethodType type, Symbol symbol) throws Throwable { + if (symbol.source == null || symbol.fn.stream().map(MethodHandle::type).anyMatch(isEqual(type))) return; + Shen.debug("recompiling as %s: %s", type, symbol.source); + List fn = new ArrayList<>(symbol.fn); + try { + Compiler.typeHint.set(type); + Primitives.eval_kl(symbol.source); + } finally { + Compiler.typeHint.remove(); + symbol.fn.addAll(fn); + if (!type.returnType().equals(Object.class)) + symbol.fn.removeIf(f -> f.type().equals(type.changeReturnType(Object.class))); + } + } + + static final Map types = new HashMap<>(); + + static { + types.put(Primitives.intern("symbol"), Symbol.class); + types.put(Primitives.intern("number"), long.class); + types.put(Primitives.intern("boolean"), boolean.class); + types.put(Primitives.intern("string"), String.class); + types.put(Primitives.intern("exception"), Exception.class); + types.put(Primitives.intern("list"), Iterable.class); + types.put(Primitives.intern("vector"), Object[].class); + } + + static Set tooStrictTypes = new HashSet<>(asList(Primitives.intern("concat"), Primitives.intern("fail-if"), + Primitives.intern("tail"), Primitives.intern("systemf"))); + + static MethodType typeSignature(Symbol symbol) throws Throwable { + if (tooStrictTypes.contains(symbol) || !hasKnownSignature(symbol)) return null; + return typeSignature(symbol, shenTypeSignature(symbol)); + } + + static MethodType typeSignature(Symbol symbol, List shenTypes) { + List> javaTypes = new ArrayList<>(); + for (Object argumentType : shenTypes) { + if (argumentType instanceof Cons) + argumentType = ((Cons) argumentType).car; + javaTypes.add(types.containsKey(argumentType) ? types.get(argumentType) : + argumentType instanceof Class ? (Class) argumentType : Object.class); + } + MethodType type = methodType(javaTypes.remove(javaTypes.size() - 1), javaTypes); + Shen.debug("%s has Shen type signature: %s mapped to Java %s", symbol, shenTypes, type); + return type; + } + + static boolean hasKnownSignature(Symbol symbol) { + return Primitives.intern("shen.*signedfuncs*").var instanceof Cons && ((Cons) Primitives.intern("shen.*signedfuncs*").var).contains(symbol); + } + + static List shenTypeSignature(Symbol symbol) throws Throwable { + return shenTypeSignature(((Cons) Shen.eval(format("(shen-typecheck %s (gensym A))", symbol))).toList()); + } + + static List shenTypeSignature(List signature) { + if (signature.size() != 3) + return Shen.vec(signature.stream().filter(isEqual(Primitives.intern("-->")).negate())); + List argumentTypes = new ArrayList<>(); + for (; signature.size() == 3; signature = ((Cons) signature.get(2)).toList()) { + argumentTypes.add(signature.get(0)); + if (!(signature.get(2) instanceof Cons) || signature.get(2) instanceof Cons + && !((Cons) signature.get(2)).contains(Primitives.intern("-->"))) { + argumentTypes.add(signature.get(2)); + break; + } + } + return argumentTypes; + } + + static MethodHandle guard(MethodType type, List candidates) { + candidates = bestMatchingMethods(type, candidates); + Shen.debug("applicable candidates: %s", candidates); + MethodHandle match = candidates.get(candidates.size() - 1).asType(type); + for (int i = candidates.size() - 1; i > 0; i--) { + MethodHandle fallback = candidates.get(i); + MethodHandle target = candidates.get(i - 1); + Class differentType = Shen.find(target.type().parameterList(), fallback.type().parameterList(), (x, y) -> !x.equals(y)); + int firstDifferent = target.type().parameterList().indexOf(differentType); + if (firstDifferent == -1) firstDifferent = 0; + Shen.debug("switching on %d argument type %s", firstDifferent, differentType); + Shen.debug("target: %s ; fallback: %s", target, fallback); + MethodHandle test = checkClass.bindTo(differentType); + test = dropArguments(test, 0, type.dropParameterTypes(firstDifferent, type.parameterCount()).parameterList()); + test = test.asType(test.type().changeParameterType(firstDifferent, type.parameterType(firstDifferent))); + match = guardWithTest(test, target.asType(type), match); + } + return match; + } + + static List bestMatchingMethods(MethodType type, List candidates) { + return Shen.vec(candidates.stream() + .filter(f -> Shen.every(type.parameterList(), f.type().parameterList(), RT::canCast)) + .sorted((x, y) -> y.type().changeReturnType(type.returnType()).equals(y.type().erase()) ? -1 : 1) + .sorted((x, y) -> Shen.every(y.type().parameterList(), x.type().parameterList(), RT::canCast) ? -1 : 1)); + } + + public static boolean checkClass(Class xClass, Object x) { + return xClass != null && canCastStrict(x.getClass(), xClass); + } + + static MethodHandle relinkOn(Class exception, MethodHandle fn, MethodHandle fallback) { + return catchException(fn.asType(fallback.type()), exception, dropArguments(fallback, 0, Exception.class)); + } + + static MethodHandle javaCall(MutableCallSite site, String name, MethodType type, Object... args) throws Exception { + if (name.endsWith(".")) { + Class aClass = Primitives.intern(name.substring(0, name.length() - 1)).value(); + if (aClass != null) + return findJavaMethod(type, aClass.getName(), aClass.getConstructors()); + } + if (name.startsWith(".")) + return relinkOn(ClassCastException.class, findJavaMethod(type, name.substring(1), args[0].getClass().getMethods()), + linker(site, toBytecodeName(name))); + String[] classAndMethod = name.split("/"); + if (classAndMethod.length == 2 && Primitives.intern(classAndMethod[0]).var instanceof Class) + return findJavaMethod(type, classAndMethod[1], ((Class) Primitives.intern(classAndMethod[0]).value()).getMethods()); + return null; + } + + public static Object proxy(Method sam, Object x) throws Throwable { + if (x instanceof MethodHandle) { + MethodHandle target = (MethodHandle) x; + int arity = sam.getParameterTypes().length; + int actual = target.type().parameterCount(); + if (arity < actual) target = insertArguments(target, arity, new Object[actual - arity]); + if (arity > actual) + target = dropArguments(target, actual, asList(sam.getParameterTypes()).subList(actual, arity)); + return asInterfaceInstance(sam.getDeclaringClass(), target); + } + return null; + } + + static MethodHandle filterJavaTypes(MethodHandle method) throws IllegalAccessException { + MethodHandle[] filters = new MethodHandle[method.type().parameterCount()]; + for (int i = 0; i < method.type().parameterCount() - (method.isVarargsCollector() ? 1 : 0); i++) + if (isSAM(method.type().parameterType(i))) + filters[i] = proxy.bindTo(findSAM(method.type().parameterType(i))) + .asType(methodType(method.type().parameterType(i), Object.class)); + else if (canCast(method.type().parameterType(i), int.class)) + filters[i] = asInt.asType(methodType(method.type().parameterType(i), Object.class)); + else if (canCast(method.type().wrap().parameterType(i), Number.class)) + filters[i] = asNumber.asType(methodType(method.type().parameterType(i), Object.class)); + if (canCast(method.type().wrap().returnType(), Number.class)) + method = filterReturnValue(method, number.asType(methodType(long.class, method.type().returnType()))); + return filterArguments(method, 0, filters); + } + + static MethodHandle findJavaMethod(MethodType type, String method, T[] methods) { + return Shen.some(stream(methods), m -> { + try { + if (m.getName().equals(method)) { + m.setAccessible(true); + MethodHandle mh = (m instanceof Method) ? lookup.unreflect((Method) m) : lookup.unreflectConstructor((Constructor) m); + mh.asType(methodType(type.returnType(), Shen.vec(type.parameterList().stream() + .map(c -> c.equals(Long.class) ? Integer.class : c.equals(long.class) ? int.class : c)))); + return filterJavaTypes(mh); + } + } catch (WrongMethodTypeException | IllegalAccessException ignored) { + } + return null; + }); + } + + public static MethodHandle function(Object target) throws Exception { + return target instanceof Shen.Invokable ? Primitives.function((Shen.Invokable) target) : (MethodHandle) target; + } + + static MethodHandle linker(MutableCallSite site, String name) { + return insertArguments(link, 0, site, name).asCollector(Object[].class, site.type().parameterCount()); + } + + static MethodHandle reLinker(String name, int arity) throws IllegalAccessException { + MutableCallSite reLinker = new MutableCallSite(genericMethodType(arity)); + return relinkOn(IllegalStateException.class, reLinker.dynamicInvoker(), linker(reLinker, toBytecodeName(name))); + } + + public static CallSite invokeBSM(Lookup lookup, String name, MethodType type) throws IllegalAccessException { + if (isOverloadedInternalFunction(name)) return invokeCallSite(name, type); + return sites.computeIfAbsent(name + type, key -> invokeCallSite(name, type)); + } + + static boolean isOverloadedInternalFunction(String name) { + return Primitives.intern(toSourceName(name)).fn.size() > 1; + } + + static CallSite invokeCallSite(String name, MethodType type) { + MutableCallSite site = new MutableCallSite(type); + site.setTarget(linker(site, name).asType(type)); + return site; + } + + public static CallSite symbolBSM(Lookup lookup, String name, MethodType type) { + return sites.computeIfAbsent(name, key -> new ConstantCallSite(constant(Symbol.class, Primitives.intern(toSourceName(name))))); + } + + public static CallSite applyBSM(Lookup lookup, String name, MethodType type) throws Exception { + return sites.computeIfAbsent(name + type, key -> applyCallSite(type)); + } + + public static Object partial(MethodHandle target, Object... args) throws Throwable { + if (args.length > target.type().parameterCount()) return uncurry(target, args); + return insertArguments(target, 0, args); + } + + public static boolean arityCheck(int arity, MethodHandle target) throws Throwable { + return target.type().parameterCount() == arity; + } + + static CallSite applyCallSite(MethodType type) { + MethodHandle apply = invoker(type.dropParameterTypes(0, 1)); + MethodHandle test = insertArguments(arityCheck, 0, type.parameterCount() - 1); + return new ConstantCallSite(guardWithTest(test, apply, partial.asType(type)).asType(type)); + } + + static MethodHandle mh(Class aClass, String name, Class... types) { + try { + return lookup.unreflect(Shen.find(stream(aClass.getMethods()), m -> m.getName().equals(name) + && (types.length == 0 || deepEquals(m.getParameterTypes(), types)))); + } catch (IllegalAccessException e) { + throw Shen.uncheck(e); + } + } + + static MethodHandle field(Class aClass, String name) { + try { + return lookup.unreflectGetter(aClass.getField(name)); + } catch (Exception e) { + throw Shen.uncheck(e); + } + } + + static boolean canCast(Class a, Class b) { + return a == Object.class || b == Object.class || canCastStrict(a, b); + } + + static boolean canCastStrict(Class a, Class b) { + return a == b || b.isAssignableFrom(a) || canWiden(a, b); + } + + static boolean canWiden(Class a, Class b) { + return wrapper(b).isNumeric() && wrapper(b).isConvertibleFrom(wrapper(a)); + } + + static Wrapper wrapper(Class type) { + if (isPrimitiveType(type)) return forPrimitiveType(type); + if (isWrapperType(type)) return forWrapperType(type); + return forBasicType(type); + } + + public static Symbol defun(Symbol name, MethodHandle fn) throws Throwable { + if (overrides.contains(name)) return name; + synchronized (name.symbol) { + SwitchPoint guard = name.fnGuard; + name.fn.clear(); + name.fn.add(fn); + if (guard != null) { + name.fnGuard = new SwitchPoint(); + invalidateAll(new SwitchPoint[]{guard}); + } + return name; + } + } + + static void register(Class aClass, Consumer hook) { + stream(aClass.getDeclaredMethods()).filter(m -> isPublic(m.getModifiers())).forEach(hook); + } + + static void override(Method m) { + overrides.add(defun(m)); + } + + static Symbol defun(Method m) { + try { + Symbol name = Primitives.intern(unscramble(m.getName())); + name.fn.add(lookup.unreflect(m)); + return name; + } catch (IllegalAccessException e) { + throw Shen.uncheck(e); + } + } + + static Object uncurry(Object chain, Object... args) throws Throwable { + for (Object arg : args) + chain = ((MethodHandle) chain).invokeExact(arg); + return chain; + } + + public static MethodHandle bindTo(MethodHandle fn, Object arg) { + return insertArguments(fn, 0, arg); + } + + static String unscramble(String s) { + return toSourceName(s).replaceAll("_", "-").replaceAll("^KL-", "").replaceAll("GT", ">").replaceAll("EQ", "=") + .replaceAll("LT", "<").replaceAll("EX$", "!").replaceAll("P$", "?").replaceAll("^AT", "@"); + } + + static MethodHandle findSAM(Object lambda) { + try { + return lookup.unreflect(findSAM(lambda.getClass())).bindTo(lambda); + } catch (IllegalAccessException e) { + throw Shen.uncheck(e); + } + } + + static Method findSAM(Class lambda) { + List methods = Shen.vec(stream(lambda.getDeclaredMethods()).filter(m -> !m.isSynthetic())); + return methods.size() == 1 ? methods.get(0) : null; + } + + static boolean isSAM(Class aClass) { + return findSAM(aClass) != null; + } +} \ No newline at end of file diff --git a/src/shen/Shen.java b/src/shen/Shen.java index 9bed24d..a5342df 100755 --- a/src/shen/Shen.java +++ b/src/shen/Shen.java @@ -1,20 +1,8 @@ package shen; -import jdk.internal.org.objectweb.asm.*; -import jdk.internal.org.objectweb.asm.commons.GeneratorAdapter; -import jdk.internal.org.objectweb.asm.tree.ClassNode; -import jdk.internal.org.objectweb.asm.util.ASMifier; -import jdk.internal.org.objectweb.asm.util.TraceClassVisitor; -import sun.invoke.anon.AnonymousClassLoader; -import sun.invoke.util.Wrapper; -import sun.misc.Unsafe; - import java.io.*; import java.lang.invoke.*; -import java.lang.reflect.Constructor; -import java.lang.reflect.Executable; -import java.lang.reflect.Field; -import java.lang.reflect.Method; +import java.nio.charset.Charset; import java.util.*; import java.util.ArrayList; import java.util.concurrent.Callable; @@ -23,47 +11,17 @@ import java.util.stream.Collector; import java.util.stream.Collectors; import java.util.stream.Stream; -import java.util.stream.StreamSupport; -import static java.lang.Character.isUpperCase; import static java.lang.ClassLoader.getSystemClassLoader; -import static java.lang.Double.*; -import static java.lang.Math.floorMod; -import static java.lang.Math.toIntExact; +import static java.lang.ClassLoader.getSystemResources; import static java.lang.String.format; import static java.lang.System.*; -import static java.lang.invoke.MethodHandleProxies.asInterfaceInstance; -import static java.lang.invoke.MethodHandles.*; -import static java.lang.invoke.MethodHandles.lookup; -import static java.lang.invoke.MethodType.genericMethodType; -import static java.lang.invoke.MethodType.methodType; -import static java.lang.invoke.SwitchPoint.invalidateAll; -import static java.lang.reflect.Modifier.isPublic; import static java.util.Arrays.*; -import static java.util.Arrays.fill; -import static java.util.Arrays.stream; import static java.util.Collections.*; -import static java.util.Objects.deepEquals; -import static java.util.function.Predicate.*; +import static java.util.function.Predicate.isEqual; import static java.util.jar.Attributes.Name.IMPLEMENTATION_VERSION; import static java.util.stream.Collectors.toSet; -import static java.util.stream.Stream.empty; -//import static java.util.stream.Streams.*; -import static jdk.internal.org.objectweb.asm.ClassReader.SKIP_DEBUG; -import static jdk.internal.org.objectweb.asm.ClassWriter.COMPUTE_FRAMES; -import static jdk.internal.org.objectweb.asm.Type.*; -import static jdk.internal.org.objectweb.asm.commons.GeneratorAdapter.*; -import static shen.Shen.Compiler.*; -import static shen.Shen.Cons.toCons; -import static shen.Shen.KLReader.lines; -import static shen.Shen.KLReader.read; -import static shen.Shen.Numbers.*; -import static shen.Shen.Primitives.*; -import static shen.Shen.RT.*; -import static shen.Shen.RT.lookup; -import static sun.invoke.util.BytecodeName.toBytecodeName; -import static sun.invoke.util.BytecodeName.toSourceName; -import static sun.invoke.util.Wrapper.*; +import static java.util.stream.Stream.concat; @SuppressWarnings({"UnusedDeclaration", "Convert2Diamond"}) public class Shen { @@ -75,564 +33,29 @@ public static void main(String... args) throws Throwable { static final Map symbols = new HashMap<>(); static { - set("*language*", "Java"); - set("*implementation*", format("%s (build %s)", getProperty("java.runtime.name"), getProperty("java.runtime.version"))); - set("*porters*", "Håkan Råberg"); - set("*port*", version()); - set("*stinput*", in); - set("*stoutput*", out); - set("*debug*", Boolean.getBoolean("shen.debug")); - set("*debug-asm*", Boolean.getBoolean("shen.debug.asm")); - set("*compile-path*", getProperty("shen.compile.path", "target/classes")); - set("*home-directory*", getProperty("user.dir")); - - register(Primitives.class, RT::defun); - register(Overrides.class, RT::override); + Primitives.set("*language*", "Java"); + Primitives.set("*implementation*", format("%s (build %s)", getProperty("java.runtime.name"), getProperty("java.runtime.version"))); + Primitives.set("*porters*", new String("Håkan Råberg".getBytes(), Charset.forName("ISO-8859-1"))); + Primitives.set("*port*", version()); + Primitives.set("*stinput*", in); + Primitives.set("*stoutput*", out); + Primitives.set("*debug*", Boolean.getBoolean("shen.debug")); + Primitives.set("*debug-asm*", Boolean.getBoolean("shen.debug.asm")); + Primitives.set("*compile-path*", getProperty("shen.compile.path", "target/classes")); + Primitives.set("*home-directory*", getProperty("user.dir")); + + RT.register(Primitives.class, RT::defun); + RT.register(Overrides.class, RT::override); asList(Math.class, System.class).forEach(Primitives::KL_import); } - interface LLPredicate { boolean test(long a, long b); } - interface Invokable { MethodHandle invoker() throws Exception; } - - public static class Numbers implements Opcodes { - static final long tag = 1, real = 0, integer = 1; - static final Set operators = new HashSet<>(); - - // longs are either 63 bit signed integers or doubleToLongBits with bit 0 used as tag, 0 = double, 1 = long. - // Java: 5ms, Shen.java: 10ms, Boxed Java: 15ms. Which ever branch that starts will be faster for some reason. - static { - ClassWriter cw = new ClassWriter(ClassWriter.COMPUTE_FRAMES); - cw.visit(V1_7, ACC_PUBLIC | ACC_FINAL, "shen/Shen$Operators", null, getInternalName(Object.class), null); - - binaryOp(cw, "+", ADD); - binaryOp(cw, "-", SUB); - binaryOp(cw, "*", MUL); - binaryOp(cw, "/", realOp(DIV), integerDivision()); - binaryOp(cw, "%", REM); - binaryComp(cw, "<", LT); - binaryComp(cw, "<=", LE); - binaryComp(cw, ">", GT); - binaryComp(cw, ">=", GE); - - register(loader.loadClass(cw.toByteArray()), Numbers::op); - } - - static Consumer integerOp(int op) { - return mv -> toInteger(mv, op); - } - - static Consumer realOp(int op) { - return mv -> toReal(mv, op); - } - - static Consumer integerDivision() { - return mv -> { - Label notZero = new Label(); - mv.dup2(); - mv.visitInsn(L2I); - mv.ifZCmp(IFNE, notZero); - mv.newInstance(getType(ArithmeticException.class)); - mv.dup(); - mv.push("Division by zero"); - mv.invokeConstructor(getType(ArithmeticException.class), method("", desc(void.class, String.class))); - mv.throwException(); - mv.visitLabel(notZero); - mv.visitInsn(L2D); - mv.swap(DOUBLE_TYPE, LONG_TYPE); - mv.visitInsn(L2D); - mv.swap(DOUBLE_TYPE, DOUBLE_TYPE); - toReal(mv, DIV); - }; - } - - static void toInteger(GeneratorAdapter mv, int op) { - mv.math(op, LONG_TYPE); - mv.push((int) tag); - mv.visitInsn(LSHL); - mv.push(integer); - mv.visitInsn(LOR); - } - - static void toReal(GeneratorAdapter mv, int op) { - mv.math(op, DOUBLE_TYPE); - mv.invokeStatic(getType(Double.class), method("doubleToRawLongBits", desc(long.class, double.class))); - mv.push(~integer); - mv.visitInsn(LAND); - } - - static void binaryComp(ClassWriter cw, String op, int test) { - binaryOp(cw, op, boolean.class, comparison(DOUBLE_TYPE, test), comparison(LONG_TYPE, test)); - } - - static Consumer comparison(Type type, int test) { - return mv -> { - Label _else = new Label(); - mv.ifCmp(type, test, _else); - mv.push(false); - mv.returnValue(); - mv.visitLabel(_else); - mv.push(true); - mv.returnValue(); - }; - } - - static void binaryOp(ClassWriter cw, String op, int instruction) { - binaryOp(cw, op, long.class, realOp(instruction), integerOp(instruction)); - } - - static void binaryOp(ClassWriter cw, String op, Consumer realOp, Consumer integerOp) { - binaryOp(cw, op, long.class, realOp, integerOp); - } - - static void binaryOp(ClassWriter cw, String op, Class returnType, Consumer realOp, - Consumer integerOp) { - GeneratorAdapter mv = new GeneratorAdapter(ACC_PUBLIC + ACC_STATIC, - method(toBytecodeName(op), desc(returnType, long.class, long.class)), null, null, cw); - - isInteger(mv, 0); - Label argOneIsLong = new Label(); - mv.ifZCmp(IFNE, argOneIsLong); - asDouble(mv, 0); - isInteger(mv, 1); - Label argTwoIsLong = new Label(); - mv.ifZCmp(IFNE, argTwoIsLong); - asDouble(mv, 1); - Label doubleOperation = new Label(); - mv.goTo(doubleOperation); - mv.visitLabel(argTwoIsLong); - asLong(mv, 1); - mv.visitInsn(L2D); - mv.goTo(doubleOperation); - mv.visitLabel(argOneIsLong); - isInteger(mv, 1); - Label longOperation = new Label(); - mv.ifZCmp(IFNE, longOperation); - asLong(mv, 0); - mv.visitInsn(L2D); - asDouble(mv, 1); - mv.visitLabel(doubleOperation); - realOp.accept(mv); - mv.returnValue(); - mv.visitLabel(longOperation); - asLong(mv, 0); - asLong(mv, 1); - integerOp.accept(mv); - mv.returnValue(); - mv.endMethod(); - } - - static void asDouble(GeneratorAdapter mv, int arg) { - mv.loadArg(arg); - mv.invokeStatic(getType(Double.class), method("longBitsToDouble", desc(double.class, long.class))); - } - - static void asLong(GeneratorAdapter mv, int arg) { - mv.loadArg(arg); - mv.push((int) tag); - mv.visitInsn(LSHR); - } - - static void isInteger(GeneratorAdapter mv, int arg) { - mv.loadArg(arg); - mv.visitInsn(L2I); - mv.push((int) tag); - mv.visitInsn(IAND); - } - - static void op(Method op) { - try { - Symbol symbol = intern(toSourceName(op.getName())); - symbol.fn.add(lookup.unreflect(op)); - operators.add(symbol); - } catch (IllegalAccessException e) { - throw uncheck(e); - } - } - - static Object maybeNumber(Object o) { - return o instanceof Long ? asNumber((Long) o) : o; - } - - public static long number(Number n) { - return n instanceof Double ? real(n.doubleValue()) : integer(n.longValue()); - } - - static long real(double d) { - return ~tag & doubleToLongBits(d); - } - - static long integer(long l) { - return l << tag | tag; - } - - static double asDouble(long l) { - return isInteger(l) ? l >> tag : longBitsToDouble(l); - } - - public static int asInt(long l) { - return toIntExact(asNumber(l).longValue()); - } - - public static Number asNumber(long fp) { //noinspection RedundantCast - return isInteger(fp) ? (Number) (fp >> tag) : (Number) longBitsToDouble(fp); - } - - static boolean isInteger(long l) { - return (tag & l) == integer; - } - } - - public final static class Symbol implements Invokable { - public final String symbol; - public List fn = new ArrayList<>(); - public SwitchPoint fnGuard; - public Object var; - public Collection source; - - Symbol(String symbol) { - this.symbol = symbol.intern(); - } - - public String toString() { - return symbol; - } - - public T value() { - if (var == null) throw new IllegalArgumentException("variable " + this + " has no value"); - //noinspection unchecked - return (T) var; - } - - public boolean equals(Object o) { //noinspection StringEquality - return o instanceof Symbol && symbol == ((Symbol) o).symbol; - } - - public int hashCode() { - return symbol.hashCode(); - } - - public MethodHandle invoker() throws IllegalAccessException { - if (fn.isEmpty()) return reLinker(symbol, 0); - MethodHandle mh = fn.get(0); - if (fn.size() > 1) return reLinker(symbol, mh.type().parameterCount()); - return mh; - } - } - - public final static class Cons extends AbstractCollection { - public final Object car, cdr; - public final int size; - - public Cons(Object car, Object cdr) { - this.car = car; - this.cdr = cdr; - this.size = cdr instanceof Cons ? 1 + (((Cons) cdr).size) : EMPTY_LIST.equals(cdr) ? 1 : 2; - } - - public boolean equals(Object o) { - if (this == o) return true; - if (o instanceof List && isList()) //noinspection unchecked - return vec(toList().stream().map(Numbers::maybeNumber)).equals(o); - if (o == null || getClass() != o.getClass()) return false; - //noinspection ConstantConditions - Cons cons = (Cons) o; - return EQ(car, cons.car) && cdr.equals(cons.cdr); - } - - boolean isList() { - return cdr instanceof Cons || EMPTY_LIST.equals(cdr); - } - - public int hashCode() { - return 31 * car.hashCode() + cdr.hashCode(); - } - - @SuppressWarnings("NullableProblems") - public Iterator iterator() { - if (!isList()) throw new IllegalStateException("cons pair is not a list: " + this); - return new ConsIterator(); - } - - public int size() { - return size; - } - - public String toString() { - if (isList()) return vec(toList().stream().map(Numbers::maybeNumber)).toString(); - return "[" + maybeNumber(car) + " | " + maybeNumber(cdr) + "]"; - } - - public List toList() { - return new ArrayList(this); - } - - public static Collection toCons(List list) { - if (list.isEmpty()) return list; - Cons cons = null; - list = new ArrayList<>(list); - reverse(list); - for (Object o : list) { - if (o instanceof List) o = toCons((List) o); - if (cons == null) cons = new Cons(o, EMPTY_LIST); - else cons = new Cons(o, cons); - } - return cons; - } - - class ConsIterator implements Iterator { - Cons cons = Cons.this; - - public boolean hasNext() { - return cons != null; - } - - public Object next() { - if (cons == null) throw new NoSuchElementException(); - try { - if (!cons.isList()) return cons; - return cons.car; - } finally { - cons =!cons.isList() || EMPTY_LIST.equals(cons.cdr) ? null : (Cons) cons.cdr; - } - } - } - } - - public static final class Primitives { - public static boolean EQ(Object left, Object right) { - if (Objects.equals(left, right)) return true; - if (absvectorP(left) && absvectorP(right)) { - Object[] leftA = (Object[]) left; - Object[] rightA = (Object[]) right; - if (leftA.length != rightA.length) return false; - for (int i = 0; i < leftA.length; i++) - if (!EQ(leftA[i], rightA[i])) - return false; - return true; - } - if (numberP(left) && numberP(right)) { - long a = (Long) left; - long b = (Long) right; - return (tag & a) == integer && (tag & b) == integer ? a == b : asDouble(a) == asDouble(b); - } - return false; - } - - public static Class KL_import(Symbol s) throws ClassNotFoundException { - Class aClass = Class.forName(s.symbol); - return set(intern(aClass.getSimpleName()), aClass); - } - - static Class KL_import(Class type) { - try { - return KL_import(intern(type.getName())); - } catch (ClassNotFoundException e) { - throw uncheck(e); - } - } - - public static Cons cons(Object x, Object y) { - return new Cons(x, y); - } - - public static boolean consP(Object x) { - return x instanceof Cons; - } - - public static Object simple_error(String s) { - throw new RuntimeException(s, null, false, false) {}; - } - - public static String error_to_string(Throwable e) { - return e.getMessage() == null ? e.toString() : e.getMessage(); - } - - public static Object hd(Cons cons) { - return cons.car; - } - - public static Object tl(Cons cons) { - return cons.cdr; - } - - public static String str(Object x) { - if (consP(x)) throw new IllegalArgumentException(x + " is not an atom; str cannot convert it to a string."); - if (x != null && x.getClass().isArray()) return deepToString((Object[]) x); - if (x instanceof Long) x = asNumber((Long) x); - return String.valueOf(x); - } - - public static String pos(String x, long n) { - return str(x.charAt((int) (n >> tag))); - } - - public static String tlstr(String x) { - return x.substring(1); - } - - public static Class type(Object x) { - return x.getClass(); - } - - public static Object[] absvector(long n) { - Object[] objects = new Object[(int) (n >> tag)]; - fill(objects, intern("fail!")); - return objects; - } - - public static boolean absvectorP(Object x) { - return x.getClass() == Object[].class; - } - - public static Object LT_address(Object[] vector, long n) { - return vector[((int) (n >> tag))]; - } - - public static Object[] address_GT(Object[] vector, long n, Object value) { - vector[((int) (n >> tag))] = value; - return vector; - } - - public static boolean numberP(Object x) { - return x instanceof Long; - } - - public static boolean stringP(Object x) { - return x instanceof String; - } - - public static String n_GTstring(long n) { - if (n >> tag < 0) throw new IllegalArgumentException(n + " is not a valid character"); - return Character.toString((char) (n >> tag)); - } - - public static String byte_GTstring(long n) { - return n_GTstring(n >> tag); - } - - public static long string_GTn(String s) { - return integer((int) s.charAt(0)); - } - - public static long read_byte(InputStream s) throws IOException { - return integer(s.read()); - } - - public static Long convertToLong(Object x) { - if (x instanceof Long) x = asNumber((Long) x); - return Long.valueOf((Long) x); - } - - public static T write_byte(T x, OutputStream s) throws IOException { - s.write(convertToLong(x).byteValue()); - s.flush(); - return x; - } - - public static Closeable open(String string, Symbol direction) throws IOException { - File file = new File(string); - if (!file.isAbsolute()) { - //noinspection RedundantCast - file = new File((String) intern("*home-directory*").value(), string); - } - - switch (direction.symbol) { - case "in": return new BufferedInputStream(new FileInputStream(file)); - case "out": return new BufferedOutputStream(new FileOutputStream(file)); - } - throw new IllegalArgumentException("invalid direction"); - } - - public static Object close(Closeable stream) throws IOException { - stream.close(); - return EMPTY_LIST; - } - - static long startTime = System.currentTimeMillis(); - public static long get_time(Symbol time) { - switch (time.symbol) { - case "run": return real((currentTimeMillis() - startTime) / 1000.0); - case "unix": return integer(currentTimeMillis() / 1000); - } - throw new IllegalArgumentException("get-time does not understand the parameter " + time); - } - - public static String cn(String s1, String s2) { - return s1 + s2; - } - - public static Symbol intern(String name) { - return symbols.computeIfAbsent(name, Symbol::new); - } - - public static T value(Symbol x) { - return x.value(); - } - - @SuppressWarnings("unchecked") - public static T set(Symbol x, T y) { - return (T) (x.var = y); - } - - static T set(String x, T y) { - return set(intern(x), y); - } - - public static MethodHandle function(Invokable x) throws Exception { - return x.invoker(); - } - - static MethodHandle function(String x) throws Exception { - return function(intern(x)); - } - - public static Object eval_kl(Object kl) throws Throwable { - return new Compiler(kl).load("__eval__", Callable.class).newInstance().call(); - } - - public static boolean or(boolean x, boolean y) { - return x || y; - } - - public static boolean and(boolean x, boolean y) { - return x && y; - } + interface LLPredicate { + boolean test(long a, long b); } - public static final class Overrides { - static final Symbol _true = intern("true"), _false = intern("false"), shen_tuple = intern("shen.tuple"); - - public static boolean variableP(Object x) { - return x instanceof Symbol && isUpperCase(((Symbol) x).symbol.charAt(0)); - } - - public static boolean booleanP(Object x) { - return x instanceof Boolean || _true == x || _false == x; - } - - public static boolean symbolP(Object x) { - return x instanceof Symbol && !booleanP(x); - } - - public static long length(Collection x) { - return integer(x.size()); - } - - public static Object[] ATp(Object x, Object y) { - return new Object[] {shen_tuple, x, y}; - } - - public static long hash(Object s, long limit) { - long hash = s.hashCode(); - if (hash == 0) return 1; - return integer(floorMod(hash, limit >> tag)); - } - - public static Object[] shen_fillvector(Object[] vector, long counter, long n, Object x) { - fill(vector, (int) (counter >> tag), (int) (n >> tag) + 1, x); - return vector; - } + interface Invokable { + MethodHandle invoker() throws Exception; } static boolean isDebug() { @@ -640,25 +63,24 @@ static boolean isDebug() { } static boolean booleanProperty(String property) { - return intern(property).var == Boolean.TRUE; + return Primitives.intern(property).var == Boolean.TRUE; } public static Object eval(String kl) throws Throwable { - return eval_kl(read(new StringReader(kl)).get(0)); + return Primitives.eval_kl(KLReader.read(new StringReader(kl)).get(0)); } static void install() throws Throwable { readTypes(); - set("shen-*installing-kl*", true); + Primitives.set("shen-*installing-kl*", true); for (String file : asList("toplevel", "core", "sys", "sequent", "yacc", "reader", "prolog", "track", "load", "writer", "macros", "declarations", "types", "t-star")) load("klambda/" + file, Callable.class).newInstance().call(); - //Loading custom klambda files for (String file : asList("types")) - load("klambda-custom/" + file, Callable.class).newInstance().call(); - set("shen-*installing-kl*", false); - set("*home-directory*", getProperty("user.dir")); //Resetting it because it gets overwritten in declarations.kl - builtins.addAll(vec(symbols.values().stream().filter(s -> !s.fn.isEmpty()))); + load("klambda-custom/" + file, Callable.class).newInstance().call(); + Primitives.set("shen-*installing-kl*", false); + Primitives.set("*home-directory*", getProperty("user.dir")); //Resetting it because it gets overwritten in declarations.kl + RT.builtins.addAll(vec(symbols.values().stream().filter(s -> !s.fn.isEmpty()))); } static void readTypes() throws Throwable { @@ -666,14 +88,14 @@ static void readTypes() throws Throwable { getSystemClassLoader().loadClass("klambda.types"); } catch (ClassNotFoundException ignored) { try (Reader in = resource("klambda/types.kl")) { - List declarations = vec(read(in).stream().filter(List.class::isInstance) - .filter(c -> ((List) c).get(0).equals(intern("declare")))); + List declarations = vec(KLReader.read(in).stream().filter(List.class::isInstance) + .filter(c -> ((List) c).get(0).equals(Primitives.intern("declare")))); for (Object declaration : declarations) { List list = (List) declaration; Symbol symbol = (Symbol) list.get(1); - if (!tooStrictTypes.contains(symbol)) + if (!RT.tooStrictTypes.contains(symbol)) //noinspection unchecked - typesForInstallation.put(symbol, typeSignature(symbol, shenTypeSignature(((Cons) eval_kl(list.get(2))).toList()))); + RT.typesForInstallation.put(symbol, RT.typeSignature(symbol, RT.shenTypeSignature(((Cons) Primitives.eval_kl(list.get(2))).toList()))); } } } @@ -692,15 +114,16 @@ static Class load(String file, Class aClass) throws Throwable { static Class compile(String file, Class aClass) throws Throwable { try (Reader in = resource(format("%s.kl", file))) { debug("loading: %s", file); - Compiler compiler = new Compiler(null, file, cons(intern("do"), read(in))); + Compiler compiler = new Compiler(null, file, cons(Primitives.intern("do"), KLReader.read(in))); //noinspection RedundantCast - File compilePath = new File((String) intern("*compile-path*").value()); + File compilePath = new File((String) Primitives.intern("*compile-path*").value()); File classFile = new File(compilePath, file + ".class"); - if (!(compilePath.mkdirs() || compilePath.isDirectory())) throw new IOException("could not make directory: " + compilePath); + if (!(compilePath.mkdirs() || compilePath.isDirectory())) + throw new IOException("could not make directory: " + compilePath); try { return compiler.load(classFile.getName().replaceAll(".class$", ".kl"), aClass); } finally { - lines.clear(); + KLReader.lines.clear(); if (compiler.bytes != null) try (OutputStream out = new FileOutputStream(classFile)) { out.write(compiler.bytes); @@ -714,1233 +137,80 @@ static Reader resource(String resource) { } static String version() { - String version = null; - try (InputStream manifest = getSystemClassLoader().getResourceAsStream("META-INF/MANIFEST.MF")) { - version = new Manifest(manifest).getMainAttributes().getValue(IMPLEMENTATION_VERSION); - } catch (IOException ignored) { + try (InputStream manifest = find(Collections.list(getSystemResources("META-INF/MANIFEST.MF")).stream(), + u -> u.getPath().matches(".*shen.java.*?.jar!.*")).openStream()) { + return new Manifest(manifest).getMainAttributes().getValue(IMPLEMENTATION_VERSION); + } catch (IOException | NullPointerException ignored) { } - return version != null ? version : ""; + return ""; } - public static class KLReader { - static Map lines = new IdentityHashMap<>(); - static int currentLine; - - static List read(Reader reader) throws Exception { - lines.clear(); - currentLine = 1; - return tokenizeAll(new Scanner(reader).useDelimiter("(\\s|\\)|\")")); - } + static void debug(String format, Object... args) { + if (isDebug()) err.println(format(format, + stream(args).map(o -> o != null && o.getClass() == Object[].class + ? deepToString((Object[]) o) : o).toArray())); + } - static Object tokenize(Scanner sc) throws Exception { - whitespace(sc); - if (find(sc, "\\(")) return tokenizeAll(sc); - if (find(sc, "\"")) return nextString(sc); - if (find(sc, "\\)")) return null; - if (sc.hasNextBoolean()) return sc.nextBoolean(); - if (sc.hasNextLong()) return integer(sc.nextLong()); - if (sc.hasNextDouble()) return real(sc.nextDouble()); - if (sc.hasNext()) return intern(sc.next()); - return null; - } + @SafeVarargs + static List list(T... items) { + return new ArrayList<>(asList(items)); + } - static void whitespace(Scanner sc) { - sc.skip("[^\\S\\n]*"); - while (find(sc, "\\n")) { - currentLine++; - sc.skip("[^\\S\\n]*"); - } - } + @SuppressWarnings("unchecked") + static List vec(Stream coll) { + return new ArrayList<>(coll.collect(Collectors.toList())); + } - static boolean find(Scanner sc, String pattern) { - return sc.findWithinHorizon(pattern, 1) != null; - } + static T find(Stream coll, Predicate pred) { + return coll.filter(pred).findFirst().orElse(null); + } - static Object nextString(Scanner sc) throws IOException { - String s = sc.findWithinHorizon("(?s).*?\"", 0); - currentLine += s.replaceAll("[^\n]", "").length(); - return s.substring(0, s.length() - 1); - } + static R some(Stream coll, Function pred) { + return coll.map(pred).filter(isEqual(true).or(Objects::nonNull)).findFirst().orElse(null); + } - static List tokenizeAll(Scanner sc) throws Exception { - List list = list(); - lines.put(list, currentLine); - Object x; - while ((x = tokenize(sc)) != null) list.add(x); - return list; - } + static > C into(C to, Collection from) { + Collector> collector = to instanceof Set ? toSet() : Collectors.toList(); + //noinspection unchecked + return (C) concat(to.stream(), from.stream()).collect(collector); } - public static class RT { - static final Lookup lookup = lookup(); - static final Set overrides = new HashSet<>(); - static final Set builtins = new HashSet<>(); - static final Map typesForInstallation = new HashMap<>(); - static final Map sites = new HashMap<>(); - static final Map guards = new HashMap<>(); + static > C conj(C coll, Object x) { //noinspection unchecked + return into(coll, singleton((T) x)); + } - static final MethodHandle - link = mh(RT.class, "link"), proxy = mh(RT.class, "proxy"), - checkClass = mh(RT.class, "checkClass"), toIntExact = mh(Math.class, "toIntExact"), - asNumber = mh(Numbers.class, "asNumber"), number = mh(Numbers.class, "number"), - asInt = mh(Numbers.class, "asInt"), toList = mh(Cons.class, "toList"), - partial = mh(RT.class, "partial"), arityCheck = mh(RT.class, "arityCheck"); + static List cons(T x, List seq) { + return into(singletonList(x), seq); + } - public static Object link(MutableCallSite site, String name, Object... args) throws Throwable { - name = toSourceName(name); - MethodType type = site.type(); - debug("LINKING: %s%s %s", name, type, vec(stream(args).map(Numbers::maybeNumber))); - List> actualTypes = vec(stream(args).map(Object::getClass)); - debug("actual types: %s", actualTypes); - Symbol symbol = intern(name); - debug("candidates: %s", symbol.fn); + static Stream map(Stream c1, Stream c2, BiFunction f) { + Iterator it1 = c1.iterator(); + Iterator it2 = c2.iterator(); + List result = new ArrayList(); + while (it1.hasNext() && it2.hasNext()) { + result.add(f.apply(it1.next(), it2.next())); + } + return result.stream(); + } - if (symbol.fn.isEmpty()) { - MethodHandle java = javaCall(site, name, type, args); - if (java != null) { - debug("calling java: %s", java); - site.setTarget(java.asType(type)); - return java.invokeWithArguments(args); - } - throw new NoSuchMethodException("undefined function " + name + type - + (symbol.fn.isEmpty() ? "" : " in " + vec(symbol.fn.stream().map(MethodHandle::type)))); - } + static boolean every(Collection c1, Collection c2, BiPredicate pred) { + return map(c1.stream(), c2.stream(), pred::test).allMatch(isEqual(true)); + } - int arity = symbol.fn.get(0).type().parameterCount(); - if (arity > args.length) { - MethodHandle partial = insertArguments(reLinker(name, arity), 0, args); - debug("partial: %s", partial); - return partial; - } + static T find(Collection c1, Collection c2, BiPredicate pred) { + return find(map(c1.stream(), c2.stream(), (x, y) -> pred.test(x, y) ? x : null), Objects::nonNull); + } - MethodHandle match = find(symbol.fn.stream(), f -> every(actualTypes, f.type().parameterList(), RT::canCastStrict)); - if (match == null) throw new NoSuchMethodException("undefined function " + name + type); - debug("match based on argument types: %s", match); + static List rest(List coll) { + return coll.isEmpty() ? coll : coll.subList(1, coll.size()); + } - MethodHandle fallback = linker(site, toBytecodeName(name)).asType(type); - if (symbol.fn.size() > 1 && !match.type().parameterList().stream().allMatch(isEqual(long.class))) { - match = guards.computeIfAbsent(asList(type, symbol.fn), key -> guard(type, symbol.fn)); - debug("selected: %s", match); - } + static RuntimeException uncheck(Throwable t) { + return uncheckAndThrow(t); + } - synchronized (symbol.symbol) { - if (symbol.fnGuard == null) symbol.fnGuard = new SwitchPoint(); - site.setTarget(symbol.fnGuard.guardWithTest(match.asType(type), fallback)); - } - Object result = match.invokeWithArguments(args); - maybeRecompile(type, symbol, result == null ? Object.class : result.getClass()); - return result; - } + static T uncheckAndThrow(Throwable t) throws T { //noinspection unchecked + throw (T) t; + } +} - static void maybeRecompile(MethodType type, Symbol symbol, Class returnType) throws Throwable { - if (symbol.source == null || booleanProperty("shen-*installing-kl*")) return; - MethodType signature = typeSignature(symbol); - type = signature != null ? signature : type.changeReturnType(isWrapperType(returnType) ? wrapper(returnType).primitiveType() - : isPrimitiveType(returnType) ? returnType : Object.class); - if ((signature != null || (type.changeReturnType(Object.class).hasPrimitives() && !builtins.contains(symbol)))) - recompile(type, symbol); - } - - static void recompile(MethodType type, Symbol symbol) throws Throwable { - if (symbol.source == null || symbol.fn.stream().map(MethodHandle::type).anyMatch(isEqual(type))) return; - debug("recompiling as %s: %s", type, symbol.source); - List fn = new ArrayList<>(symbol.fn); - try { - typeHint.set(type); - eval_kl(symbol.source); - } finally { - typeHint.remove(); - symbol.fn.addAll(fn); - if (!type.returnType().equals(Object.class)) - symbol.fn.removeIf(f -> f.type().equals(type.changeReturnType(Object.class))); - } - } - - static final Map types = new HashMap<>(); - static { - types.put(intern("symbol"), Symbol.class); - types.put(intern("number"), long.class); - types.put(intern("boolean"), boolean.class); - types.put(intern("string"), String.class); - types.put(intern("exception"), Exception.class); - types.put(intern("list"), Iterable.class); - types.put(intern("vector"), Object[].class); - } - - static Set tooStrictTypes = new HashSet<>(asList(intern("concat"), intern("fail-if"), - intern("tail"), intern("systemf"))); - - static MethodType typeSignature(Symbol symbol) throws Throwable { - if (tooStrictTypes.contains(symbol) || !hasKnownSignature(symbol)) return null; - return typeSignature(symbol, shenTypeSignature(symbol)); - } - - static MethodType typeSignature(Symbol symbol, List shenTypes) { - List> javaTypes = new ArrayList<>(); - for (Object argumentType : shenTypes) { - if (argumentType instanceof Cons) - argumentType = ((Cons) argumentType).car; - javaTypes.add(types.containsKey(argumentType) ? types.get(argumentType) : - argumentType instanceof Class ? (Class) argumentType : Object.class); - } - MethodType type = methodType(javaTypes.remove(javaTypes.size() - 1), javaTypes); - debug("%s has Shen type signature: %s mapped to Java %s", symbol, shenTypes, type); - return type; - } - - static boolean hasKnownSignature(Symbol symbol) { - return intern("shen.*signedfuncs*").var instanceof Cons && ((Cons) intern("shen.*signedfuncs*").var).contains(symbol); - } - - static List shenTypeSignature(Symbol symbol) throws Throwable { - return shenTypeSignature(((Cons) eval(format("(shen-typecheck %s (gensym A))", symbol))).toList()); - } - - static List shenTypeSignature(List signature) { - if (signature.size() != 3) - return vec(signature.stream().filter(isEqual(intern("-->")).negate())); - List argumentTypes = new ArrayList<>(); - for (; signature.size() == 3; signature = ((Cons) signature.get(2)).toList()) { - argumentTypes.add(signature.get(0)); - if (!(signature.get(2) instanceof Cons) || signature.get(2) instanceof Cons - && !((Cons) signature.get(2)).contains(intern("-->"))) { - argumentTypes.add(signature.get(2)); - break; - } - } - return argumentTypes; - } - - static MethodHandle guard(MethodType type, List candidates) { - candidates = bestMatchingMethods(type, candidates); - debug("applicable candidates: %s", candidates); - MethodHandle match = candidates.get(candidates.size() - 1).asType(type); - for (int i = candidates.size() - 1; i > 0; i--) { - MethodHandle fallback = candidates.get(i); - MethodHandle target = candidates.get(i - 1); - Class differentType = find(target.type().parameterList(), fallback.type().parameterList(), (x, y) -> !x.equals(y)); - int firstDifferent = target.type().parameterList().indexOf(differentType); - debug("switching on %d argument type %s", firstDifferent, differentType); - debug("target: %s ; fallback: %s", target, fallback); - MethodHandle test = checkClass.bindTo(differentType); - test = dropArguments(test, 0, type.dropParameterTypes(firstDifferent, type.parameterCount()).parameterList()); - test = test.asType(test.type().changeParameterType(firstDifferent, type.parameterType(firstDifferent))); - match = guardWithTest(test, target.asType(type), match); - } - return match; - } - - static List bestMatchingMethods(MethodType type, List candidates) { - return vec(candidates.stream() - .filter(f -> every(type.parameterList(), f.type().parameterList(), RT::canCast)) - .sorted((x, y) -> y.type().changeReturnType(type.returnType()).equals(y.type().erase()) ? -1 : 1) - .sorted((x, y) -> every(y.type().parameterList(), x.type().parameterList(), RT::canCast) ? -1 : 1)); - } - - public static boolean checkClass(Class xClass, Object x) { - return canCastStrict(x.getClass(), xClass); - } - - static MethodHandle relinkOn(Class exception, MethodHandle fn, MethodHandle fallback) { - return catchException(fn.asType(fallback.type()), exception, dropArguments(fallback, 0, Exception.class)); - } - - static MethodHandle javaCall(MutableCallSite site, String name, MethodType type, Object... args) throws Exception { - if (name.endsWith(".")) { - Class aClass = intern(name.substring(0, name.length() - 1)).value(); - if (aClass != null) - return findJavaMethod(type, aClass.getName(), aClass.getConstructors()); - } - if (name.startsWith(".")) - return relinkOn(ClassCastException.class, findJavaMethod(type, name.substring(1), args[0].getClass().getMethods()), - linker(site, toBytecodeName(name))); - String[] classAndMethod = name.split("/"); - if (classAndMethod.length == 2 && intern(classAndMethod[0]).var instanceof Class) - return findJavaMethod(type, classAndMethod[1], ((Class) intern(classAndMethod[0]).value()).getMethods()); - return null; - } - - public static Object proxy(Method sam, Object x) throws Throwable { - if (x instanceof MethodHandle) { - MethodHandle target = (MethodHandle) x; - int arity = sam.getParameterTypes().length; - int actual = target.type().parameterCount(); - if (arity < actual) target = insertArguments(target, arity, new Object[actual - arity]); - if (arity > actual) target = dropArguments(target, actual, asList(sam.getParameterTypes()).subList(actual, arity)); - return asInterfaceInstance(sam.getDeclaringClass(), target); - } - return null; - } - - static MethodHandle filterJavaTypes(MethodHandle method) throws IllegalAccessException { - MethodHandle[] filters = new MethodHandle[method.type().parameterCount()]; - for (int i = 0; i < method.type().parameterCount() - (method.isVarargsCollector() ? 1 : 0); i++) - if (isSAM(method.type().parameterType(i))) - filters[i] = proxy.bindTo(findSAM(method.type().parameterType(i))) - .asType(methodType(method.type().parameterType(i), Object.class)); - else if (canCast(method.type().parameterType(i), int.class)) - filters[i] = asInt.asType(methodType(method.type().parameterType(i), Object.class)); - else if (canCast(method.type().wrap().parameterType(i), Number.class)) - filters[i] = asNumber.asType(methodType(method.type().parameterType(i), Object.class)); - if (canCast(method.type().wrap().returnType(), Number.class)) - method = filterReturnValue(method, number.asType(methodType(long.class, method.type().returnType()))); - return filterArguments(method, 0, filters); - } - - static MethodHandle findJavaMethod(MethodType type, String method, T[] methods) { - return some(stream(methods), m -> { - try { - if (m.getName().equals(method)) { - m.setAccessible(true); - MethodHandle mh = (m instanceof Method) ? lookup.unreflect((Method) m) : lookup.unreflectConstructor((Constructor) m); - mh.asType(methodType(type.returnType(), vec(type.parameterList().stream() - .map(c -> c.equals(Long.class) ? Integer.class : c.equals(long.class) ? int.class : c)))); - return filterJavaTypes(mh); - } - } catch (WrongMethodTypeException | IllegalAccessException ignored) { - } - return null; - }); - } - - public static MethodHandle function(Object target) throws Exception { - return target instanceof Invokable ? Primitives.function((Invokable) target) : (MethodHandle) target; - } - - static MethodHandle linker(MutableCallSite site, String name) { - return insertArguments(link, 0, site, name).asCollector(Object[].class, site.type().parameterCount()); - } - - static MethodHandle reLinker(String name, int arity) throws IllegalAccessException { - MutableCallSite reLinker = new MutableCallSite(genericMethodType(arity)); - return relinkOn(IllegalStateException.class, reLinker.dynamicInvoker(), linker(reLinker, toBytecodeName(name))); - } - - public static CallSite invokeBSM(Lookup lookup, String name, MethodType type) throws IllegalAccessException { - if (isOverloadedInternalFunction(name)) return invokeCallSite(name, type); - return sites.computeIfAbsent(name + type, key -> invokeCallSite(name, type)); - } - - static boolean isOverloadedInternalFunction(String name) { - return intern(toSourceName(name)).fn.size() > 1; - } - - static CallSite invokeCallSite(String name, MethodType type) { - MutableCallSite site = new MutableCallSite(type); - site.setTarget(linker(site, name).asType(type)); - return site; - } - - public static CallSite symbolBSM(Lookup lookup, String name, MethodType type) { - return sites.computeIfAbsent(name, key -> new ConstantCallSite(constant(Symbol.class, intern(toSourceName(name))))); - } - - public static CallSite applyBSM(Lookup lookup, String name, MethodType type) throws Exception { - return sites.computeIfAbsent(name + type, key -> applyCallSite(type)); - } - - public static Object partial(MethodHandle target, Object... args) throws Throwable { - if (args.length > target.type().parameterCount()) return uncurry(target, args); - return insertArguments(target, 0, args); - } - - public static boolean arityCheck(int arity, MethodHandle target) throws Throwable { - return target.type().parameterCount() == arity; - } - - static CallSite applyCallSite(MethodType type) { - MethodHandle apply = invoker(type.dropParameterTypes(0, 1)); - MethodHandle test = insertArguments(arityCheck, 0, type.parameterCount() - 1); - return new ConstantCallSite(guardWithTest(test, apply, partial.asType(type)).asType(type)); - } - - static MethodHandle mh(Class aClass, String name, Class... types) { - try { - return lookup.unreflect(find(stream(aClass.getMethods()), m -> m.getName().equals(name) - && (types.length == 0 || deepEquals(m.getParameterTypes(), types)))); - } catch (IllegalAccessException e) { - throw uncheck(e); - } - } - - static MethodHandle field(Class aClass, String name) { - try { - return lookup.unreflectGetter(aClass.getField(name)); - } catch (Exception e) { - throw uncheck(e); - } - } - - static boolean canCast(Class a, Class b) { - return a == Object.class || b == Object.class || canCastStrict(a, b); - } - - static boolean canCastStrict(Class a, Class b) { - return a == b || b.isAssignableFrom(a) || canWiden(a, b); - } - - static boolean canWiden(Class a, Class b) { - return wrapper(b).isNumeric() && wrapper(b).isConvertibleFrom(wrapper(a)); - } - - static Wrapper wrapper(Class type) { - if (isPrimitiveType(type)) return forPrimitiveType(type); - if (isWrapperType(type)) return forWrapperType(type); - return forBasicType(type); - } - - public static Symbol defun(Symbol name, MethodHandle fn) throws Throwable { - if (overrides.contains(name)) return name; - synchronized (name.symbol) { - SwitchPoint guard = name.fnGuard; - name.fn.clear(); - name.fn.add(fn); - if (guard != null) { - name.fnGuard = new SwitchPoint(); - invalidateAll(new SwitchPoint[] {guard}); - } - return name; - } - } - - static void register(Class aClass, Consumer hook) { - stream(aClass.getDeclaredMethods()).filter(m -> isPublic(m.getModifiers())).forEach(hook); - } - - static void override(Method m) { - overrides.add(defun(m)); - } - - static Symbol defun(Method m) { - try { - Symbol name = intern(unscramble(m.getName())); - name.fn.add(lookup.unreflect(m)); - return name; - } catch (IllegalAccessException e) { - throw uncheck(e); - } - } - - static Object uncurry(Object chain, Object... args) throws Throwable { - for (Object arg : args) - chain = ((MethodHandle) chain).invokeExact(arg); - return chain; - } - - public static MethodHandle bindTo(MethodHandle fn, Object arg) { - return insertArguments(fn, 0, arg); - } - - static String unscramble(String s) { - return toSourceName(s).replaceAll("_", "-").replaceAll("^KL-", "") .replaceAll("GT", ">").replaceAll("EQ", "=") - .replaceAll("LT", "<").replaceAll("EX$", "!").replaceAll("P$", "?").replaceAll("^AT", "@"); - } - - static MethodHandle findSAM(Object lambda) { - try { - return lookup.unreflect(findSAM(lambda.getClass())).bindTo(lambda); - } catch (IllegalAccessException e) { - throw uncheck(e); - } - } - - static Method findSAM(Class lambda) { - List methods = vec(stream(lambda.getDeclaredMethods()).filter(m -> !m.isSynthetic())); - return methods.size() == 1 ? methods.get(0) : null; - } - - static boolean isSAM(Class aClass) { - return findSAM(aClass) != null; - } - } - - public static class Compiler implements Opcodes { - static final AnonymousClassLoader loader = AnonymousClassLoader.make(unsafe(), RT.class); - static final Map macros = new HashMap<>(); - static final List> literals = asList(Long.class, String.class, Boolean.class, Handle.class); - static final Handle - applyBSM = handle(mh(RT.class, "applyBSM")), invokeBSM = handle(mh(RT.class, "invokeBSM")), - symbolBSM = handle(mh(RT.class, "symbolBSM")), or = handle(RT.mh(Primitives.class, "or")), - and = handle(RT.mh(Primitives.class, "and")); - static final Map push = new HashMap<>(); - static { - register(Macros.class, Compiler::macro); - } - - static int id = 1; - - String className; - ClassWriter cw; - - byte[] bytes; - GeneratorAdapter mv; - Object kl; - static ThreadLocal typeHint = new ThreadLocal<>(); - - Symbol self; - jdk.internal.org.objectweb.asm.commons.Method method; - Map locals; - List args; - List argTypes; - Type topOfStack; - Label recur; - - static class TypedValue { - final Type type; - final Object value; - - TypedValue(Type type, Object value) { - this.type = type; - this.value = value; - } - } - - public Compiler(Object kl, Symbol... args) throws Throwable { - this(null, "shen/ShenEval" + id++, kl, args); - } - - public Compiler(ClassWriter cn, String className, Object kl, Symbol... args) throws Throwable { - this.cw = cn; - this.className = className; - this.kl = kl; - this.args = list(args); - this.locals = new HashMap<>(); - } - - static ClassWriter classWriter(String name, Class anInterface) { - ClassWriter cw = new ClassWriter(COMPUTE_FRAMES) {}; // Needs to be in this package for some reason. - cw.visit(V1_7, ACC_PUBLIC | ACC_FINAL, name, null, getInternalName(Object.class), new String[] {getInternalName(anInterface)}); - return cw; - } - - static jdk.internal.org.objectweb.asm.commons.Method method(String name, String desc) { - return new jdk.internal.org.objectweb.asm.commons.Method(name, desc); - } - - - static String desc(Class returnType, Class... argumentTypes) { - return methodType(returnType, argumentTypes).toMethodDescriptorString(); - } - - static String desc(Type returnType, List argumentTypes) { - return getMethodDescriptor(returnType, argumentTypes.toArray(new Type[argumentTypes.size()])); - } - - static Handle handle(MethodHandle handle) { - MethodHandleInfo info = new MethodHandleInfo(handle); - return handle(getInternalName(info.getDeclaringClass()), info.getName(), handle.type().toMethodDescriptorString()); - } - - static Handle handle(String className, String name, String desc) { - return new Handle(Opcodes.H_INVOKESTATIC, className, name, desc); - } - - static Type boxedType(Type type) { - if (!isPrimitive(type)) return type; - return getType(forBasicType(type.getDescriptor().charAt(0)).wrapperType()); - } - - static boolean isPrimitive(Type type) { - return type.getSort() < ARRAY; - } - - static void macro(Method m) { - try { - macros.put(intern(unscramble(m.getName())), lookup.unreflect(m)); - } catch (IllegalAccessException e) { - throw uncheck(e); - } - } - - GeneratorAdapter generator(int access, jdk.internal.org.objectweb.asm.commons.Method method) { - return new GeneratorAdapter(access, method, cw.visitMethod(access, method.getName(), method.getDescriptor(), null, null)); - } - - TypedValue compile(Object kl) { - return compile(kl, true); - } - - TypedValue compile(Object kl, boolean tail) { - return compile(kl, getType(Object.class), tail); - } - - TypedValue compile(Object kl, Type returnType, boolean tail) { - return compile(kl, returnType, true, tail); - } - - TypedValue compile(Object kl, Type returnType, boolean handlePrimitives, boolean tail) { - try { - Class literalClass = find(literals.stream(), c -> c.isInstance(kl)); - if (literalClass != null) push(literalClass, kl); - else if (kl instanceof Symbol) symbol((Symbol) kl); - else if (kl instanceof Collection) { - @SuppressWarnings("unchecked") - List list = new ArrayList<>((Collection) kl); - lineNumber(list); - if (list.isEmpty()) emptyList(); - else { - Object first = list.get(0); - if (first instanceof Symbol && !inScope((Symbol) first)) { - Symbol s = (Symbol) first; - if (macros.containsKey(s)) macroExpand(s, rest(list), returnType, tail); - else indy(s, rest(list), returnType, tail); - - } else { - compile(first, tail); - apply(returnType, rest(list)); - } - } - } else - throw new IllegalArgumentException("Cannot compile: " + kl + " (" + kl.getClass() + ")"); - if (handlePrimitives) handlePrimitives(returnType); - return new TypedValue(topOfStack, kl); - } catch (RuntimeException | Error e) { - throw e; - } catch (Throwable t) { - throw uncheck(t); - } - } - - void handlePrimitives(Type returnType) { - if (isPrimitive(returnType) && !isPrimitive(topOfStack)) unbox(returnType); - else if (!isPrimitive(returnType) && isPrimitive(topOfStack)) box(); - } - - void lineNumber(List list) { - if (lines.containsKey(list)) - mv.visitLineNumber(lines.get(list), mv.mark()); - } - - boolean inScope(Symbol x) { - return (locals.containsKey(x) || args.contains(x)); - } - - void macroExpand(Symbol s, List args, Type returnType, boolean tail) throws Throwable { - macros.get(s).invokeWithArguments(into(asList(new Macros(), tail, returnType), - vec(args.stream().map(x -> x instanceof Cons ? ((Cons) x).toList() : x)))); - } - - void indy(Symbol s, List args, Type returnType, boolean tail) throws ReflectiveOperationException { - Iterator selfCallTypes = asList(method.getArgumentTypes()).iterator(); - List typedValues = vec(args.stream().map(o -> compile(o, isSelfCall(s, args) - ? selfCallTypes.next() : getType(Object.class), false, false))); - List argumentTypes = vec(typedValues.stream().map(t -> t.type)); - if (isSelfCall(s, args)) { - if (tail) { - debug("recur: %s", s); - recur(argumentTypes); - } else { - debug("can only recur from tail position: %s", s); - mv.invokeDynamic(toBytecodeName(s.symbol), desc(method.getReturnType(), argumentTypes), invokeBSM); - returnType = method.getReturnType(); - } - } else { - if (operators.contains(s) && returnType.equals(getType(Object.class)) && argumentTypes.size() == 2) - returnType = getType(s.fn.get(0).type().returnType()); - mv.invokeDynamic(toBytecodeName(s.symbol), desc(returnType, argumentTypes), invokeBSM); - } - topOfStack = returnType; - } - - void recur(List argumentTypes) { - for (int i = args.size()- 1; i >= 0; i--) { - if (!isPrimitive(method.getArgumentTypes()[i])) mv.valueOf(argumentTypes.get(i)); - mv.storeArg(i); - } - mv.goTo(recur); - } - - boolean isSelfCall(Symbol s, List args) { - return self.equals(s) && args.size() == this.args.size(); - } - - void apply(Type returnType, List args) throws ReflectiveOperationException { - if (!topOfStack.equals(getType(MethodHandle.class))) - mv.invokeStatic(getType(RT.class), method("function", desc(MethodHandle.class, Object.class))); - List argumentTypes = cons(getType(MethodHandle.class), vec(args.stream().map(o -> compile(o, false).type))); - mv.invokeDynamic("__apply__", desc(returnType, argumentTypes), applyBSM); - topOfStack = returnType; - } - - class Macros { - public void trap_error(boolean tail, Type returnType, Object x, Object f) throws Throwable { - Label after = mv.newLabel(); - - Label start = mv.mark(); - compile(x, returnType, tail); - mv.goTo(after); - - mv.catchException(start, mv.mark(), getType(Throwable.class)); - compile(f, false); - maybeCast(MethodHandle.class); - mv.swap(); - bindTo(); - - mv.invokeVirtual(getType(MethodHandle.class), method("invokeExact", desc(Object.class))); - if (isPrimitive(returnType)) unbox(returnType); - else topOfStack(Object.class); - mv.visitLabel(after); - } - - public void KL_if(boolean tail, Type returnType, Object test, Object then, Object _else) throws Exception { - if (test == Boolean.TRUE || test == intern("true")) { - compile(then, returnType, tail); - return; - } - if (test == Boolean.FALSE || test == intern("false")) { - compile(_else, returnType, tail); - return; - } - - Label elseStart = mv.newLabel(); - Label end = mv.newLabel(); - - compile(test, BOOLEAN_TYPE, false); - if (!BOOLEAN_TYPE.equals(topOfStack)) { - popStack(); - mv.throwException(getType(IllegalArgumentException.class), "boolean expected"); - return; - } - mv.visitJumpInsn(IFEQ, elseStart); - - compile(then, returnType, tail); - Type typeOfThenBranch = topOfStack; - mv.goTo(end); - - mv.visitLabel(elseStart); - compile(_else, returnType, tail); - - mv.visitLabel(end); - if (!typeOfThenBranch.equals(topOfStack) && !isPrimitive(returnType)) - topOfStack(Object.class); - } - - public void cond(boolean tail, Type returnType, List... clauses) throws Exception { - if (clauses.length == 0) - mv.throwException(getType(IllegalArgumentException.class), "condition failure"); - else { - List clause = clauses[0]; - KL_if(tail, returnType, clause.get(0), clause.get(1), cons(intern("cond"), rest(list((Object[]) clauses)))); - } - } - - public void or(boolean tail, Type returnType, Object x, Object... clauses) throws Exception { - if (clauses.length == 0) - bindTo(or, x); - else { - KL_if(tail, BOOLEAN_TYPE, x, true, (clauses.length > 1 ? cons(intern("or"), list(clauses)) : clauses[0])); - if (!isPrimitive(returnType)) mv.box(returnType); - } - } - - public void and(boolean tail, Type returnType, Object x, Object... clauses) throws Exception { - if (clauses.length == 0) - bindTo(and, x); - else { - KL_if(tail, BOOLEAN_TYPE, x, (clauses.length > 1 ? cons(intern("and"), list(clauses)) : clauses[0]), false); - if (!isPrimitive(returnType)) mv.box(returnType); - } - } - - public void lambda(boolean tail, Type returnType, Symbol x, Object y) throws Throwable { - fn("__lambda__", y, x); - } - - public void freeze(boolean tail, Type returnType, Object x) throws Throwable { - fn("__freeze__", x); - } - - public void defun(boolean tail, Type returnType, Symbol name, final List args, Object body) throws Throwable { - push(name); - debug("compiling: %s%s in %s", name, args, getObjectType(className).getClassName()); - name.source = toCons(asList(intern("defun"), name, args, body)); - if (booleanProperty("shen-*installing-kl*") && typesForInstallation.containsKey(name)) - Compiler.typeHint.set(typesForInstallation.get(name)); - fn(name.symbol, body, args.toArray(new Symbol[args.size()])); - mv.invokeStatic(getType(RT.class), method("defun", desc(Symbol.class, Symbol.class, MethodHandle.class))); - topOfStack(Symbol.class); - } - - public void let(boolean tail, Type returnType, Symbol x, Object y, Object z) throws Throwable { - Label start = mv.mark(); - compile(y, false); - Integer hidden = locals.get(x); - int let = hidden != null && tail ? hidden : mv.newLocal(topOfStack); - mv.storeLocal(let); - locals.put(x, let); - compile(z, returnType, tail); - if (hidden != null) locals.put(x, hidden); - else locals.remove(x); - mv.push((String) null); - mv.storeLocal(let); - mv.visitLocalVariable(x.symbol, mv.getLocalType(let).getDescriptor(), null, start, mv.mark(), let); - } - - public void KL_do(boolean tail, Type returnType, Object... xs) throws Throwable { - for (int i = 0; i < xs.length; i++) { - boolean last = i == xs.length - 1; - compile(xs[i], last ? returnType : getType(Object.class), last && tail); - if (!last) popStack(); - } - } - - public void thaw(boolean tail, Type returnType, Object f) throws Throwable { - compile(f, false); - maybeCast(MethodHandle.class); - mv.invokeVirtual(getType(MethodHandle.class), method("invokeExact", desc(Object.class))); - topOfStack(Object.class); - } - } - - void fn(String name, Object kl, Symbol... args) throws Throwable { - String bytecodeName = toBytecodeName(name) + "_" + id++; - List scope = vec(closesOver(new HashSet<>(asList(args)), kl).distinct()); - scope.retainAll(into(locals.keySet(), this.args)); - - if (name.startsWith("__")) typeHint.remove(); - List types = into(vec(scope.stream().map(this::typeOf)), typeHint.get() != null - ? vec(typeHint.get().parameterList().stream().map(Type::getType)) : nCopies(args.length, getType(Object.class))); - Type returnType = typeHint.get() != null ? getType(typeHint.get().returnType()) : getType(Object.class); - typeHint.remove(); - push(handle(className, bytecodeName, desc(returnType, types))); - insertArgs(0, scope); - - scope.addAll(asList(args)); - Compiler fn = new Compiler(cw, className, kl, scope.toArray(new Symbol[scope.size()])); - fn.method(ACC_PUBLIC | ACC_STATIC | ACC_FINAL, intern(name), bytecodeName, returnType, types); - } - - @SuppressWarnings({"unchecked"}) - Stream closesOver(Set scope, Object kl) { - if (kl instanceof Symbol && !scope.contains(kl)) - return singleton((Symbol) kl).stream(); - if (kl instanceof Collection) { - List list = new ArrayList<>((Collection) kl); - if (!list.isEmpty()) - switch (list.get(0).toString()) { - case "let": return concat(closesOver(scope, list.get(2)), closesOver(conj(scope, list.get(2)), list.get(3))); - case "lambda": return closesOver(conj(scope, list.get(2)), list.get(2)); - case "defun": return closesOver(into(scope, (Collection) list.get(2)), list.get(3)); - } - return list.stream().flatMap(o -> closesOver(scope, o)); - } - return empty(); - } - - void emptyList() { - mv.getStatic(getType(Collections.class), "EMPTY_LIST", getType(List.class)); - topOfStack(List.class); - } - - void symbol(Symbol s) throws Throwable { - if (asList("true", "false").contains(s.symbol)) { - push(Boolean.class, Boolean.valueOf(s.symbol)); - return; - } - else if (locals.containsKey(s)) mv.loadLocal(locals.get(s)); - else if (args.contains(s)) mv.loadArg(args.indexOf(s)); - else push(s); - topOfStack = typeOf(s); - } - - Type typeOf(Symbol s) { - if (locals.containsKey(s)) return mv.getLocalType(locals.get(s)); - else if (args.contains(s)) return argTypes.get(args.indexOf(s)); - return getType(Symbol.class); - } - - void loadArgArray(List args) { - mv.push(args.size()); - mv.newArray(getType(Object.class)); - - for (int i = 0; i < args.size(); i++) { - mv.dup(); - mv.push(i); - compile(args.get(i), false); - box(); - mv.arrayStore(getType(Object.class)); - } - topOfStack(Object[].class); - } - - void push(Symbol kl) { - mv.invokeDynamic(toBytecodeName(kl.symbol), desc(Symbol.class), symbolBSM); - topOfStack(Symbol.class); - } - - void push(Handle handle) { - mv.push(handle); - topOfStack(MethodHandle.class); - } - - void push(Class aClass, Object kl) throws Throwable { - aClass = asPrimitiveType(aClass); - push.computeIfAbsent(aClass, c -> mh(mv.getClass(), "push", c)).invoke(mv, kl); - topOfStack(aClass); - } - - void box() { - Type maybePrimitive = topOfStack; - mv.valueOf(maybePrimitive); - topOfStack = boxedType(maybePrimitive); - } - - void unbox(Type type) { - mv.unbox(type); - topOfStack = type; - } - - void popStack() { - if (topOfStack.getSize() == 1) mv.pop(); else mv.pop2(); - } - - void maybeCast(Class type) { - maybeCast(getType(type)); - } - - void maybeCast(Type type) { - if (!type.equals(topOfStack)) mv.checkCast(type); - topOfStack = type; - } - - void topOfStack(Class aClass) { - topOfStack = getType(aClass); - } - - public Class load(String source, Class anInterface) throws Exception { - try { - cw = classWriter(className, anInterface); - cw.visitSource(source, null); - constructor(); - Method sam = findSAM(anInterface); - List types = vec(stream(sam.getParameterTypes()).map(Type::getType)); - method(ACC_PUBLIC, intern(sam.getName()), toBytecodeName(sam.getName()), getType(sam.getReturnType()), types); - bytes = cw.toByteArray(); - if (booleanProperty("*debug-asm*")) printASM(bytes, sam); - //noinspection unchecked - return (Class) loader.loadClass(bytes); - } catch (VerifyError e) { - printASM(bytes, null); - throw e; - } - } - - void method(int modifiers, Symbol name, String bytecodeName, Type returnType, List argumentTypes) { - this.self = name; - this.argTypes = argumentTypes; - this.method = method(bytecodeName, desc(returnType, argumentTypes)); - mv = generator(modifiers, method); - recur = mv.mark(); - compile(kl, returnType, true); - maybeCast(returnType); - mv.returnValue(); - mv.endMethod(); - } - - void constructor() { - GeneratorAdapter ctor = generator(ACC_PUBLIC, method("", desc(void.class))); - ctor.loadThis(); - ctor.invokeConstructor(getType(Object.class), method("", desc(void.class))); - ctor.returnValue(); - ctor.endMethod(); - } - - void bindTo(Handle handle, Object arg) { - push(handle); - compile(arg, false); - box(); - bindTo(); - } - - void bindTo() { - mv.invokeStatic(getType(RT.class), method("bindTo",desc(MethodHandle.class, MethodHandle.class, Object.class))); - topOfStack(MethodHandle.class); - } - - void insertArgs(int pos, List args) { - if (args.isEmpty()) return; - mv.push(pos); - loadArgArray(args); - mv.invokeStatic(getType(MethodHandles.class), method("insertArguments", - desc(MethodHandle.class, MethodHandle.class, int.class, Object[].class))); - topOfStack(MethodHandle.class); - } - - static void printASM(byte[] bytes, Method method) { - ASMifier asm = new ASMifier(); - PrintWriter pw = new PrintWriter(err); - TraceClassVisitor printer = new TraceClassVisitor(null, asm, pw); - if (method == null) - new ClassReader(bytes).accept(printer, SKIP_DEBUG); - else { - ClassNode cn = new ClassNode(); - new ClassReader(bytes).accept(cn, SKIP_DEBUG); - find(cn.methods.stream(), mn -> mn.name.equals(method.getName())).accept(printer); - asm.print(pw); - pw.flush(); - } - } - - static Unsafe unsafe() { - try { - Field unsafe = Unsafe.class.getDeclaredField("theUnsafe"); - unsafe.setAccessible(true); - return (Unsafe) unsafe.get(null); - } catch (Exception e) { - throw uncheck(e); - } - } - } - - static void debug(String format, Object... args) { - if (isDebug()) err.println(format(format, - stream(args).map(o -> o != null && o.getClass() == Object[].class - ? deepToString((Object[]) o) : o).toArray())); - } - - @SafeVarargs - static List list(T... items) { - return new ArrayList<>(asList(items)); - } - - @SuppressWarnings("unchecked") - static List vec(Stream coll) { - return new ArrayList<>(coll.collect(Collectors.toList())); - } - - static T find(Stream coll, Predicate pred) { - return coll.filter(pred).findFirst().orElse(null); - } - - static R some(Stream coll, Function pred) { - return coll.map(pred).filter(isEqual(true).or(Objects::nonNull)).findFirst().orElse(null); - } - - static > C into(C to, Collection from) { - Collector> collector = to instanceof Set ? toSet() : Collectors.toList(); - //noinspection unchecked - return (C) concat(to.stream(), from.stream()).collect(collector); - } - - static > C conj(C coll, Object x) { //noinspection unchecked - return into(coll, singleton((T) x)); - } - - static List cons(T x, List seq) { - return into(singletonList(x), seq); - } - - static boolean every(Collection c1, Collection c2, BiPredicate pred) { - //return zip(c1.stream(), c2.stream(), pred::test).allMatch(isEqual(true)); - Iterator it1 = c1.iterator(); - Iterator it2 = c2.iterator(); - List result= new ArrayList(); - while(it1.hasNext() && it2.hasNext()) { - T value1 = it1.next(); - T value2 = it2.next(); - result.add(pred.test(value1,value2)); - } - boolean ret = !result.contains(false); - return ret; - } - - static T find(Collection c1, Collection c2, BiPredicate pred) { - //return zip(c1.stream(), c2.stream(), (x, y) -> pred.test(x, y) ? x : null) - // .filter(Objects::nonNull).findFirst().orElse(null); - Iterator it1 = c1.iterator(); - Iterator it2 = c2.iterator(); - Collection result = new ArrayList(c1); - result.clear(); - while(it1.hasNext() && it2.hasNext()) { - T value1 = it1.next(); - T value2 = it2.next(); - if(pred.test(value1, value2) == true){ - result.add(value1); - }else{ - result.add(null); - } - } - - return result.stream().filter(Objects::nonNull).findFirst().orElse(null); - } - - static List rest(List coll) { - return coll.isEmpty() ? coll : coll.subList(1, coll.size()); - } - - static RuntimeException uncheck(Throwable t) { - return uncheckAndThrow(t); - } - - static T uncheckAndThrow(Throwable t) throws T { //noinspection unchecked - throw (T) t; - } - //***************************************************************** - //***************************************************************** - //***************************************************************** - //***************************************************************** - //***************************************************************** - //Stuff taken out of b93 and modified appropriately - /** - * Creates a lazy concatenated {@code Stream} whose elements are all the - * elements of a first {@code Stream} succeeded by all the elements of the - * second {@code Stream}. The resulting stream is ordered if both - * of the input streams are ordered, and parallel if either of the input - * streams is parallel. - * - * @param The type of stream elements - * @param a the first stream - * @param b the second stream to concatenate on to end of the first - * stream - * @return the concatenation of the two input streams - */ - public static Stream concat(Stream a, Stream b) { - Objects.requireNonNull(a); - Objects.requireNonNull(b); - - @SuppressWarnings("unchecked") - Spliterator split = new ConcatSpliterator.OfRef<>((Spliterator) a.spliterator(), - (Spliterator) b.spliterator()); - /*return (a.isParallel() || b.isParallel()) - ? StreamSupport.parallelStream(split) - : StreamSupport.stream(split);*/ - return (a.isParallel() || b.isParallel()) - ? StreamSupport.stream(split,true) - : StreamSupport.stream(split,false); - } - - private abstract static class ConcatSpliterator> - implements Spliterator { - protected final T_SPLITR aSpliterator; - protected final T_SPLITR bSpliterator; - // True when no split has occurred, otherwise false - boolean beforeSplit; - - public ConcatSpliterator(T_SPLITR aSpliterator, T_SPLITR bSpliterator) { - this.aSpliterator = aSpliterator; - this.bSpliterator = bSpliterator; - beforeSplit = true; - } - - @Override - public T_SPLITR trySplit() { - T_SPLITR ret = beforeSplit ? aSpliterator : (T_SPLITR) bSpliterator.trySplit(); - beforeSplit = false; - return ret; - } - - @Override - public boolean tryAdvance(Consumer consumer) { - boolean hasNext; - if (beforeSplit) { - hasNext = aSpliterator.tryAdvance(consumer); - if (!hasNext) { - beforeSplit = false; - hasNext = bSpliterator.tryAdvance(consumer); - } - } - else - hasNext = bSpliterator.tryAdvance(consumer); - return hasNext; - } - - @Override - public void forEachRemaining(Consumer consumer) { - if (beforeSplit) - aSpliterator.forEachRemaining(consumer); - bSpliterator.forEachRemaining(consumer); - } - - @Override - public long estimateSize() { - if (beforeSplit) { - // If one or both estimates are Long.MAX_VALUE then the sum - // will either be Long.MAX_VALUE or overflow to a negative value - long size = aSpliterator.estimateSize() + bSpliterator.estimateSize(); - return (size >= 0) ? size : Long.MAX_VALUE; - } - else { - return bSpliterator.estimateSize(); - } - } - - @Override - public int characteristics() { - if (beforeSplit) { - // Concatenation loses DISTINCT and SORTED characteristics - return aSpliterator.characteristics() & bSpliterator.characteristics() & - ~(Spliterator.DISTINCT | Spliterator.SORTED); - } - else { - return bSpliterator.characteristics(); - } - } - - @Override - public Comparator getComparator() { - if (beforeSplit) - throw new IllegalStateException(); - return bSpliterator.getComparator(); - } - - private static class OfRef extends ConcatSpliterator> { - private OfRef(Spliterator aSpliterator, Spliterator bSpliterator) { - super(aSpliterator, bSpliterator); - } - } - - private static abstract class OfPrimitive> - extends ConcatSpliterator - implements Spliterator.OfPrimitive { - private OfPrimitive(T_SPLITR aSpliterator, T_SPLITR bSpliterator) { - super(aSpliterator, bSpliterator); - } - - @Override - public boolean tryAdvance(T_CONS action) { - boolean hasNext; - if (beforeSplit) { - hasNext = aSpliterator.tryAdvance(action); - if (!hasNext) { - beforeSplit = false; - hasNext = bSpliterator.tryAdvance(action); - } - } - else - hasNext = bSpliterator.tryAdvance(action); - return hasNext; - } - - @Override - public void forEachRemaining(T_CONS action) { - if (beforeSplit) - aSpliterator.forEachRemaining(action); - bSpliterator.forEachRemaining(action); - } - } - - private static class OfInt - extends ConcatSpliterator.OfPrimitive - implements Spliterator.OfInt { - private OfInt(Spliterator.OfInt aSpliterator, Spliterator.OfInt bSpliterator) { - super(aSpliterator, bSpliterator); - } - } - - private static class OfLong - extends ConcatSpliterator.OfPrimitive - implements Spliterator.OfLong { - private OfLong(Spliterator.OfLong aSpliterator, Spliterator.OfLong bSpliterator) { - super(aSpliterator, bSpliterator); - } - } - - private static class OfDouble - extends ConcatSpliterator.OfPrimitive - implements Spliterator.OfDouble { - private OfDouble(Spliterator.OfDouble aSpliterator, Spliterator.OfDouble bSpliterator) { - super(aSpliterator, bSpliterator); - } - } - } -} diff --git a/src/shen/Symbol.java b/src/shen/Symbol.java new file mode 100644 index 0000000..2c0250e --- /dev/null +++ b/src/shen/Symbol.java @@ -0,0 +1,44 @@ +package shen; + +import java.lang.invoke.MethodHandle; +import java.lang.invoke.SwitchPoint; +import java.util.ArrayList; +import java.util.Collection; +import java.util.List; + +public class Symbol implements Shen.Invokable { + public final String symbol; + public List fn = new ArrayList<>(); + public SwitchPoint fnGuard; + public Object var; + public Collection source; + + Symbol(String symbol) { + this.symbol = symbol.intern(); + } + + public String toString() { + return symbol; + } + + public T value() { + if (var == null) throw new IllegalArgumentException("variable " + this + " has no value"); + //noinspection unchecked + return (T) var; + } + + public boolean equals(Object o) { //noinspection StringEquality + return o instanceof Symbol && symbol == ((Symbol) o).symbol; + } + + public int hashCode() { + return symbol.hashCode(); + } + + public MethodHandle invoker() throws IllegalAccessException { + if (fn.isEmpty()) return RT.reLinker(symbol, 0); + MethodHandle mh = fn.get(0); + if (fn.size() > 1) return RT.reLinker(symbol, mh.type().parameterCount()); + return mh; + } +} \ No newline at end of file diff --git a/test/shen/BenchmarksTest.java b/test/shen/BenchmarksTest.java index f4d41b4..cf1d7e4 100644 --- a/test/shen/BenchmarksTest.java +++ b/test/shen/BenchmarksTest.java @@ -3,16 +3,13 @@ import org.junit.Ignore; import org.junit.Test; -import static shen.Shen.eval; -import static shen.Shen.install; - public class BenchmarksTest { @Test @Ignore public void benchmarks() throws Throwable { - install(); - eval("(cd \"shen/benchmarks\")"); - eval("(load \"README.shen\")"); - eval("(load \"benchmarks.shen\")"); + Shen.install(); + Shen.eval("(cd \"shen/benchmarks\")"); + Shen.eval("(load \"README.shen\")"); + Shen.eval("(load \"benchmarks.shen\")"); } public static void main(String... args) throws Throwable { diff --git a/test/shen/MicroBench.java b/test/shen/MicroBench.java index 1b21dc0..ec19337 100644 --- a/test/shen/MicroBench.java +++ b/test/shen/MicroBench.java @@ -4,18 +4,13 @@ import java.util.concurrent.Callable; import static java.lang.System.currentTimeMillis; -import static shen.Shen.Compiler; -import static shen.Shen.KLReader.read; -import static shen.Shen.Numbers.maybeNumber; -import static shen.Shen.Primitives.set; -import static shen.Shen.eval; public class MicroBench { public static void main(String[] args) throws Throwable { int times = 10; - set("*debug*", true); - eval("(defun fib (n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2)))))"); + Primitives.set("*debug*", true); + Shen.eval("(defun fib (n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2)))))"); bench("(fib 30)", times); bench("(fib 30.0)", times); // Will switch fib from long to double @@ -25,11 +20,11 @@ public static void main(String[] args) throws Throwable { bench(() -> fib(30), times); // Java bench(() -> fibBoxed(30L), times); // Java Boxed - eval("(defun my-cons (a b) (cons a b))"); + Shen.eval("(defun my-cons (a b) (cons a b))"); bench("(my-cons 1 2)", times); // Will pick cons(Object, Object) bench("(my-cons 1 ())", times); // Fails without hack/fix - eval("(defun my-cons (a b) (cons a b))"); + Shen.eval("(defun my-cons (a b) (cons a b))"); bench("(my-cons 1 ())", times); // Picks cons(Object, List) bench("(my-cons 1 2)", times); // Guarded down to cons(Object, Object) bench("(my-cons 1 ())", times); // Reuses same target matching guard @@ -37,17 +32,17 @@ public static void main(String[] args) throws Throwable { bench("(= 1 1)", times); // Not for performance, but these easily break bench("(= 1 1.0)", times); - eval("(defun map (f x) (if (cons? x) (cons (f (hd x)) (map f (tl x))) ()))"); + Shen.eval("(defun map (f x) (if (cons? x) (cons (f (hd x)) (map f (tl x))) ()))"); bench("(map (+ 1) (cons 1 (cons 2 (cons 3 ()))))", times); - eval("(defun inc (x) (+ 1 x))"); + Shen.eval("(defun inc (x) (+ 1 x))"); bench("(map inc (cons 1 (cons 2 (cons 3 ()))))", times); times = 30; bench("(cons 1 1.0)", times); bench("((cons 1) 1.0)", times); - eval("(defun my-cons (x) ((cons 1) x))"); + Shen.eval("(defun my-cons (x) ((cons 1) x))"); bench("(my-cons 1.0)", times); } @@ -67,13 +62,13 @@ static Long fibBoxed(Long n) { } static void bench(String test, int times) throws Throwable { - Object kl = read(new StringReader(test)).get(0); + Object kl = KLReader.read(new StringReader(test)).get(0); bench(new Compiler(kl).load("__eval__", Callable.class).newInstance(), times); } static void bench(Callable code, int times) throws Exception { long start = currentTimeMillis(); - for (int i = 0; i < times; i++) System.out.println(maybeNumber(code.call())); + for (int i = 0; i < times; i++) System.out.println(Numbers.maybeNumber(code.call())); System.out.println(times + ": " + ((currentTimeMillis() - start) / ((double) times) + "ms.")); } } diff --git a/test/shen/PrimitivesTest.java b/test/shen/PrimitivesTest.java index 527f643..d575b52 100644 --- a/test/shen/PrimitivesTest.java +++ b/test/shen/PrimitivesTest.java @@ -16,10 +16,6 @@ import static org.hamcrest.CoreMatchers.equalTo; import static org.hamcrest.CoreMatchers.instanceOf; import static org.junit.Assert.*; -import static shen.Shen.*; -import static shen.Shen.Numbers.*; -import static shen.Shen.Primitives.intern; -import static shen.Shen.RT.canCast; public class PrimitivesTest { @Test @@ -27,7 +23,7 @@ public void equals() { is(2L, "2"); is(true, "true"); is("foo", "\"foo\""); - is(intern("bar"), "bar"); + is(Primitives.intern("bar"), "bar"); is(false, "(= 2 3)"); is(false, "(= \"foo\" \"bar\")"); is(false, "(= true false)"); @@ -36,7 +32,7 @@ public void equals() { @Test public void defun_lambda_and_let() { - is(intern("f"), "(defun f (x) (lambda y (+ x y))"); + is(Primitives.intern("f"), "(defun f (x) (lambda y (+ x y))"); is(5L, "((f 3) 2)"); is(10L, "(let x 5 (* 2 x)"); } @@ -106,7 +102,7 @@ public void arithmetic() { is(1.5, "(let x 2.0 (let y 0.5 (- x y)))"); is(1.5, "(let x 2 (let y 0.5 (- x y)))"); is(true, "(= (value x) 1)"); - is(intern("fun"), "(defun fun (x y) (- x y)))"); + is(Primitives.intern("fun"), "(defun fun (x y) (- x y)))"); is(1.5, "(fun 2 0.5)"); is(1.5, "(fun 2.5 1)"); } @@ -223,13 +219,13 @@ public void cons() { @Test public void absvector_absvector_p_address_gt_and_lt_address() { - Symbol fail = intern("fail!"); + Symbol fail = Primitives.intern("fail!"); Object[] absvector = {fail, fail, fail, fail, fail}; is(absvector, "(set v (absvector 5)"); is(false, "(absvector? v)"); is(false, "(absvector? 2)"); is(false, "(absvector? \"foo\")"); - absvector[2] = integer(5L); + absvector[2] = Numbers.integer(5L); is(absvector, "(address-> (value v) 2 5)"); is(5L, "(<-address (value v) 2)"); is(-1L, "(trap-error (<-address (value v) 5) (lambda E -1))"); @@ -239,8 +235,8 @@ public void absvector_absvector_p_address_gt_and_lt_address() { public void eval_kl_freeze_and_thaw() { is(9L, "(eval-kl (cons + (cons 4 (cons 5 ()))))"); is(4L, "(eval-kl 4)"); - is(intern("hello"), "(eval-kl hello)"); - is(intern("hello"), "(eval-kl hello)"); + is(Primitives.intern("hello"), "(eval-kl hello)"); + is(Primitives.intern("hello"), "(eval-kl hello)"); is(MethodHandle.class, "(freeze (+ 2 2)"); is(MethodHandle.class, "(freeze (/ 2 0))"); is(4L, "((freeze (+ 2 2)))"); @@ -252,7 +248,7 @@ public void set_value_and_intern() { is(5L, "(set x 5)"); is(5L, "(value x)"); is(5L, "(value (intern \"x\")"); - is(intern("fun"), "(defun fun () (value x))"); + is(Primitives.intern("fun"), "(defun fun () (value x))"); is(5L, "(fun)"); is(6L, "(set x 6)"); is(6L, "(fun)"); @@ -270,7 +266,7 @@ public void tagged_values() { is(false, "(value x)"); is(asList(), "(set x ())"); is(asList(), "(value x)"); - is(intern("fun"), "(defun fun (x) (value x))"); + is(Primitives.intern("fun"), "(defun fun (x) (value x))"); is(asList(), "(fun x)"); is(5.0, "(set x 5.0)"); is(5.0, "(fun x)"); @@ -344,8 +340,8 @@ public void lists() { is(-1L, "(trap-error (hd 5) (lambda E -1))"); is(-1L, "(trap-error (tl 5) (lambda E -1))"); is(1L, "(hd (cons 1 (cons 2 (cons 3 ()))))"); - is(asList(integer(2L), integer(3L)), "(tl (cons 1 (cons 2 (cons 3 ()))))"); - is(new Cons(integer(5L), integer(10L)), "(cons 5 10)"); + is(asList(Numbers.integer(2L), Numbers.integer(3L)), "(tl (cons 1 (cons 2 (cons 3 ()))))"); + is(new Cons(Numbers.integer(5L), Numbers.integer(10L)), "(cons 5 10)"); } @Test @@ -380,10 +376,10 @@ public void partials() { is(MethodHandle.class, "(cons 1)"); is(MethodHandle.class, "(cons)"); is(MethodHandle.class, "((cons) 1)"); - is(asList(integer(1L)), "((cons 1) ())"); - is(new Cons(integer(1L), integer(2L)), "((cons 1) 2)"); - is(new Cons(integer(1L), integer(2L)), "(((cons) 1) 2)"); - is(new Cons(integer(1L), integer(2L)), "((cons) 1 2)"); + is(asList(Numbers.integer(1L)), "((cons 1) ())"); + is(new Cons(Numbers.integer(1L), Numbers.integer(2L)), "((cons 1) 2)"); + is(new Cons(Numbers.integer(1L), Numbers.integer(2L)), "(((cons) 1) 2)"); + is(new Cons(Numbers.integer(1L), Numbers.integer(2L)), "((cons) 1 2)"); is(true, "((> 50) 10)"); is(true, "(let test or (test true false))"); is(false, "(let test and (test true false))"); @@ -393,20 +389,20 @@ public void partials() { @Test public void uncurry() { - is(asList(integer(1L), integer(2L)), "((lambda x (lambda y (cons x (cons y ())))) 1 2)"); - is(new Cons(integer(1L), integer(2L)), "(((cons) 1) 2)"); + is(asList(Numbers.integer(1L), Numbers.integer(2L)), "((lambda x (lambda y (cons x (cons y ())))) 1 2)"); + is(new Cons(Numbers.integer(1L), Numbers.integer(2L)), "(((cons) 1) 2)"); } @Test public void function() { is(3L, "((function +) 1 2)"); is(3.0, "((function +) 1 2.0)"); - is(intern("x"), "(defun x () y)"); - is(intern("y"), "(let z x (z)))"); - is(intern("x"), "(defun x (y) y)"); + is(Primitives.intern("x"), "(defun x () y)"); + is(Primitives.intern("y"), "(let z x (z)))"); + is(Primitives.intern("x"), "(defun x (y) y)"); is(2L, "(let a x (a 2)))"); - is(intern("x"), "(defun x (y) (y))"); - is(intern("y"), "(defun y () 1))"); + is(Primitives.intern("x"), "(defun x (y) (y))"); + is(Primitives.intern("y"), "(defun y () 1))"); is(1L, "(x y)"); is(MethodHandle.class, "(function undefined)"); is(-1L, "(trap-error ((function undefined)) (lambda E -1))"); @@ -414,26 +410,26 @@ public void function() { @Test public void rebind() { - is(intern("fun"), "(defun fun (x) (cons 1 x)"); - is(asList(integer(1L)), "(fun ())"); - is(new Cons(integer(1L), integer(2L)), "(fun 2)"); - is(intern("fun"), "(defun fun (x) (cons 1 x)"); - is(new Cons(integer(1L), integer(2L)), "(fun 2)"); - is(asList(integer(1L)), "(fun ())"); - is(intern("fun2"), "(defun fun2 (x) (+ 2 x))"); + is(Primitives.intern("fun"), "(defun fun (x) (cons 1 x)"); + is(asList(Numbers.integer(1L)), "(fun ())"); + is(new Cons(Numbers.integer(1L), Numbers.integer(2L)), "(fun 2)"); + is(Primitives.intern("fun"), "(defun fun (x) (cons 1 x)"); + is(new Cons(Numbers.integer(1L), Numbers.integer(2L)), "(fun 2)"); + is(asList(Numbers.integer(1L)), "(fun ())"); + is(Primitives.intern("fun2"), "(defun fun2 (x) (+ 2 x))"); is(3L, "(fun2 1)"); is(3.0, "(fun2 1.0)"); } @Test public void recur() { - is(intern("factorial"), "(defun factorial (cnt acc) (if (= 0 cnt) acc (factorial (- cnt 1) (* acc cnt)))"); + is(Primitives.intern("factorial"), "(defun factorial (cnt acc) (if (= 0 cnt) acc (factorial (- cnt 1) (* acc cnt)))"); is(3628800L, "(factorial 10 1)"); } @Test public void can_only_recur_from_tail_position() { - is(intern("fib"), "(defun fib (n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2)))))"); + is(Primitives.intern("fib"), "(defun fib (n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2)))))"); is(55L, "(fib 10)"); } @@ -449,16 +445,16 @@ public void java() { is("Oracle Corporation", "(System/getProperty \"java.vendor\")"); is(1.414213562373095, "(Math/sqrt 2)"); // Should be 1.4142135623730951 <- last decimal is truncated is(Class.class, "(import java.util.Arrays)"); - is(asList(integer(1L), integer(2L)), "(Arrays/asList 1 2)"); + is(asList(Numbers.integer(1L), Numbers.integer(2L)), "(Arrays/asList 1 2)"); is(Class.class, "(import java.util.ArrayList)"); is(Class.class, "(value ArrayList)"); is(0L, "(.size ()))"); is(ArrayList.class, "(ArrayList.)"); - is(asList(integer(1L)), "(ArrayList. (cons 1 ())"); + is(asList(Numbers.integer(1L)), "(ArrayList. (cons 1 ())"); is(Long.class, "(.size (ArrayList. (cons 1 ()))"); // is(asList(2L), "(tl (ArrayList. (cons 1 (cons 2 ())))"); is("HELLO", "(.toUpperCase \"Hello\")"); - is(intern("up"), "(defun up (x) (.toUpperCase x))"); + is(Primitives.intern("up"), "(defun up (x) (.toUpperCase x))"); is("UP", "(up \"up\")"); is("TWICE", "(up \"twice\")"); } @@ -478,10 +474,10 @@ public void java_proxies() { public void relink_java() { is(Class.class, "(import java.util.ArrayList)"); is(Class.class, "(import java.util.LinkedList)"); - is(intern("to-string"), "(defun to-string (x) (.toString x))"); + is(Primitives.intern("to-string"), "(defun to-string (x) (.toString x))"); is(String.class, "(to-string (ArrayList. (cons 1 ()))"); is(String.class, "(to-string (LinkedList. (cons 1 ()))"); - is(intern("size"), "(defun size (x) (.size x))"); + is(Primitives.intern("size"), "(defun size (x) (.size x))"); is(1L, "(size (ArrayList. (cons 1 ()))"); is(1L, "(size (LinkedList. (cons 1 ()))"); is(0L, "(size ())"); @@ -491,46 +487,46 @@ public void relink_java() { @Test public void redefine() { - is(intern("fun"), "(defun fun (x y) (+ x y))"); - is(intern("fun2"), "(defun fun2 () (fun 1 2))"); + is(Primitives.intern("fun"), "(defun fun (x y) (+ x y))"); + is(Primitives.intern("fun2"), "(defun fun2 () (fun 1 2))"); is(3L, "(fun 1 2)"); is(3L, "(fun2)"); - is(intern("fun"), "(defun fun (x y) (- x y))"); + is(Primitives.intern("fun"), "(defun fun (x y) (- x y))"); is(-1L, "(fun 1 2)"); is(-1L, "(fun2)"); - is(intern("fun"), "(defun fun (x y) (+ x y))"); + is(Primitives.intern("fun"), "(defun fun (x y) (+ x y))"); is(3L, "(fun 1 2)"); is(3L, "(fun2)"); } @Test public void casts() { - assertTrue(canCast(Long.class, Object.class)); - assertTrue(canCast(Object.class, Long.class)); - assertTrue(canCast(Long.class, Double.class)); - assertFalse(canCast(Double.class, Long.class)); - assertTrue(canCast(long.class, double.class)); - assertFalse(canCast(double.class, long.class)); - assertTrue(canCast(long.class, Double.class)); - assertFalse(canCast(Double.class, Long.class)); - assertTrue(canCast(long.class, Object.class)); - assertTrue(canCast(Object.class, long.class)); - assertTrue(canCast(Long.class, long.class)); - assertTrue(canCast(long.class, Long.class)); - assertTrue(canCast(long.class, long.class)); - assertTrue(canCast(Object.class, Object.class)); - assertTrue(canCast(String.class, Object.class)); - assertTrue(canCast(Object.class, String.class)); - assertFalse(canCast(Long.class, List.class)); + assertTrue(RT.canCast(Long.class, Object.class)); + assertTrue(RT.canCast(Object.class, Long.class)); + assertTrue(RT.canCast(Long.class, Double.class)); + assertFalse(RT.canCast(Double.class, Long.class)); + assertTrue(RT.canCast(long.class, double.class)); + assertFalse(RT.canCast(double.class, long.class)); + assertTrue(RT.canCast(long.class, Double.class)); + assertFalse(RT.canCast(Double.class, Long.class)); + assertTrue(RT.canCast(long.class, Object.class)); + assertTrue(RT.canCast(Object.class, long.class)); + assertTrue(RT.canCast(Long.class, long.class)); + assertTrue(RT.canCast(long.class, Long.class)); + assertTrue(RT.canCast(long.class, long.class)); + assertTrue(RT.canCast(Object.class, Object.class)); + assertTrue(RT.canCast(String.class, Object.class)); + assertTrue(RT.canCast(Object.class, String.class)); + assertFalse(RT.canCast(Long.class, List.class)); } void is(Object expected, String actual) { Object 神 = 神(actual); if (expected instanceof Class) - if (expected == Double.class) assertThat(isInteger((Long) 神), equalTo(false)); + if (expected == Double.class) assertThat(Numbers.isInteger((Long) 神), equalTo(false)); else assertThat(神, instanceOf((Class) expected)); else if (神 instanceof Long) - assertThat(asNumber((Long) 神), equalTo(expected)); + assertThat(Numbers.asNumber((Long) 神), equalTo(expected)); else if (神 instanceof Cons && expected instanceof List) assertThat(((Cons) 神).toList(), equalTo(expected)); else @@ -539,7 +535,7 @@ else if (神 instanceof Cons && expected instanceof List) Object 神(String shen) { try { - return eval(shen); + return Shen.eval(shen); } catch (Throwable t) { throw new RuntimeException(t); } diff --git a/test/shen/SmokeTest.java b/test/shen/SmokeTest.java index 6f15271..3527e95 100644 --- a/test/shen/SmokeTest.java +++ b/test/shen/SmokeTest.java @@ -3,11 +3,13 @@ import org.junit.Test; import java.util.LinkedList; +import java.util.List; import static java.lang.System.out; import static java.util.Arrays.asList; -import static shen.Shen.Primitives.*; -import static shen.Shen.eval; +import static org.hamcrest.CoreMatchers.equalTo; +import static org.hamcrest.CoreMatchers.instanceOf; +import static org.junit.Assert.assertThat; // These are the main methods from the interpreter and compiler, no structure or niceness. // Tests lots of random stuff, written while developing, most this should be covered in PrimitivesTest. @@ -15,97 +17,151 @@ public class SmokeTest { @Test public void interpreter() throws Throwable { - out.println(eval_kl(intern("x"))); - out.println(eval("(or false)")); - out.println(eval("(or false false)")); - out.println(eval("(or false true)")); - out.println(eval("(or false false false)")); - out.println(eval("((or false) true)")); - out.println(eval("()")); - out.println(eval("(cons 2 3)")); - - out.println(eval("(absvector? (absvector 10))")); - out.println(eval("(absvector 10)")); - out.println(eval("(absvector? ())")); - out.println(eval("(+ 1 2)")); - out.println(eval("((+ 6.5) 2.0)")); - out.println(eval("(+ 1.0 2.0)")); - out.println(eval("(* 5 2)")); - out.println(eval("(* 5)")); - out.println(eval("(let x 42 x)")); - out.println(eval("(let x 42 (let y 2 (cons x y)))")); - out.println(eval("((lambda x (lambda y (cons x y))) 2 3)")); - out.println(eval("((lambda x (lambda y (cons x y))) 2)")); - out.println(eval("((let x 3 (lambda y (cons x y))) 2)")); - out.println(eval("(cond (true 1))")); - out.println(eval("(cond (false 1) ((> 10 3) 3))")); - out.println(eval("(cond (false 1) ((> 10 3) ()))")); - - out.println(eval("(defun fib (n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2)))))")); - out.println(eval("(fib 10)")); - - out.println(eval("(defun factorial (cnt acc) (if (= 0 cnt) acc (factorial (- cnt 1) (* acc cnt)))")); - out.println(eval("(factorial 10 1)")); - out.println(eval("(factorial 12)")); - out.println(eval("((factorial 19) 1)")); - - out.println(eval_kl(asList(intern("lambda"), intern("x"), intern("x")))); - out.println(eval_kl(asList(intern("defun"), intern("my-fun"), asList(intern("x")), intern("x")))); - out.println(str(eval_kl(asList(intern("my-fun"), 3L)))); - out.println(eval_kl(asList(intern("defun"), intern("my-fun2"), asList(intern("x"), intern("y")), asList(intern("cons"), intern("y"), asList(intern("cons"), intern("x"), new LinkedList()))))); - out.println(eval_kl(asList(intern("my-fun2"), 3L, 5L))); - out.println(eval_kl(asList(intern("defun"), intern("my-fun3"), asList(), "Hello"))); - out.println(str(eval_kl(asList(intern("my-fun3"))))); + out.println(Primitives.eval_kl(Primitives.intern("x"))); + out.println(Shen.eval("(or false)")); + out.println(Shen.eval("(or false false)")); + out.println(Shen.eval("(or false true)")); + out.println(Shen.eval("(or false false false)")); + out.println(Shen.eval("((or false) true)")); + out.println(Shen.eval("()")); + out.println(Shen.eval("(cons 2 3)")); + + out.println(Shen.eval("(absvector? (absvector 10))")); + out.println(Shen.eval("(absvector 10)")); + out.println(Shen.eval("(absvector? ())")); + out.println(Shen.eval("(+ 1 2)")); + out.println(Shen.eval("((+ 6.5) 2.0)")); + out.println(Shen.eval("(+ 1.0 2.0)")); + out.println(Shen.eval("(* 5 2)")); + out.println(Shen.eval("(* 5)")); + out.println(Shen.eval("(let x 42 x)")); + out.println(Shen.eval("(let x 42 (let y 2 (cons x y)))")); + out.println(Shen.eval("((lambda x (lambda y (cons x y))) 2 3)")); + out.println(Shen.eval("((lambda x (lambda y (cons x y))) 2)")); + out.println(Shen.eval("((let x 3 (lambda y (cons x y))) 2)")); + out.println(Shen.eval("(cond (true 1))")); + out.println(Shen.eval("(cond (false 1) ((> 10 3) 3))")); + out.println(Shen.eval("(cond (false 1) ((> 10 3) ()))")); + + out.println(Shen.eval("(defun fib (n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2)))))")); + out.println(Shen.eval("(fib 10)")); + + out.println(Shen.eval("(defun factorial (cnt acc) (if (= 0 cnt) acc (factorial (- cnt 1) (* acc cnt)))")); + out.println(Shen.eval("(factorial 10 1)")); + out.println(Shen.eval("(factorial 12)")); + out.println(Shen.eval("((factorial 19) 1)")); + + out.println(Primitives.eval_kl(asList(Primitives.intern("lambda"), Primitives.intern("x"), Primitives.intern("x")))); + out.println(Primitives.eval_kl(asList(Primitives.intern("defun"), Primitives.intern("my-fun"), asList(Primitives.intern("x")), Primitives.intern("x")))); + out.println(Primitives.str(Primitives.eval_kl(asList(Primitives.intern("my-fun"), 3L)))); + out.println(Primitives.eval_kl(asList(Primitives.intern("defun"), Primitives.intern("my-fun2"), asList(Primitives.intern("x"), Primitives.intern("y")), asList(Primitives.intern("cons"), Primitives.intern("y"), asList(Primitives.intern("cons"), Primitives.intern("x"), new LinkedList()))))); + out.println(Primitives.eval_kl(asList(Primitives.intern("my-fun2"), 3L, 5L))); + out.println(Primitives.eval_kl(asList(Primitives.intern("defun"), Primitives.intern("my-fun3"), asList(), "Hello"))); + out.println(Primitives.str(Primitives.eval_kl(asList(Primitives.intern("my-fun3"))))); } @Test public void compiler() throws Throwable { - out.println(eval("(trap-error my-symbol my-handler)")); - out.println(eval("(trap-error (simple-error \"!\") (lambda x x))")); - out.println(eval("(if true \"true\" \"false\")")); - out.println(eval("(if false \"true\" \"false\")")); - out.println(eval("(cond (false 1) (true 2))")); - out.println(eval("(cond (false 1) ((or true false) 3))")); - out.println(eval("(or false)")); - out.println(eval("((or false) false)")); - out.println(eval("(or false false)")); - out.println(eval("(or false true false)")); - out.println(eval("(and true true)")); - out.println(eval("(and true true (or false false))")); - out.println(eval("(and true false)")); - out.println(eval("(and true)")); - out.println(eval("(lambda x x)")); - out.println(eval("((lambda x x) 2)")); - out.println(eval("(let x \"str\" x)")); - out.println(eval("(let x 10 x)")); - out.println(eval("(let x 10 (let y 5 x))")); - out.println(eval("((let x 42 (lambda y x)) 0)")); - out.println(eval("((lambda x ((lambda y x) 42)) 0)")); - out.println(eval("(get-time unix)")); - out.println(eval("(value *language*)")); - out.println(eval("(+ 1 1)")); - out.println(eval("(+ 1.2 1.1)")); - out.println(eval("(+ 1.2 1)")); - out.println(eval("(+ 1 1.3)")); - out.println(eval("(cons x y)")); - out.println(eval("(cons x)")); - out.println(eval("((cons x) z)")); - out.println(eval("(cons x y)")); - out.println(eval("(absvector? (absvector 10))")); - out.println(eval("(trap-error (/ 1 0) (lambda x x))")); - out.println(eval("(defun fun (x y) (+ x y))")); - out.println(eval("(defun fun2 () (fun 1 2))")); - out.println(eval("(fun2)")); - out.println(eval("(defun fun (x y) (- x y))")); - out.println(eval("(fun2)")); - out.println(eval("(fun 1 2)")); - out.println(eval("(set x y)")); - out.println(eval("(value x)")); - out.println(eval("(set x z)")); - out.println(eval("(value x)")); - out.println(eval("()")); - out.println(eval("(cond (true ()) (false 2))")); - out.println(eval("(if (<= 3 3) x y)")); - out.println(eval("(eval-kl (cons + (cons 1 (cons 2 ()))))")); + out.println(Shen.eval("(trap-error my-symbol my-handler)")); + out.println(Shen.eval("(trap-error (simple-error \"!\") (lambda x x))")); + out.println(Shen.eval("(if true \"true\" \"false\")")); + out.println(Shen.eval("(if false \"true\" \"false\")")); + out.println(Shen.eval("(cond (false 1) (true 2))")); + out.println(Shen.eval("(cond (false 1) ((or true false) 3))")); + out.println(Shen.eval("(or false)")); + out.println(Shen.eval("((or false) false)")); + out.println(Shen.eval("(or false false)")); + out.println(Shen.eval("(or false true false)")); + out.println(Shen.eval("(and true true)")); + out.println(Shen.eval("(and true true (or false false))")); + out.println(Shen.eval("(and true false)")); + out.println(Shen.eval("(and true)")); + out.println(Shen.eval("(lambda x x)")); + out.println(Shen.eval("((lambda x x) 2)")); + out.println(Shen.eval("(let x \"str\" x)")); + out.println(Shen.eval("(let x 10 x)")); + out.println(Shen.eval("(let x 10 (let y 5 x))")); + out.println(Shen.eval("((let x 42 (lambda y x)) 0)")); + out.println(Shen.eval("((lambda x ((lambda y x) 42)) 0)")); + out.println(Shen.eval("(get-time unix)")); + out.println(Shen.eval("(value *language*)")); + out.println(Shen.eval("(+ 1 1)")); + out.println(Shen.eval("(+ 1.2 1.1)")); + out.println(Shen.eval("(+ 1.2 1)")); + out.println(Shen.eval("(+ 1 1.3)")); + out.println(Shen.eval("(cons x y)")); + out.println(Shen.eval("(cons x)")); + out.println(Shen.eval("((cons x) z)")); + out.println(Shen.eval("(cons x y)")); + out.println(Shen.eval("(absvector? (absvector 10))")); + out.println(Shen.eval("(trap-error (/ 1 0) (lambda x x))")); + out.println(Shen.eval("(defun fun (x y) (+ x y))")); + out.println(Shen.eval("(defun fun2 () (fun 1 2))")); + out.println(Shen.eval("(fun2)")); + out.println(Shen.eval("(defun fun (x y) (- x y))")); + out.println(Shen.eval("(fun2)")); + out.println(Shen.eval("(fun 1 2)")); + out.println(Shen.eval("(set x y)")); + out.println(Shen.eval("(value x)")); + out.println(Shen.eval("(set x z)")); + out.println(Shen.eval("(value x)")); + out.println(Shen.eval("()")); + out.println(Shen.eval("(cond (true ()) (false 2))")); + out.println(Shen.eval("(if (<= 3 3) x y)")); + out.println(Shen.eval("(eval-kl (cons + (cons 1 (cons 2 ()))))")); + } + + /* + This tests a function which is recursive and which uses the let keyword. e.g. + + (define funcLetAndRecurse + X -> (let Z (- X 1) + (if (= Z 1) (* 3 X) (funcLetAndRecurse Z)) + ) + ) + + This function returns 6 + + In the function below we use the Klambda code which is : + + (defun funcLetAndRecurse (V503) (let Z (- V503 1) (if (= Z 1) (* 3 V503) (funcLetAndRecurse Z)))) + */ + @Test + public void other() throws Throwable { + String funcDef1 = "(defun funcLetAndRecurse (V503) (let Z (- V503 1) (if (= Z 1) (* 3 V503) (funcLetAndRecurse Z))))"; + String funcCall = "(funcLetAndRecurse 10)"; + + //tests that let and recurse works fine when combined together + Shen.eval(funcDef1); + is(6L, funcCall); + + //tests that second call gives same answer as first + is(6L, funcCall); + + //this tests that redefinition works + String funcDef2 = " (defun funcLetAndRecurse (V503) (let Z (- V503 1) (if (= Z 1) (* 2 V503) (funcLetAndRecurse Z))))"; + Shen.eval(funcDef2); + is(4L, funcCall); + } + + void is(Object expected, String actual) { + Object 神 = 神(actual); + if (expected instanceof Class) + if (expected == Double.class) assertThat(Numbers.isInteger((Long) 神), equalTo(false)); + else assertThat(神, instanceOf((Class) expected)); + else if (神 instanceof Long) + assertThat(Numbers.asNumber((Long) 神), equalTo(expected)); + else if (神 instanceof Cons && expected instanceof List) + assertThat(((Cons) 神).toList(), equalTo(expected)); + else + assertThat(神, equalTo(expected)); + } + + Object 神(String shen) { + try { + return Shen.eval(shen); + } catch (Throwable t) { + throw new RuntimeException(t); + } } } diff --git a/test/shen/TestProgramsTest.java b/test/shen/TestProgramsTest.java index 2bb125d..cb13979 100644 --- a/test/shen/TestProgramsTest.java +++ b/test/shen/TestProgramsTest.java @@ -3,16 +3,13 @@ import org.junit.Ignore; import org.junit.Test; -import static shen.Shen.eval; -import static shen.Shen.install; - public class TestProgramsTest { @Test @Ignore public void test_programs() throws Throwable { - install(); - eval("(cd \"shen/Test Programs\")"); - eval("(load \"README.shen\")"); - eval("(load \"tests.shen\")"); + Shen.install(); + Shen.eval("(cd \"shen/Test Programs\")"); + Shen.eval("(load \"README.shen\")"); + Shen.eval("(load \"tests.shen\")"); } public static void main(String... args) throws Throwable {