diff options
Diffstat (limited to '')
| -rw-r--r-- | epl-v10.html | 261 | ||||
| -rw-r--r-- | source/lux.lux | 108 | ||||
| -rw-r--r-- | src/lux/analyser/base.clj | 1 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 82 | ||||
| -rw-r--r-- | src/lux/analyser/env.clj | 24 | ||||
| -rw-r--r-- | src/lux/analyser/lambda.clj | 8 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 56 | ||||
| -rw-r--r-- | src/lux/analyser/module.clj | 97 | ||||
| -rw-r--r-- | src/lux/analyser/record.clj | 158 | ||||
| -rw-r--r-- | src/lux/base.clj | 130 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 5 | ||||
| -rw-r--r-- | src/lux/compiler/cache.clj | 2 | ||||
| -rw-r--r-- | src/lux/compiler/case.clj | 23 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 21 | ||||
| -rw-r--r-- | src/lux/reader.clj | 10 | ||||
| -rw-r--r-- | src/lux/type.clj | 44 |
16 files changed, 689 insertions, 341 deletions
diff --git a/epl-v10.html b/epl-v10.html new file mode 100644 index 000000000..813c07d8c --- /dev/null +++ b/epl-v10.html @@ -0,0 +1,261 @@ +<?xml version="1.0" encoding="ISO-8859-1" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />
+<title>Eclipse Public License - Version 1.0</title>
+<style type="text/css">
+ body {
+ size: 8.5in 11.0in;
+ margin: 0.25in 0.5in 0.25in 0.5in;
+ tab-interval: 0.5in;
+ }
+ p {
+ margin-left: auto;
+ margin-top: 0.5em;
+ margin-bottom: 0.5em;
+ }
+ p.list {
+ margin-left: 0.5in;
+ margin-top: 0.05em;
+ margin-bottom: 0.05em;
+ }
+ </style>
+
+</head>
+
+<body lang="EN-US">
+
+<p align=center><b>Eclipse Public License - v 1.0</b></p>
+
+<p>THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
+PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR
+DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS
+AGREEMENT.</p>
+
+<p><b>1. DEFINITIONS</b></p>
+
+<p>"Contribution" means:</p>
+
+<p class="list">a) in the case of the initial Contributor, the initial
+code and documentation distributed under this Agreement, and</p>
+<p class="list">b) in the case of each subsequent Contributor:</p>
+<p class="list">i) changes to the Program, and</p>
+<p class="list">ii) additions to the Program;</p>
+<p class="list">where such changes and/or additions to the Program
+originate from and are distributed by that particular Contributor. A
+Contribution 'originates' from a Contributor if it was added to the
+Program by such Contributor itself or anyone acting on such
+Contributor's behalf. Contributions do not include additions to the
+Program which: (i) are separate modules of software distributed in
+conjunction with the Program under their own license agreement, and (ii)
+are not derivative works of the Program.</p>
+
+<p>"Contributor" means any person or entity that distributes
+the Program.</p>
+
+<p>"Licensed Patents" mean patent claims licensable by a
+Contributor which are necessarily infringed by the use or sale of its
+Contribution alone or when combined with the Program.</p>
+
+<p>"Program" means the Contributions distributed in accordance
+with this Agreement.</p>
+
+<p>"Recipient" means anyone who receives the Program under
+this Agreement, including all Contributors.</p>
+
+<p><b>2. GRANT OF RIGHTS</b></p>
+
+<p class="list">a) Subject to the terms of this Agreement, each
+Contributor hereby grants Recipient a non-exclusive, worldwide,
+royalty-free copyright license to reproduce, prepare derivative works
+of, publicly display, publicly perform, distribute and sublicense the
+Contribution of such Contributor, if any, and such derivative works, in
+source code and object code form.</p>
+
+<p class="list">b) Subject to the terms of this Agreement, each
+Contributor hereby grants Recipient a non-exclusive, worldwide,
+royalty-free patent license under Licensed Patents to make, use, sell,
+offer to sell, import and otherwise transfer the Contribution of such
+Contributor, if any, in source code and object code form. This patent
+license shall apply to the combination of the Contribution and the
+Program if, at the time the Contribution is added by the Contributor,
+such addition of the Contribution causes such combination to be covered
+by the Licensed Patents. The patent license shall not apply to any other
+combinations which include the Contribution. No hardware per se is
+licensed hereunder.</p>
+
+<p class="list">c) Recipient understands that although each Contributor
+grants the licenses to its Contributions set forth herein, no assurances
+are provided by any Contributor that the Program does not infringe the
+patent or other intellectual property rights of any other entity. Each
+Contributor disclaims any liability to Recipient for claims brought by
+any other entity based on infringement of intellectual property rights
+or otherwise. As a condition to exercising the rights and licenses
+granted hereunder, each Recipient hereby assumes sole responsibility to
+secure any other intellectual property rights needed, if any. For
+example, if a third party patent license is required to allow Recipient
+to distribute the Program, it is Recipient's responsibility to acquire
+that license before distributing the Program.</p>
+
+<p class="list">d) Each Contributor represents that to its knowledge it
+has sufficient copyright rights in its Contribution, if any, to grant
+the copyright license set forth in this Agreement.</p>
+
+<p><b>3. REQUIREMENTS</b></p>
+
+<p>A Contributor may choose to distribute the Program in object code
+form under its own license agreement, provided that:</p>
+
+<p class="list">a) it complies with the terms and conditions of this
+Agreement; and</p>
+
+<p class="list">b) its license agreement:</p>
+
+<p class="list">i) effectively disclaims on behalf of all Contributors
+all warranties and conditions, express and implied, including warranties
+or conditions of title and non-infringement, and implied warranties or
+conditions of merchantability and fitness for a particular purpose;</p>
+
+<p class="list">ii) effectively excludes on behalf of all Contributors
+all liability for damages, including direct, indirect, special,
+incidental and consequential damages, such as lost profits;</p>
+
+<p class="list">iii) states that any provisions which differ from this
+Agreement are offered by that Contributor alone and not by any other
+party; and</p>
+
+<p class="list">iv) states that source code for the Program is available
+from such Contributor, and informs licensees how to obtain it in a
+reasonable manner on or through a medium customarily used for software
+exchange.</p>
+
+<p>When the Program is made available in source code form:</p>
+
+<p class="list">a) it must be made available under this Agreement; and</p>
+
+<p class="list">b) a copy of this Agreement must be included with each
+copy of the Program.</p>
+
+<p>Contributors may not remove or alter any copyright notices contained
+within the Program.</p>
+
+<p>Each Contributor must identify itself as the originator of its
+Contribution, if any, in a manner that reasonably allows subsequent
+Recipients to identify the originator of the Contribution.</p>
+
+<p><b>4. COMMERCIAL DISTRIBUTION</b></p>
+
+<p>Commercial distributors of software may accept certain
+responsibilities with respect to end users, business partners and the
+like. While this license is intended to facilitate the commercial use of
+the Program, the Contributor who includes the Program in a commercial
+product offering should do so in a manner which does not create
+potential liability for other Contributors. Therefore, if a Contributor
+includes the Program in a commercial product offering, such Contributor
+("Commercial Contributor") hereby agrees to defend and
+indemnify every other Contributor ("Indemnified Contributor")
+against any losses, damages and costs (collectively "Losses")
+arising from claims, lawsuits and other legal actions brought by a third
+party against the Indemnified Contributor to the extent caused by the
+acts or omissions of such Commercial Contributor in connection with its
+distribution of the Program in a commercial product offering. The
+obligations in this section do not apply to any claims or Losses
+relating to any actual or alleged intellectual property infringement. In
+order to qualify, an Indemnified Contributor must: a) promptly notify
+the Commercial Contributor in writing of such claim, and b) allow the
+Commercial Contributor to control, and cooperate with the Commercial
+Contributor in, the defense and any related settlement negotiations. The
+Indemnified Contributor may participate in any such claim at its own
+expense.</p>
+
+<p>For example, a Contributor might include the Program in a commercial
+product offering, Product X. That Contributor is then a Commercial
+Contributor. If that Commercial Contributor then makes performance
+claims, or offers warranties related to Product X, those performance
+claims and warranties are such Commercial Contributor's responsibility
+alone. Under this section, the Commercial Contributor would have to
+defend claims against the other Contributors related to those
+performance claims and warranties, and if a court requires any other
+Contributor to pay any damages as a result, the Commercial Contributor
+must pay those damages.</p>
+
+<p><b>5. NO WARRANTY</b></p>
+
+<p>EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS
+PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS
+OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION,
+ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY
+OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely
+responsible for determining the appropriateness of using and
+distributing the Program and assumes all risks associated with its
+exercise of rights under this Agreement , including but not limited to
+the risks and costs of program errors, compliance with applicable laws,
+damage to or loss of data, programs or equipment, and unavailability or
+interruption of operations.</p>
+
+<p><b>6. DISCLAIMER OF LIABILITY</b></p>
+
+<p>EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT
+NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING
+WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR
+DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED
+HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.</p>
+
+<p><b>7. GENERAL</b></p>
+
+<p>If any provision of this Agreement is invalid or unenforceable under
+applicable law, it shall not affect the validity or enforceability of
+the remainder of the terms of this Agreement, and without further action
+by the parties hereto, such provision shall be reformed to the minimum
+extent necessary to make such provision valid and enforceable.</p>
+
+<p>If Recipient institutes patent litigation against any entity
+(including a cross-claim or counterclaim in a lawsuit) alleging that the
+Program itself (excluding combinations of the Program with other
+software or hardware) infringes such Recipient's patent(s), then such
+Recipient's rights granted under Section 2(b) shall terminate as of the
+date such litigation is filed.</p>
+
+<p>All Recipient's rights under this Agreement shall terminate if it
+fails to comply with any of the material terms or conditions of this
+Agreement and does not cure such failure in a reasonable period of time
+after becoming aware of such noncompliance. If all Recipient's rights
+under this Agreement terminate, Recipient agrees to cease use and
+distribution of the Program as soon as reasonably practicable. However,
+Recipient's obligations under this Agreement and any licenses granted by
+Recipient relating to the Program shall continue and survive.</p>
+
+<p>Everyone is permitted to copy and distribute copies of this
+Agreement, but in order to avoid inconsistency the Agreement is
+copyrighted and may only be modified in the following manner. The
+Agreement Steward reserves the right to publish new versions (including
+revisions) of this Agreement from time to time. No one other than the
+Agreement Steward has the right to modify this Agreement. The Eclipse
+Foundation is the initial Agreement Steward. The Eclipse Foundation may
+assign the responsibility to serve as the Agreement Steward to a
+suitable separate entity. Each new version of the Agreement will be
+given a distinguishing version number. The Program (including
+Contributions) may always be distributed subject to the version of the
+Agreement under which it was received. In addition, after a new version
+of the Agreement is published, Contributor may elect to distribute the
+Program (including its Contributions) under the new version. Except as
+expressly stated in Sections 2(a) and 2(b) above, Recipient receives no
+rights or licenses to the intellectual property of any Contributor under
+this Agreement, whether expressly, by implication, estoppel or
+otherwise. All rights in the Program not expressly granted under this
+Agreement are reserved.</p>
+
+<p>This Agreement is governed by the laws of the State of New York and
+the intellectual property laws of the United States of America. No party
+to this Agreement will bring a legal action under this Agreement more
+than one year after the cause of action arose. Each party waives its
+rights to a jury trial in any resulting litigation.</p>
+
+</body>
+
+</html>
diff --git a/source/lux.lux b/source/lux.lux index 91e00d317..04f9df811 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -122,6 +122,7 @@ #Nil])]))]) #Nil)))])])) (_lux_export Bindings) +(_lux_declare-tags [#counter #mappings]) ## (deftype (Env k v) ## (& #name Text @@ -143,6 +144,7 @@ (#BoundT "v")]) #Nil])])])]))])])) (_lux_export Env) +(_lux_declare-tags [#name #inner-closures #locals #closure]) ## (deftype Cursor ## (, Text Int Int)) @@ -243,19 +245,19 @@ (#Cons [(#BoundT "a") #Nil])]))])])])])) -## (deftype Reader +## (deftype Source ## (List (Meta Cursor Text))) -(_lux_def Reader +(_lux_def Source (#AppT [List (#AppT [(#AppT [Meta Cursor]) Text])])) -(_lux_export Reader) +(_lux_export Source) -## (deftype HostState +## (deftype Host ## (& #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader) ## #classes (^ clojure.lang.Atom))) -(_lux_def HostState +(_lux_def Host (#RecordT (#Cons [## "lux;writer" (#DataT "org.objectweb.asm.ClassWriter") (#Cons [## "lux;loader" @@ -263,6 +265,7 @@ (#Cons [## "lux;classes" (#DataT "clojure.lang.Atom") #Nil])])]))) +(_lux_declare-tags [#writer #loader #classes]) ## (deftype (DefData' m) ## (| (#TypeD Type) @@ -283,6 +286,7 @@ Ident #Nil])])])]))])) (_lux_export DefData') +(_lux_declare-tags [#TypeD #ValueD #MacroD #AliasD]) ## (deftype LuxVar ## (| (#Local Int) @@ -294,6 +298,7 @@ Ident #Nil])]))) (_lux_export LuxVar) +(_lux_declare-tags [#Local #Global]) ## (deftype (Module Compiler) ## (& #module-aliases (List (, Text Text)) @@ -323,44 +328,46 @@ #Nil)))]) #Nil])])])]))])) (_lux_export Module) +(_lux_declare-tags [#module-aliases #defs #imports #tags]) ## (deftype #rec Compiler -## (& #source Reader +## (& #source Source +## #cursor Cursor ## #modules (List (, Text (Module Compiler))) ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) -## #host HostState +## #expected Type ## #seed Int ## #eval? Bool -## #expected Type -## #cursor Cursor +## #host Host ## )) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [## "lux;source" - Reader - (#Cons [## "lux;modules" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))]) - (#Cons [## "lux;envs" - (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) - (#Cons [## "lux;types" - (#AppT [(#AppT [Bindings Int]) Type]) - (#Cons [## "lux;host" - HostState - (#Cons [## "lux;seed" - Int - (#Cons [## "lux;eval?" - Bool - (#Cons [## "lux;expected" - Type - (#Cons [## "lux;cursor" - Cursor + Source + (#Cons [## "lux;cursor" + Cursor + (#Cons [## "lux;modules" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))]) + (#Cons [## "lux;envs" + (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) + (#Cons [## "lux;types" + (#AppT [(#AppT [Bindings Int]) Type]) + (#Cons [## "lux;expected" + Type + (#Cons [## "lux;seed" + Int + (#Cons [## "lux;eval?" + Bool + (#Cons [## "lux;host" + Host #Nil])])])])])])])])]))]) Void])) (_lux_export Compiler) +(_lux_declare-tags [#source #cursor #modules #envs #types #expected #seed #eval? #host]) ## (deftype Macro ## (-> (List AST) (StateE Compiler (List AST)))) @@ -1016,18 +1023,19 @@ (def''' Monad Type (All' [m] - (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] - ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))])))) + (#RecordT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) + (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b)))))))) +(_lux_declare-tags [#return #bind]) (def''' Maybe/Monad ($' Monad Maybe) - {#lux;return + {#return (lambda' return [x] (#Some x)) - #lux;bind + #bind (lambda' [f ma] (_lux_case ma #None #None @@ -1035,12 +1043,12 @@ (def''' Lux/Monad ($' Monad Lux) - {#lux;return + {#return (lambda' [x] (lambda' [state] (#Right [state x]))) - #lux;bind + #bind (lambda' [f ma] (lambda' [state] (_lux_case (ma state) @@ -1073,12 +1081,12 @@ (defmacro (do tokens) (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) + (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] (let' [[var value] binding] (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) + (#Meta _ (#TagS "" "let")) (`' (;let' (~ value) (~ body'))) _ @@ -1108,11 +1116,11 @@ #Nil (wrap #Nil) - (#Cons [x xs']) + (#Cons x xs') (do m [y (f x) ys (map% m f xs')] - (wrap (#Cons [y ys]))) + (wrap (#Cons y ys))) ))) (def''' (. f g) @@ -1385,6 +1393,10 @@ (#Cons [[k' v] dict']) (#Cons [[k' v'] (put k v dict')])))) +(def''' (->text x) + (-> (^ java.lang.Object) Text) + (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) + (def''' (get-module-name state) ($' Lux Text) (_lux_case state @@ -1405,7 +1417,7 @@ ($' Maybe Macro)) (do Maybe/Monad [$module (get module modules) - gdef (let' [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] + gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags} (_lux_: ($' Module Compiler) $module)] (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] @@ -1432,7 +1444,7 @@ #envs envs #types types #host host #seed seed #eval? eval? #expected expected #cursor cursor} - (#Right [state (find-macro' modules current-module module name)])))))) + (#Right state (find-macro' modules current-module module name))))))) (def''' (list:join xs) (All [a] @@ -1494,10 +1506,6 @@ (as-pairs tokens))] (wrap (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) -(def''' (->text x) - (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) - (def''' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) @@ -2508,7 +2516,7 @@ (if export? (list name) (list))))) - (let [{#module-aliases _ #defs defs #imports _} =module] + (let [{#module-aliases _ #defs defs #imports _ #tags tags} =module] defs))] (#Right state (list:join to-alias))) @@ -2721,7 +2729,7 @@ #None #None - (#Some {#defs defs #module-aliases _ #imports _}) + (#Some {#defs defs #module-aliases _ #imports _ #tags tags}) (case (get v-name defs) #None #None @@ -2742,7 +2750,7 @@ ## #seed seed #eval? eval? #expected expected} state] ## (do Maybe/Monad ## [module (get v-prefix modules) -## #let [{#defs defs #module-aliases _ #imports _} module] +## #let [{#defs defs #module-aliases _ #imports _ #tags tags} module] ## def (get v-name defs) ## #let [[_ def-data] def]] ## (case def-data diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 58c01e642..fe1e0d55b 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -21,7 +21,6 @@ "text" "variant" "tuple" - "record" "apply" "case" "lambda" diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6992c11a3..34cbf8b48 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -14,7 +14,8 @@ [type :as &type]) (lux.analyser [base :as &&] [env :as &env] - [module :as &module]))) + [module :as &module] + [record :as &&record]))) ;; [Tags] (deftags "" @@ -25,7 +26,6 @@ "CharTotal" "TextTotal" "TupleTotal" - "RecordTotal" "VariantTotal" ) @@ -37,7 +37,6 @@ "CharTestAC" "TextTestAC" "TupleTestAC" - "RecordTestAC" "VariantTestAC" ) @@ -194,33 +193,25 @@ _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - (&/$RecordS ?slots) - (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] + (&/$RecordS pairs) + (|do [?members (&&record/order-record pairs) + ;; :let [_ (prn 'PRE (&type/show-type value-type))] value-type* (adjust-type value-type) ;; :let [_ (prn 'POST (&type/show-type value-type*))] ;; value-type* (resolve-type value-type) ] (|case value-type* - (&/$RecordT ?slot-types) - (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) - (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* slot] - (|let [[sn sv] slot] - (|case sn - (&/$Meta _ (&/$TagS ?ident)) - (|do [=ident (&&/resolved-ident ?ident) - :let [=tag (&/ident->text =ident)]] - (if-let [=slot-type (&/|get =tag ?slot-types)] - (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] - (return (&/T (&/|put =tag =test =tests) =kont))) - (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) - - _ - (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) + (&/$RecordT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) (|do [=kont kont] - (return (&/T (&/|table) =kont))) - (&/|reverse ?slots))] - (return (&/T (&/V $RecordTestAC =tests) =kont)))) + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) _ (fail "[Pattern-matching Error] Record requires record-type."))) @@ -320,34 +311,6 @@ (return (&/V $TupleTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [($DefaultTotal total?) ($RecordTestAC ?tests)] - (|do [structs (&/map% (fn [t] - (|let [[slot value] t] - (|do [struct* (merge-total (&/V $DefaultTotal total?) (&/T value ?body))] - (return (&/T slot struct*))))) - (->> ?tests - &/->seq - (sort compare-kv) - &/->list))] - (return (&/V $RecordTotal (&/T total? structs)))) - - [($RecordTotal total? ?values) ($RecordTestAC ?tests)] - (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map2% (fn [left right] - (|let [[lslot sub-struct] left - [rslot value]right] - (if (.equals ^Object lslot rslot) - (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] - (return (&/T lslot sub-struct*))) - (fail "[Pattern-matching Error] Record slots mismatch.")))) - ?values - (->> ?tests - &/->seq - (sort compare-kv) - &/->list))] - (return (&/V $RecordTotal (&/T total? structs)))) - (fail "[Pattern-matching Error] Inconsistent record-size.")) - [($DefaultTotal total?) ($VariantTestAC ?tag ?test)] (|do [sub-struct (merge-total (&/V $DefaultTotal total?) (&/T ?test ?body))] @@ -361,6 +324,7 @@ )))) (defn ^:private check-totality [value-type struct] + ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct ($BoolTotal ?total ?values) (return (or ?total @@ -389,14 +353,6 @@ ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) - _ - (fail "[Pattern-maching Error] Tuple is not total.")))) - - ($RecordTotal ?total ?structs) - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* (&/$RecordT ?members) (|do [totals (&/map2% (fn [sub-struct ?member] (check-totality ?member sub-struct)) @@ -404,7 +360,7 @@ (return (&/fold #(and %1 %2) true totals))) _ - (fail "[Pattern-maching Error] Record is not total.")))) + (fail "[Pattern-maching Error] Tuple is not total.")))) ($VariantTotal ?total ?structs) (if ?total @@ -422,6 +378,10 @@ ($DefaultTotal ?total) (return ?total) + + ;; _ + ;; (assert false (prn-str 'check-totality (&type/show-type value-type) + ;; (&/adt->text struct))) )) ;; [Exports] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 614b38799..4e9dcd79f 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,28 +15,28 @@ ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] ;; (prn 'with-local name) - (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) - =return (body (&/update$ &/$ENVS + (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$envs (fn [stack] - (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))] - (&/|cons (&/update$ &/$LOCALS #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) (&/|head stack)) (&/|tail stack)))) state))] (|case =return (&/$Right ?state ?value) - (return* (&/update$ &/$ENVS (fn [stack*] - (&/|cons (&/update$ &/$LOCALS #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS old-mappings)) + (return* (&/update$ &/$envs (fn [stack*] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) (&/|head stack*)) (&/|tail stack*))) ?state) @@ -47,4 +47,4 @@ (def captured-vars (fn [state] - (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 91cf3443b..aeb5a4814 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -27,10 +27,10 @@ (defn close-over [scope name register frame] (|let [[_ register-type] register register* (&/T (&/V &&/$captured (&/T scope - (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) register)) register-type)] - (&/T register* (&/update$ &/$CLOSURE #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) + (&/T register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index e55d5fec8..449ef59c1 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -18,7 +18,8 @@ [lambda :as &&lambda] [case :as &&case] [env :as &&env] - [module :as &&module]))) + [module :as &&module] + [record :as &&record]))) (defn ^:private analyse-1+ [analyse ?token] (&type/with-var @@ -124,7 +125,7 @@ ;; (fn [$var] ;; (|do [exo-type** (&type/apply-type exo-type* $var)] ;; (analyse-variant analyse exo-type** ident ?values)))) - + ;; _ ;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) @@ -150,26 +151,14 @@ (return ?table) _ - (fail (str "[Analyser Error] The type of a record must be a record type:\n" - (&type/show-type exo-type*) - "\n"))) + (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) _ (&/assert! (= (&/|length types) (&/|length ?elems)) (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) - =slots (&/map% (fn [kv] - (|case kv - [(&/$Meta _ (&/$TagS ?ident)) ?value] - (|do [=ident (&&/resolved-ident ?ident) - :let [?tag (&/ident->text =ident)] - slot-type (if-let [slot-type (&/|get ?tag types)] - (return slot-type) - (fail (str "[Analyser Error] Record type does not have slot: " ?tag))) - =value (&&/analyse-1 analyse slot-type ?value)] - (return (&/T ?tag =value))) - - _ - (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) - ?elems)] - (return (&/|list (&/T (&/V &&/$record =slots) (&/V &/$RecordT exo-type)))))) + members (&&record/order-record ?elems) + =members (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + types members)] + (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -193,9 +182,9 @@ (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/get$ &/$ENVS state) - no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not) - (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) + (|let [stack (&/get$ &/$envs state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -204,8 +193,8 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global [(&/$Global ?module* name*) _] @@ -235,21 +224,21 @@ (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) - (&/|map #(&/get$ &/$NAME %) outer) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get name))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) _ (&type/check exo-type btype)] (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state)))) + (&/set$ &/$envs (&/|++ inner* outer) state)))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -311,13 +300,14 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= "<>" r-name) + ;; :let [_ (when (or (= ":" (aget real-name 1)) + ;; (= "type" (aget real-name 1)) ;; ;; (= &&/$struct r-name) ;; ) - ;; (->> (&/|map &/show-ast macro-expansion*) + ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn (str r-module ";" r-name))))] + ;; (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 68554a019..6cf25b738 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -11,23 +11,23 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return return* fail fail* |case]] + (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] - [host :as &host]) - [lux.analyser.base :as &&])) + [host :as &host]))) ;; [Utils] -(def ^:private $DEFS 0) -(def ^:private $IMPORTS 1) -(def ^:private $ALIASES 2) -(def ^:private $tags 3) +(deftags "" + "module-aliases" + "defs" + "imports" + "tags") (def ^:private +init+ - (&/R ;; "lux;defs" + (&/R ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" (&/|table) ;; "lux;imports" (&/|list) - ;; "lux;module-aliases" - (&/|table) ;; "lux;tags" (&/|list) )) @@ -37,24 +37,24 @@ "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [ms] (&/|update current-module - (fn [m] (&/update$ $IMPORTS (partial &/|cons module) m)) + (fn [m] (&/update$ $imports (partial &/|cons module) m)) ms)) state) nil)))) (defn define [module name def-data type] (fn [state] - (|case (&/get$ &/$ENVS state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T false def-data) %) m)) ms)))) @@ -66,8 +66,8 @@ (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] - (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _)] (return* state &type/Type) @@ -87,14 +87,14 @@ (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (|case (&/get$ &/$ENVS state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update a-module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) m)) ms)))) @@ -107,15 +107,15 @@ "(-> Text (Lux Bool))" (fn [state] (return* state - (->> state (&/get$ &/$MODULES) (&/|contains? name))))) + (->> state (&/get$ &/$modules) (&/|contains? name))))) (defn alias [module alias reference] (fn [state] (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update module - #(&/update$ $ALIASES + #(&/update$ $module-aliases (fn [aliases] (&/|put alias reference aliases)) %) @@ -125,7 +125,7 @@ (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/get$ &/$MODULES) (&/|get current-module) (&/get$ $ALIASES) (&/|get name))] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) @@ -133,9 +133,9 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) @@ -158,7 +158,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] (if-let [$def (&/|get name $module)] (|case $def [exported? (&/$ValueD ?type _)] @@ -168,11 +168,11 @@ (.getField "_datum") (.get nil))]] (fn [state*] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [$modules] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) m)) $modules)) @@ -190,18 +190,18 @@ (defn export [module name] (fn [state] - (|case (&/get$ &/$ENVS state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] + (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] (|case $def [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) [false ?data] (return* (->> state - (&/update$ &/$MODULES (fn [ms] + (&/update$ &/$modules (fn [ms] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T true ?data) %) m)) ms)))) @@ -230,30 +230,30 @@ _ (&/T ?exported? k "V"))))) - (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) (defn create-module [name] "(-> Text (Lux (,)))" (fn [state] - (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil))) + (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/update$ &/$MODULES #(&/|put name +init+ %)) - (&/set$ &/$ENVS (&/|list (&/env name)))) + (&/update$ &/$modules #(&/|put name +init+ %)) + (&/set$ &/$envs (&/|list (&/env name)))) nil))) (defn tags-by-module [module] "(-> Text (Lux (List (, Text (, Int (List Text))))))" (fn [state] - (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (return* state (&/get$ $tags =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) @@ -261,9 +261,9 @@ (defn declare-tags [module tag-names] "(-> Text (List Text) (Lux (,)))" (fn [state] - (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [=modules] (&/|update module #(&/set$ $tags (&/fold (fn [table idx+tag-name] @@ -280,8 +280,17 @@ (defn tag-index [module tag-name] "(-> Text Text (Lux Int))" (fn [state] - (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] (return* state (aget idx+tags 0)) - (fail* (str "[Lux Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) - (fail* (str "[Lux Error] Unknown module: " module))))) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + +(defn tag-group [module tag-name] + "(-> Text Text (Lux (List Ident)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 1)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj new file mode 100644 index 000000000..2b4b7e095 --- /dev/null +++ b/src/lux/analyser/record.clj @@ -0,0 +1,158 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.analyser.record + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [deftags |let |do return fail |case]]) + (lux.analyser [base :as &&] + [module :as &&module]))) + +;; [Tags] +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) + +;; [Exports] +(defn order-record [pairs] + "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" + (|do [tag-group (|case pairs + (&/$Nil) + (return (&/|list)) + + (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) + (|do [[module name] (&&/resolved-ident tag1)] + (&&module/tag-group module name)) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + =pairs (&/map% (fn [kv] + (|case kv + [(&/$Meta _ (&/$TagS k)) v] + (|do [=k (&&/resolved-ident k)] + (return (&/T (&/ident->text =k) v))) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) + pairs)] + (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (fail (str "[Analyser Error] Unknown tag: " tag)))) + (&/|map &/ident->text tag-group)))) diff --git a/src/lux/base.clj b/src/lux/base.clj index a700a30c8..b8b7118f4 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -63,30 +63,34 @@ ;; [Fields] ;; Binding -(def $COUNTER 0) -(def $MAPPINGS 1) +(deftags "" + "counter" + "mappings") ;; Env -(def $CLOSURE 0) -(def $INNER-CLOSURES 1) -(def $LOCALS 2) -(def $NAME 3) +(deftags "" + "name" + "inner-closures" + "locals" + "closure") ;; Host -(def $CLASSES 0) -(def $LOADER 1) -(def $WRITER 2) +(deftags "" + "writer" + "loader" + "classes") ;; Compiler -(def $cursor 0) -(def $ENVS 1) -(def $EVAL? 2) -(def $EXPECTED 3) -(def $HOST 4) -(def $MODULES 5) -(def $SEED 6) -(def $SOURCE 7) -(def $TYPES 8) +(deftags "" + "source" + "cursor" + "modules" + "envs" + "types" + "expected" + "seed" + "eval?" + "host") ;; Vars (deftags "lux;" @@ -533,11 +537,11 @@ (def loader (fn [state] - (return* state (->> state (get$ $HOST) (get$ $LOADER))))) + (return* state (->> state (get$ $host) (get$ $loader))))) (def classes (fn [state] - (return* state (->> state (get$ $HOST) (get$ $CLASSES))))) + (return* state (->> state (get$ $host) (get$ $classes))))) (def +init-bindings+ (R ;; "lux;counter" @@ -546,14 +550,14 @@ (|table))) (defn env [name] - (R ;; "lux;closure" - +init-bindings+ + (R ;; "lux;name" + name ;; "lux;inner-closures" 0 ;; "lux;locals" +init-bindings+ - ;; "lux;name" - name + ;; "lux;closure" + +init-bindings+ )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String @@ -576,32 +580,32 @@ (defn host [_] (let [store (atom {})] - (R ;; "lux;classes" - store + (R ;; "lux;writer" + (V $None nil) ;; "lux;loader" (memory-class-loader store) - ;; "lux;writer" - (V $None nil)))) + ;; "lux;classes" + store))) (defn init-state [_] - (R ;; "lux;cursor" + (R ;; "lux;source" + (V $None nil) + ;; "lux;cursor" (T "" -1 -1) + ;; "lux;modules" + (|table) ;; "lux;envs" (|list) - ;; "lux;eval?" - false + ;; "lux;types" + +init-bindings+ ;; "lux;expected" (V $VariantT (|list)) - ;; "lux;host" - (host nil) - ;; "lux;modules" - (|table) ;; "lux;seed" 0 - ;; "lux;source" - (V $None nil) - ;; "lux;types" - +init-bindings+ + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) )) (defn save-module [body] @@ -609,8 +613,8 @@ (|case (body state) ($Right state* output) (return* (->> state* - (set$ $ENVS (get$ $ENVS state)) - (set$ $SOURCE (get$ $SOURCE state))) + (set$ $envs (get$ $envs state)) + (set$ $source (get$ $source state))) output) ($Left msg) @@ -618,20 +622,20 @@ (defn with-eval [body] (fn [state] - (|case (body (set$ $EVAL? true state)) + (|case (body (set$ $eval? true state)) ($Right state* output) - (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) + (return* (set$ $eval? (get$ $eval? state) state*) output) ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state (get$ $EVAL? state)))) + (return* state (get$ $eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] + (let [writer* (->> state (get$ $host) (get$ $writer))] (|case writer* ($Some datum) (return* state datum) @@ -641,15 +645,15 @@ (def get-top-local-env (fn [state] - (try (let [top (|head (get$ $ENVS state))] + (try (let [top (|head (get$ $envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed (get$ $SEED state)] - (return* (set$ $SEED (inc seed) state) seed)))) + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) (defn ->seq [xs] (|case xs @@ -671,19 +675,19 @@ (def get-module-name (fn [state] - (|case (|reverse (get$ $ENVS state)) + (|case (|reverse (get$ $envs state)) ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") ($Cons ?global _) - (return* state (get$ $NAME ?global))))) + (return* state (get$ $name ?global))))) (defn with-scope [name body] (fn [state] - (let [output (body (update$ $ENVS #(|cons (env name) %) state))] + (let [output (body (update$ $envs #(|cons (env name) %) state))] (|case output ($Right state* datum) - (return* (update$ $ENVS |tail state*) datum) + (return* (update$ $envs |tail state*) datum) _ output)))) @@ -693,23 +697,23 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top (get$ $INNER-CLOSURES) str)))] + (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $ENVS #(|cons (update$ $INNER-CLOSURES inc (|head %)) + (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) (|tail %)) state)))))) (def get-scope-name (fn [state] - (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse)))) + (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $HOST #(set$ $WRITER (V $Some writer) %) state))] + (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state) + (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) ?value) _ @@ -718,10 +722,10 @@ (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] - (let [output (body (set$ $EXPECTED type state))] + (let [output (body (set$ $expected type state))] (|case output ($Right ?state ?value) - (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) + (return* (set$ $expected (get$ $expected state) ?state) ?value) _ @@ -852,7 +856,7 @@ (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys (get$ $MODULES state))))) + (return* state (|keys (get$ $modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" @@ -884,3 +888,9 @@ ["" name] (|do [module get-module-name] (return (T module name))) _ (return ident))) + +(defn ident= [x y] + (|let [[xmodule xname] x + [ymodule yname] y] + (and (= xmodule ymodule) + (= xname yname)))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 7622e3002..1814a97c0 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -58,9 +58,6 @@ (&a/$tuple ?elems) (&&lux/compile-tuple compile-expression ?type ?elems) - (&a/$record ?elems) - (&&lux/compile-record compile-expression ?type ?elems) - (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) @@ -426,7 +423,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state)) + (&/set$ &/$source (&reader/from file-name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 742ac69d8..85488553c 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -58,7 +58,7 @@ (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index b108d463c..4d8ac2190 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -102,29 +102,6 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$RecordTestAC ?slots) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (-> (doto (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)) - (.visitInsn Opcodes/AALOAD) - (compile-match test $next $sub-else) - (.visitLabel $sub-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $next)) - (->> (|let [[idx [_ test]] idx+member - $next (new Label) - $sub-else (new Label)]) - (doseq [idx+member (->> ?slots - &/->seq - (sort compare-kv) - &/->list - &/enumerate - &/->seq)]))) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$VariantTestAC ?tag ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 9baefa21c..e2b9f0e89 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -72,27 +72,6 @@ (&/|range num-elems) ?elems)] (return nil))) -(defn compile-record [compile *type* ?elems] - (|do [^MethodVisitor *writer* &/get-writer - :let [elems* (->> ?elems - &/->seq - (sort #(compare (&/|first %1) (&/|first %2))) - &/->list) - num-elems (&/|length elems*) - _ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx kv] - (|let [[k v] kv] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile v) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret)))) - (&/|range num-elems) elems*)] - (return nil))) - (defn compile-variant [compile *type* ?tag ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 6aa8cca6d..e0195658f 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -21,7 +21,7 @@ ;; [Utils] (defn ^:private with-line [body] (fn [state] - (|case (&/get$ &/$SOURCE state) + (|case (&/get$ &/$source state) (&/$Nil) (fail* "[Reader Error] EOF") @@ -32,19 +32,19 @@ (fail* msg) ($Done output) - (return* (&/set$ &/$SOURCE more state) + (return* (&/set$ &/$source more state) output) ($Yes output line*) - (return* (&/set$ &/$SOURCE (&/|cons line* more) state) + (return* (&/set$ &/$source (&/|cons line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (|case (body (&/get$ &/$SOURCE state)) + (|case (body (&/get$ &/$source state)) (&/$Right reader* match) - (return* (&/set$ &/$SOURCE reader* state) + (return* (&/set$ &/$source reader* state) match) (&/$Left msg) diff --git a/src/lux/type.clj b/src/lux/type.clj index 94b0fbc5e..92c986985 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -209,12 +209,12 @@ (Tuple$ (&/|list (Bound$ "s") (Bound$ "a")))))))) -(def Reader +(def Source (App$ List (App$ (App$ Meta Cursor) Text))) -(def HostState +(def Host (Record$ (&/|list ;; "lux;writer" @@ -274,7 +274,9 @@ (Record$ (&/|list ;; "lux;source" - Reader + Source + ;; "lux;cursor" + Cursor ;; "lux;modules" (App$ List (Tuple$ (&/|list Text (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) @@ -284,16 +286,14 @@ (Tuple$ (&/|list LuxVar Type)))) ;; "lux;types" (App$ (App$ Bindings Int) Type) - ;; "lux;host" - HostState + ;; "lux;expected" + Type ;; "lux;seed" Int ;; "lux;eval?" Bool - ;; "lux;expected" - Type - ;; "lux;cursor" - Cursor + ;; "lux;host" + Host ))) $Void)) @@ -304,7 +304,7 @@ (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (if-let [type (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -315,7 +315,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (if-let [type* (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -326,26 +326,26 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (if-let [tvar (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V &/$Some type) %) + (return* (&/update$ &/$types (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) ts)) state) nil)) - (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length)))))) + (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$types) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + (let [id (->> state (&/get$ &/$types) (&/get$ &/$counter))] + (return* (&/update$ &/$types #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) state) id)))) @@ -380,11 +380,11 @@ (|do [?type** (clean* id ?type*)] (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] + (->> state (&/get$ &/$types) (&/get$ &/$mappings)))] (fn [state] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS (&/|remove id mappings*))) + (return* (&/update$ &/$types #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings (&/|remove id mappings*))) state) nil))) state)))) |