Skip to content

Commit 9dd5b10

Browse files
artella-codingartella-coding
committed
Shen 16
1 parent 4b64535 commit 9dd5b10

27 files changed

+801
-725
lines changed

‎README.md

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
# 神.java | Shen for Java (Shen 15)
1+
# 神.java | Shen for Java (Shen 16)
22

33
http://shenlanguage.org/
44

@@ -23,7 +23,7 @@ This port is loosely based on [`shen.clj`](https://github.com/hraberg/shen.clj),
2323
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`.
2424

2525
Core requirements :
26-
* [JDK 8u40 Build b04](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)
26+
* [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)
2727
* [Maven](http://maven.apache.org/). See [Maven project file](https://github.com/artella-coding/Shen.java/blob/master/pom.xml).
2828

2929
Optional requirements : There's an IntelliJ project, which requires [IDEA 12](http://www.jetbrains.com/idea/download/index.html).

‎shen/Test Programs/einstein.shen

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -29,5 +29,6 @@
2929
X Y List <-- (iright Y X List);)
3030

3131
(defprolog iright
32-
L R [L | [R | _]] <--;
33-
L R [_ | Rest] <-- (iright L R Rest);)
32+
L R (mode [L | [R | _]] -) <--;
33+
L R (mode [_ | Rest] -) <-- (iright L R Rest);)
34+

‎shen/Test Programs/qmachine.shen

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -34,15 +34,15 @@
3434

3535
(define forall
3636
{(progression A) --> (A --> boolean) --> boolean}
37-
Progression P -> (super Progression P and true))
37+
Progression P -> (super Progression P (function and) true))
3838

3939
(define exists
4040
{(progression A) --> (A --> boolean) --> boolean}
41-
Progression P -> (super Progression P or false))
41+
Progression P -> (super Progression P (function or) false))
4242

4343
(define for
4444
{(progression A) --> (A --> B) --> number}
45-
Progression P -> (super Progression P progn 0))
45+
Progression P -> (super Progression P (function progn) 0))
4646

4747
(define progn
4848
{A --> B --> B}

‎shen/benchmarks/jnk.shen

Lines changed: 194 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,194 @@
1+
(define kl-to-lisp
2+
Params Param -> Param where (element? Param Params)
3+
Params [type X _] -> (kl-to-lisp Params X)
4+
Params [lambda X Y] -> [FUNCTION [LAMBDA [X] (kl-to-lisp [X | Params] Y)]]
5+
Params [let X Y Z] -> [LET [[X (kl-to-lisp Params Y)]]
6+
(kl-to-lisp [X | Params] Z)]
7+
_ [defun F Params Code] -> [DEFUN F Params (kl-to-lisp Params Code)]
8+
Params [cond | Cond] -> [COND | (map (/. C (cond_code Params C)) (insert-default Cond))]
9+
Params [Param | X] -> (higher-order-code Param
10+
(map (/. Y (kl-to-lisp Params Y)) X))
11+
where (element? Param Params)
12+
Params [[X | Y] | Z] -> (higher-order-code (kl-to-lisp Params [X | Y])
13+
(map (/. W (kl-to-lisp Params W)) Z))
14+
Params [F | X] -> (assemble-application F
15+
(map (/. Y (kl-to-lisp Params Y)) X))
16+
where (symbol? F)
17+
_ [] -> []
18+
_ S -> [QUOTE S] where (or (symbol? S) (boolean? S))
19+
_ X -> X)
20+
21+
(define insert-default
22+
[] -> [[true [ERROR "error: cond failure~%"]]]
23+
[[true X] | Y] -> [[true X] | Y]
24+
[Case | Cases] -> [Case | (insert-default Cases)])
25+
26+
(define higher-order-code
27+
F X -> [let Args [LIST | X]
28+
[let NewF [maplispsym F]
29+
[trap-error [APPLY NewF Args]
30+
[lambda E [COND [[arity-error? F Args]
31+
[funcall [EVAL [nest-lambda F NewF]] Args]]
32+
[[EQ NewF [QUOTE or]]
33+
[funcall [lambda X1 [lambda X2 [or X1 X2]]] Args]]
34+
[[EQ NewF [QUOTE and]]
35+
[funcall [lambda X1 [lambda X2 [and X1 X2]]] Args]]
36+
[[EQ NewF [QUOTE trap-error]]
37+
[funcall [lambda X1 [lambda X2 [trap-error X1 X2]]] Args]]
38+
[[bad-lambda-call? NewF Args]
39+
[funcall NewF Args]]
40+
[T [relay-error E]]]]]]])
41+
42+
(define bad-lambda-call?
43+
F Args -> (AND (FUNCTIONP F) (NOT (= (LIST-LENGTH Args) 1))))
44+
45+
(define relay-error
46+
E -> (ERROR (error-to-string E)))
47+
48+
(define funcall
49+
Lambda [] -> Lambda
50+
Lambda [X | Y] -> (funcall (FUNCALL Lambda X) Y))
51+
52+
(define arity-error?
53+
F Args -> (AND (SYMBOLP F)
54+
(> (trap-error (arity F) (/. E -1)) (LIST-LENGTH Args)))
55+
56+
(define nest-lambda
57+
F NewF -> (nest-lambda-help NewF (trap-error (arity F) (/. E -1))))
58+
59+
(define nest-lambda-help
60+
F -1 -> F
61+
F 0 -> F
62+
F N -> (let X (gensym (protect Y))
63+
[lambda X (nest-lambda-help (add-p F X) (- N 1))]))
64+
65+
(define add-p
66+
[F | X] Y -> (append [F | X] [Y])
67+
F X -> [F X])
68+
69+
(define cond_code
70+
Params [Test Result] -> [(lisp_test Params Test)
71+
(kl-to-lisp Params Result)])
72+
73+
(define lisp_test
74+
_ true -> T
75+
Params [and | Tests] -> [AND | (map (/. X (wrap (kl-to-lisp Params X))) Tests)]
76+
Params Test -> (wrap (kl-to-lisp Params Test)))
77+
78+
(define wrap
79+
[cons? X] -> [CONSP X]
80+
[string? X] -> [STRINGP X]
81+
[number? X] -> [NUMBERP X]
82+
[empty? X] -> [NULL X]
83+
[and P Q] -> [AND (wrap P) (wrap Q)]
84+
[or P Q] -> [OR (wrap P) (wrap Q)]
85+
[not P] -> [NOT (wrap P)]
86+
[equal? X []] -> [NULL X]
87+
[equal? [] X] -> [NULL X]
88+
[equal? X [Quote Y]] -> [EQ X [Quote Y]]
89+
where (and (= (SYMBOLP Y) T) (= Quote QUOTE))
90+
[equal? [Quote Y] X] -> [EQ [Quote Y] X]
91+
where (and (= (SYMBOLP Y) T) (= Quote QUOTE))
92+
[equal? [fail] X] -> [EQ [fail] X]
93+
[equal? X [fail]] -> [EQ X [fail]]
94+
[equal? S X] -> [EQUAL S X] where (string? S)
95+
[equal? X S] -> [EQUAL X S] where (string? S)
96+
[equal? X Y] -> [shen-ABSEQUAL X Y]
97+
[shen-+string? [tlstr X]] -> [NOT [STRING-EQUAL [tlstr X] ""]]
98+
[shen-pvar? X] -> [AND [ARRAYP X] [NOT [STRINGP X]] [EQ [AREF X 0] [QUOTE shen-pvar]]]
99+
[tuple? X] -> [AND [ARRAYP X] [NOT [STRINGP X]] [EQ [AREF X 0] [QUOTE shen-tuple]]]
100+
[greater? X Y] -> [> X Y]
101+
[greater-than-or-equal-to? X Y] -> [>= X Y]
102+
[less? X Y] -> [< X Y]
103+
[less-than-or-equal-to? X Y] -> [<= X Y]
104+
X -> [wrapper X])
105+
106+
(define wrapper
107+
true -> T
108+
false -> []
109+
X -> (error "boolean expected: not ~S~%" X))
110+
111+
(define assemble-application
112+
hd [X] -> (protect [CAR X])
113+
tl [X] -> (protect [CDR X])
114+
cons [X Y] -> (protect [CONS X Y])
115+
append [X Y] -> (protect [APPEND X Y])
116+
reverse [X] -> (protect [REVERSE X])
117+
if [P Q R] -> (protect [IF (wrap P) Q R])
118+
+ [1 X] -> [1+ X]
119+
+ [X 1] -> [1+ X]
120+
- [X 1] -> [1- X]
121+
value [[Quote X]] -> X where (= Quote (protect QUOTE))
122+
set [[Quote X] [1+ X]] -> [INCF X] where (= Quote (protect QUOTE))
123+
set [[Quote X] [1- X]] -> [DECF X] where (= Quote (protect QUOTE))
124+
F X -> (let NewF (maplispsym F)
125+
Arity (trap-error (arity F) (/. E -1))
126+
(if (or (= Arity (length X)) (= Arity -1))
127+
[NewF | X]
128+
[funcall (nest-lambda F NewF) [(protect LIST) | X]])))
129+
130+
(define maplispsym
131+
= -> equal?
132+
> -> greater?
133+
< -> less?
134+
>= -> greater-than-or-equal-to?
135+
<= -> less-than-or-equal-to?
136+
+ -> add
137+
- -> subtract
138+
/ -> divide
139+
* -> multiply
140+
F -> F)
141+
142+
(define factorh
143+
[Defun F Params [Cond | Code]] -> [Defun F Params [BLOCK [] (process-tree (tree (map returns Code)))]]
144+
where (and (= Cond COND) (= Defun DEFUN))
145+
Code -> Code)
146+
147+
(define returns
148+
[Test Result] -> [Test [RETURN Result]])
149+
150+
(define process-tree
151+
(@p P Q R no-tag) -> [IF P (optimise-selectors P (process-tree Q)) (process-tree R)]
152+
(@p P Q R Tag) -> [TAGBODY [IF P (optimise-selectors P (process-tree Q))] Tag (process-tree R)]
153+
Q -> Q where (not (tuple? Q)))
154+
155+
(define optimise-selectors
156+
Test Code -> (optimise-selectors-help (selectors-from Test) Code))
157+
158+
(define selectors-from
159+
[Consp X] -> [[CAR X] [CDR X]] where (= Consp CONSP)
160+
[tuple? X] -> [[fst X] [snd X]]
161+
_ -> [])
162+
163+
(define optimise-selectors-help
164+
[] Code -> Code
165+
[S1 S2] Code -> (let O1 (occurrences S1 Code)
166+
O2 (occurrences S2 Code)
167+
V1 (gensym V)
168+
V2 (gensym V)
169+
(if (and (> O1 1) (> O2 1))
170+
[LET [[V1 S1] [V2 S2]]
171+
(subst V1 S1 (subst V2 S2 Code))]
172+
(if (> O1 1)
173+
[LET [[V1 S1]] (subst V1 S1 Code)]
174+
(if (> O2 1)
175+
[LET [[V2 S2]] (subst V2 S2 Code)]
176+
Code)))))
177+
178+
(define tree
179+
[[[And P Q] R] | S] -> (let Tag (gensym tag)
180+
Left (tree (append (branch-by P [[[And P Q] R] | S]) [[T [GO Tag]]]))
181+
Right (tree (branch-by-not P [[[And P Q] R] | S]))
182+
(@p P Left Right Tag)) where (= And AND)
183+
[[True Q] | _] -> Q where (= True T)
184+
[[P Q] | R] -> (@p P Q (tree R) no-tag))
185+
186+
(define branch-by
187+
P [[[And P Q] R] | S] -> [[Q R] | (branch-by P S)] where (= And AND)
188+
P [[P R] | S] -> [[T R]]
189+
_ Code -> [])
190+
191+
(define branch-by-not
192+
P [[[And P Q] R] | S] -> (branch-by-not P S) where (= And AND)
193+
P [[P R] | S] -> S
194+
_ Code -> Code)

0 commit comments

Comments
 (0)