aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation/common.jvm.lux
blob: 49e13570915581fc272919bba3e06a7e7cdcaaa6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
(;module:
  [lux #- function]
  (lux (control ["ex" exception #+ exception:])
       [io]
       (concurrency ["A" atom])
       (data ["e" error]
             [text]
             text/format
             (coll [dict #+ Dict]))
       [host]
       (world [blob #+ Blob]
              [file #+ File]))
  (luxc (lang [";L" variable #+ Register]
              (host ["$" jvm]
                    (jvm ["$t" type]
                         ["$d" def]
                         ["$i" inst])))))

(host;import org.objectweb.asm.Opcodes
  (#static V1_6 int))

(host;import org.objectweb.asm.Label)

(host;import java.lang.Object)

(host;import (java.lang.Class a))

(host;import java.lang.ClassLoader
  (loadClass [String] (Class Object)))

(type: #export Bytecode Blob)

(type: #export Class-Store (A;Atom (Dict Text Bytecode)))

(type: #export Artifacts (Dict File Blob))

(type: #export Host
  {#loader ClassLoader
   #store Class-Store
   #artifacts Artifacts
   #context [Text Nat]
   #anchor (Maybe [Label Register])})

(exception: Unknown-Class)
(exception: Class-Already-Stored)
(exception: No-Function-Being-Compiled)
(exception: Cannot-Overwrite-Artifact)

(def: #export (with-artifacts action)
  (All [a] (-> (Meta a) (Meta [Artifacts a])))
  (;function [compiler]
    (case (action (update@ #;host
                           (|>. (:! Host)
                                (set@ #artifacts (dict;new text;Hash<Text>))
                                (:! Void))
                           compiler))
      (#e;Success [compiler' output])
      (#e;Success [(update@ #;host
                            (|>. (:! Host)
                                 (set@ #artifacts (|> (get@ #;host compiler) (:! Host) (get@ #artifacts)))
                                 (:! Void))
                            compiler')
                   [(|> compiler' (get@ #;host) (:! Host) (get@ #artifacts))
                    output]])
      
      (#e;Error error)
      (#e;Error error))))

(def: #export (record-artifact name content)
  (-> Text Blob (Meta Unit))
  (;function [compiler]
    (if (|> compiler (get@ #;host) (:! Host) (get@ #artifacts) (dict;contains? name))
      (ex;throw Cannot-Overwrite-Artifact name)
      (#e;Success [(update@ #;host
                            (|>. (:! Host)
                                 (update@ #artifacts (dict;put name content))
                                 (:! Void))
                            compiler)
                   []]))))

(def: #export (store-class name byte-code)
  (-> Text Bytecode (Meta Unit))
  (;function [compiler]
    (let [store (|> (get@ #;host compiler)
                    (:! Host)
                    (get@ #store))]
      (if (dict;contains? name (|> store A;get io;run))
        (ex;throw Class-Already-Stored name)
        (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))])
        ))))

(def: #export (load-class name)
  (-> Text (Meta (Class Object)))
  (;function [compiler]
    (let [host (:! Host (get@ #;host compiler))
          store (|> host (get@ #store) A;get io;run)]
      (if (dict;contains? name store)
        (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
        (ex;throw Unknown-Class name)))))

(def: #export bytecode-version Int Opcodes.V1_6)

(def: #export value-field Text "_value")
(def: #export $Object $;Type ($t;class "java.lang.Object" (list)))