Commits

ariovistus committed 01236e6

working on a better type equality

  • Participants
  • Parent commits 0170e49

Comments (0)

Files changed (3)

src/org/d/compiler/ast_utils.clj

   generated expression returns true if ast referenced by sym does not 
   match matcher specification tok"
   [sym tok]
+  ; these are some stupid things that one might conceivably send to matcher
   (assert (not (contains? tok ''s)))
   (assert (not (contains? tok ''t)))
   (cond (symbol? tok)
                         `(= (nil? (.getFirstChild ~sym)) ~(get tok 'ch?)))
                       (when (contains? tok 'sib?)
                         `(= (nil? (.getNextSibling ~sym)) ~(get tok 'sib?)))
+                      (when (contains? tok 'attr?)
+                        `(not (attr? ~sym (quote ~(get tok 'attr?)))))
+                      (when (contains? tok 'type)
+                        `(or (not (attr? ~sym ~''type)) 
+                             (not (~'=t= (attr ~sym ~''type) 
+                                      ~(get tok 'type)))))
                       (when (contains? tok 'nch)
                         `(not (= (.getNumberOfChildren ~sym) ~(get tok 'nch)))))
               ]
   (let [cnd1 `(nil? ~sym)
         cnd2 (if (contains? tok 't?) 
                `(not (= (.getType ~sym) (. D2ParserTokenTypes ~(get tok 't?)))) 
-               nil)]
+               nil)
+        cnd3 (when (contains? tok 'type)
+               `(or (not (attr? ~sym ~''type)) 
+                    (not (~'=t= (attr ~sym ~''type) ~(get tok 'type))))) 
+        cnd4 (when (contains? tok 'attr?)
+               `(not (attr? ~sym ~(get tok 'attr?)))) ]
     (if (nil? cnd2) cnd1
-      `(or ~cnd1 ~cnd2))))
+      `(or ~cnd1 ~cnd2 ~cnd3 ~cnd4))))
 
 (defn syms 
   "generate a list of the form (symbol1 exp1 symbol2 exp2 ...)
   meant to bind values to the symbols per a terminal specification"
   [sym tok] 
   (if (symbol? tok) ()
-    (do
+    (let [type-syms (if (contains? tok 'type/?->) 
+                      (let [tsym (get tok 'type/?->)]
+                        `(~tsym (cond ~(cond2 sym tok) nil 
+                                      (attr? ~sym ~'type) (attr ~sym ~'type) 
+                                      true nil)
+                            ~(symbol (str tsym "?")) 
+                            (cond ~(cond2 sym tok) false 
+                                  (attr? ~sym 'type) true
+                                  true false))
+                        ()))]
+
       (when (and (map? tok) (or (contains? tok 'ast/?->) 
                                 (contains? tok 'ast?->))) 
         (assert (not (contains? tok 't))))
       (assert (not (and (contains? tok 't) (contains? tok 't?))))
       (if (spec-optional? tok)
         (concat
+          type-syms
           (when (contains? tok 'ast/?->)
             (let [sym2 (get tok 'ast/?->)
                   sym2? (symbol (str sym2 "?"))]
           (when (contains? tok 's->) 
             `(~(get tok 's->) (if ~(cond2 sym tok) nil (.getText ~sym)))))
         (concat 
+          type-syms
           (when (contains? tok 't->) `(~(get tok 't->) (.getType ~sym)))
           (when (contains? tok 's->) `(~(get tok 's->) (.getText ~sym)))
           (when (contains? tok 'ast->) `(~(get tok 'ast->) ~sym)))))))
   ch? BOOL predicates on whether the ast node has children
   sib? BOOL predicates on whether the ast node has siblings
   nch INT predicates on the number of children
+  type TYPE predicates on whether the ast node has a type and the type
+  is equivalent to TYPE
+  type/?-> SYMBOL where the type of the ast will bind to SYMBOL if it
+  exists, and SYMBOL? will report whether the ast has a type
+  attr? SYMBOL predicates on whether the ast node has attribute SYMBOL
 
   Note that there is an implied '.*' at the end of each specification
   list. 

src/org/d/compiler/d_type.clj

   "special identifiers used here: __auto - signals a to-be-deduced type for
   d2 auto functions
   ast attributes used here:
+  't-ok - receipt that type is generally ready for semantic analysis. This
+  entails (1) type is normalized (2) values (e.g. static array lengths) are
+  computed (3) typeof's have been expanded (4??) user defined types are 
+  absolutely referenced
   "
   (:import 
     (org.d.model Type MyAST Visitor2 Visitor2$State)
         tupl (make-ast! (TUPLE {ast (first elts2)}))]
     tupl))
 
+(defn t-ok? 
+  "this is a specification for everything (I hope..) required of a 
+  type ast so that it may be {copied, compared} without trouble"
+  [ast state]
+  (cond (attr? ast 't-ok) true
+        (error? ast) false
+        true (match-case ast
+                         (POINTER {ast-> t1 attr? t-ok}) true
+                         (DARRAY_DECL {ast-> t1 attr? t-ok}) true
+                         (SARRAY_DECL {ast-> t1 attr? t-ok} 
+                                      {t IntegerLiteral ast-> e1})
+                         (and (not (error? e1))
+                              (attr? e1 'value)
+                              (<= 0 (attr e1 'value)))
+                         (AARRAY_DECL {ast-> vt} {ast-> kt attr? t-ok}) true
+                         (DELEGATE {ast-> t1 attr? t-ok} {t PARAMETERS ast-> p} 
+                                   {t? POSTFIX ast/?-> pf})
+                         (all #(matches-any?  % 
+                                             (PARAMETER 
+                                               {t? PARAM_MODIFIER}
+                                               {attr? t-ok}) 
+                                             (PARAMETER Vararg))
+                                   (children p))
+                         (FUNCTION {ast-> t1 attr? t-ok} {t PARAMETERS ast-> p} 
+                                   {t? POSTFIX ast/?-> pf})
+                         (all #(matches-any?  % 
+                                             (PARAMETER 
+                                               {t? PARAM_MODIFIER}
+                                               {attr? t-ok}) 
+                                             (PARAMETER Vararg))
+                                   (children p))
+                         (PARAM_SPEC {ast-> t1 attr? t-ok} 
+                                     {t PARAMETERS ast-> p}
+                                     {t? POSTFIX ast/?-> pf})
+                         (TUPLE {ast-> t1})
+                         (all #(attr? % t-ok) (ast&siblings t1))
+                         (TYPE_MOD {ast-> t1 attr? t-ok} {}) true
+                         ; rewrite slice type to an actual tuple type
+                         (SLICE_TYPE) false
+                         ; rewrite typeof to an actual type
+                         (BASIC_TYPE Typeof) false
+                         ; rewrite .idlist to absolute id list
+                         (BASIC_TYPE Dot) false
+                         ; todo: symbol lookup!
+                         (BASIC_TYPE ID_LIST) false
+                         ; todo: check its a built in type
+                         (BASIC_TYPE) true
+                         false
+                         )))
         
 
-(defn =t= 
+#_(defn =t= 
   "type equality"
   [a1 a2] 
-  (Type/equals a1 a2))
+  (loop [t1 a1 t2 a2]
+    (cond 
+      (error? t1) 'error
+      (error? t2) 'error
+      (= (.getType t1) (.getType t2) (tok POINTER))
+      (recur (getch t1) (getch t2))
+      (= (.getType t1) (.getType t2) (tok DARRAY_DECL))
+      (recur (getch t1) (getch t2))
+      (= (.getType t1) (.getType t2) (tok SARRAY_DECL))
+      (match-case 
+        t1 (SARRAY_DECL {ast-> c1} {t IntegerLiteral ast-> e1})
+        (match-case t2 (SARRAY_DECL {ast-> c2} {t IntegerLiteral ast-> e2})
+                    (do
+                      (when (not (attr? e1 'value)) (type-ded e1 nil))
+                      (when (not (attr? e2 'value)) (type-ded e2 nil))
+                      (cond (error? e1) 'error
+                            (error? e2) 'error
+                            (and (attr  e1 'value)
+                                 (attr  e2 'value)
+                                 (= (attr e1 'value) (attr e2 'value)))
+                            (do (assert (attr? e1 'value))
+                              (assert (attr? e2 'value))
+                              (assert (attr e1 'value
+                              (recur c1 c2))
+                            true 'no)
+                    (if (and (attr? e1 'value) (attr? e2 'value)
+                             (= (attr e1 'value) (attr e2 'value)))
+                      (recur c1 c2)
+                      'unknown)))
+      (= (.getType t1) (.getType t2) (tok AARRAY_DECL))
+      (match-case t1 (AARRAY_DECL {ast-> k1} {ast-> v1})
+                  (match-case t2 (SARRAY_DECL {ast-> k2} {ast-> v2})
+                              (let [x (=t= k1 k2)]
+                                (cond (= x 'unknown) 'unknown
+                                      (= x 'yes) (recur v1 v2) 
+                                      (= x 'no) 'no))
+                              (if (and (attr? e1 'value) (attr? e2 'value))
+                                (recur c1 c2)
+                                'unknown)))
+      (matches? t1 (SLICE_TYPE))
+      (match-case t1 (SLICE_TYPE {t TUPLE ast-> tu} 
+                                 {t IntegerLiteral ast-> e1} 
+                                 {t IntegerLiteral ast-> e2})
+                  (when (not (attr? e1 'value)) (type-ded e1 nil))
+                  (when (not (attr? e2 'value)) (type-ded e2 nil))
+                  (cond (error? e1) 'error
+                        (error? e2) 'error
+                        true (let [si (attr e1 'value)
+                                   ei (attr e2 'value)]
+                               (if (and (<= 0 si ei (.getNumberOfChildren tu))
+                                        (< si ei))
+                                 (let [ch (take (- ei si) (drop si (children tu)))
+                                       chc (map cpTree ch)]
+                                   (recur (make-ast! (TUPLE {ast (first chc)})) t2))
+
+
+                  (SLICE_TYPE (BASIC_TYPE {t? Dot} ID_LIST))
+      (matches? t2 (SLICE_TYPE))
+      (= (.getType t1) (.getType t2) (tok AARRAY_DECL))
+      (and (not (= (.getType a1) (.getType a2) (tok BASIC_TYPE)))
+           (not (= (.getType a1) (.getType a2))))
+      false))))))))))
+      
+(defn =t= [a1 a2] (Type/equals a1 a2))
 
 (defn type? 
   "is ast a type (semantic type; not a raw type)?"

src/org/d/compiler/misc.clj

             ast
             (BASIC_TYPE ({t Typeof sib? false} {ast-> e})) e
             ;(TMIXIN_ID1 (Typeof {ast-> e})) e
-            ({t Dot exp? true} ({Typeof exp? true sib? true} {ast-> e})) e)]
+            ({t Dot exp? true} ({t Typeof exp? true sib? true} {ast-> e})) e)]
     (attr? e 'type)))
 
 (defn expand-typeof-rewrite! [ast state]
     (BASIC_TYPE (Typeof {ast-> e})) 
     (cpTree (attr e 'type))
     ({t Dot exp? true} 
-     ({Typeof exp? true ast-> ty} {ast-> e})
+     ({t Typeof exp? true ast-> ty} {ast-> e})
      {t Identifier ast-> i}) 
     (let [t (cpTree (attr e 'type))]
       (setch! ast t)
           (bazooka! parser v STRING))
         (=t= t WSTRING)
         (=t= t DSTRING))
-  )))
+  ))))
 
-(defn testb []
+(defn testb [])