diff options
| author | Your Name <agrawalshagun07@gmail.com> | 2025-03-16 02:00:40 +0530 |
|---|---|---|
| committer | Your Name <agrawalshagun07@gmail.com> | 2025-03-16 02:00:40 +0530 |
| commit | 0321df3708cfa4d1440faf3f407611df85484b4b (patch) | |
| tree | 8c23154afaf1afd78363eb0fa639edd5d8a32821 /src/cljcc/analyze | |
| parent | e458b2fadee1eaf0a6cf4ed4881da6f3f25acc21 (diff) | |
Refactor files to cljcc-compiler and cli tool.
Diffstat (limited to 'src/cljcc/analyze')
| -rw-r--r-- | src/cljcc/analyze/core.clj | 10 | ||||
| -rw-r--r-- | src/cljcc/analyze/label_loops.clj | 105 | ||||
| -rw-r--r-- | src/cljcc/analyze/resolve.clj | 300 | ||||
| -rw-r--r-- | src/cljcc/analyze/typecheck.clj | 537 |
4 files changed, 0 insertions, 952 deletions
diff --git a/src/cljcc/analyze/core.clj b/src/cljcc/analyze/core.clj deleted file mode 100644 index 793b667..0000000 --- a/src/cljcc/analyze/core.clj +++ /dev/null @@ -1,10 +0,0 @@ -(ns cljcc.analyze.core - (:require [cljcc.analyze.resolve :as r] - [cljcc.analyze.label-loops :as l] - [cljcc.analyze.typecheck :as t])) - -(defn validate [program] - (-> program - r/resolve-program - l/label-loops - t/typecheck)) diff --git a/src/cljcc/analyze/label_loops.clj b/src/cljcc/analyze/label_loops.clj deleted file mode 100644 index 56fffc9..0000000 --- a/src/cljcc/analyze/label_loops.clj +++ /dev/null @@ -1,105 +0,0 @@ -(ns cljcc.analyze.label-loops - (:require [cljcc.parser :as p] - [cljcc.exception :as exc] - [cljcc.analyze.resolve :as r] - [cljcc.schema :as s] - [cljcc.util :as util] - [malli.dev.pretty :as pretty])) - -(defn- unique-identifier [identifier] - (util/create-identifier! identifier)) - -(defn- annotate-label [m label] - (assoc m :label label)) - -(defn- label-statement - ([s] - (label-statement s nil)) - ([{:keys [statement-type] :as s} current-label] - (condp = statement-type - :break (if (nil? current-label) - (exc/analyzer-error "break statement outside of loop" s) - (p/break-statement-node current-label)) - :continue (if (nil? current-label) - (exc/analyzer-error "continue statement outside of loop" s) - (p/continue-statement-node current-label)) - :while (let [new-label (unique-identifier "while_label") - l-body (label-statement (:body s) new-label) - l-while (p/while-statement-node (:condition s) l-body)] - (annotate-label l-while new-label)) - :do-while (let [new-label (unique-identifier "do_while_label") - l-body (label-statement (:body s) new-label) - l-do-while (p/do-while-statement-node (:condition s) l-body)] - (annotate-label l-do-while new-label)) - :for (let [new-label (unique-identifier "for_label") - l-body (label-statement (:body s) new-label) - l-for (p/for-statement-node (:init s) (:condition s) (:post s) l-body)] - (annotate-label l-for new-label)) - :if (if (:else-statement s) - (p/if-statement-node (:condition s) - (label-statement (:then-statement s) current-label) - (label-statement (:else-statement s) current-label)) - (p/if-statement-node (:condition s) - (label-statement (:then-statement s) current-label))) - :compound (let [update-block-f (fn [item] - (if (= (:type item) :statement) - (label-statement item current-label) - item)) - new-block (mapv update-block-f (:block s))] - (p/compound-statement-node new-block)) - :return s - :expression s - :empty s - (exc/analyzer-error "invalid statement reached during loop labelling." s)))) - -(defn- label-loop-function-body [fn-declaration] - (let [statement? (fn [x] (= :statement (:type x))) - labelled-body (mapv (fn [block-item] - (if (statement? block-item) - (label-statement block-item) - block-item)) - (:body fn-declaration))] - (assoc fn-declaration :body labelled-body))) - -(defn label-loops - "Annotates labels on looping constructs. - - Parameter: - program: List of declarations / blocks" - [program] - (let [fn-declaration? (fn [x] (= :function (:declaration-type x)))] - (mapv (fn [block] - (if (fn-declaration? block) - (label-loop-function-body block) - block)) - program))) - -(comment - - (-> "./test-programs/example.c" - slurp - p/parse-from-src - r/resolve-program) - - (-> "./test-programs/example.c" - slurp - p/parse-from-src - r/resolve-program - label-loops) - - (pretty/explain - s/Program - (-> "./test-programs/example.c" - slurp - p/parse-from-src - r/resolve-program)) - - (pretty/explain - s/Program - (-> "./test-programs/example.c" - slurp - p/parse-from-src - r/resolve-program - label-loops)) - - ()) diff --git a/src/cljcc/analyze/resolve.clj b/src/cljcc/analyze/resolve.clj deleted file mode 100644 index 9f09333..0000000 --- a/src/cljcc/analyze/resolve.clj +++ /dev/null @@ -1,300 +0,0 @@ -(ns cljcc.analyze.resolve - (:require [cljcc.exception :as exc] - [cljcc.parser :as p] - [malli.dev.pretty :as pretty] - [cljcc.schema :as s] - [cljcc.util :as util] - [malli.core :as m])) - -(defn- unique-identifier [identifier] - (util/create-identifier! identifier)) - -(defn- copy-identifier-map - "Returns a copy of the identifier -> symbol map. - - Sets :at-top-level false, as it's going inside a scope. ( Could be fn definition, compound statement ). - Sets :from-current-scope as false for every symbol. Used when going into a inner scope." - [ident->symbol] - (let [set-from-current-scope-as-false (fn [i->s] - (zipmap (keys i->s) - (map (fn [s] - (assoc s :from-current-scope false)) - (vals i->s))))] - (-> ident->symbol - (dissoc :at-top-level) - set-from-current-scope-as-false - (assoc :at-top-level false)))) - -(declare resolve-block resolve-declaration resolve-optional-exp) - -(defn- resolve-exp [e ident->symbol] - (condp = (:exp-type e) - :constant-exp e - :variable-exp (if (contains? ident->symbol (:identifier e)) - (p/variable-exp-node (:name (get ident->symbol (:identifier e)))) - (exc/analyzer-error "Undeclared variable seen." {:variable e})) - :assignment-exp (let [left (:left e) - right (:right e) - op (:assignment-operator e) - left-var? (= :variable-exp (:exp-type left))] - (if left-var? - (p/assignment-exp-node (resolve-exp left ident->symbol) - (resolve-exp right ident->symbol) - op) - (exc/analyzer-error "Invalid lvalue in assignment expression." {:lvalue e}))) - :binary-exp (p/binary-exp-node (resolve-exp (:left e) ident->symbol) - (resolve-exp (:right e) ident->symbol) - (:binary-operator e)) - :unary-exp (p/unary-exp-node (:unary-operator e) (resolve-exp (:value e) ident->symbol)) - :conditional-exp (p/conditional-exp-node (resolve-exp (:left e) ident->symbol) - (resolve-exp (:middle e) ident->symbol) - (resolve-exp (:right e) ident->symbol)) - :cast-exp (p/cast-exp-node (:target-type e) - (resolve-exp (:value e) ident->symbol)) - :function-call-exp (let [fn-name (:identifier e) - args (:arguments e)] - (if (contains? ident->symbol fn-name) - (p/function-call-exp-node (:new-name (get ident->symbol fn-name)) - (mapv #(resolve-exp % ident->symbol) args)) - (exc/analyzer-error "Undeclared function." {:function-name fn-name}))) - (exc/analyzer-error "Invalid expression." {:exp e}))) - -(defn- resolve-optional-exp [e ident->symbol] - (if (nil? e) - e - (resolve-exp e ident->symbol))) - -(defn- resolve-file-scope-variable-declaration - "Adds file scope variable declaration to scope. - - Directly adds variable declaration to map as it is top level." - [{:keys [identifier] :as declaration} ident->symbol] - {:declaration declaration - :ident->symbol (assoc ident->symbol identifier {:new-name identifier - :name identifier - :from-current-scope true - :has-linkage true})}) - -(defn- resolve-local-variable-declaration - "Add local variable declaration. - - Validates for variables declared with same name. - Validates for variables declared from different scope, but with conflicting storage class." - [{:keys [identifier initial variable-type storage-class] :as declaration} ident->symbol] - (let [prev-entry (get ident->symbol identifier) - extern? (= storage-class :extern) - _ (when (and prev-entry (:from-current-scope prev-entry)) - (when (not (and (:has-linkage prev-entry) extern?)) - (exc/analyzer-error "Conflicting local declaration." {:declaration declaration})))] - (if extern? - {:declaration declaration - :ident->symbol (assoc ident->symbol identifier {:new-name identifier - :name identifier - :from-current-scope true - :has-linkage true})} - (let [unique-name (unique-identifier identifier) - updated-symbols (assoc ident->symbol identifier {:new-name unique-name - :name unique-name - :from-current-scope true - :has-linkage false}) - init-value (when initial (resolve-exp initial updated-symbols))] - {:declaration (p/variable-declaration-node unique-name storage-class variable-type init-value) - :ident->symbol updated-symbols})))) - -(defn- resolve-variable-declaration - "Resolves variable declarations. - - Ensures variable not declared twice in the current scope." - [decl {:keys [at-top-level] :as ident->symbol}] - (if at-top-level - (resolve-file-scope-variable-declaration decl ident->symbol) - (resolve-local-variable-declaration decl ident->symbol))) - -(defn- resolve-parameter [parameter ident->symbol] - (if (and (contains? ident->symbol parameter) - (:from-current-scope (get ident->symbol parameter))) - (exc/analyzer-error "Parameter name duplicated." {:parameter parameter}) - (let [unique-name (unique-identifier parameter) - updated-identifier-map (assoc ident->symbol parameter {:name unique-name - :from-current-scope true - :has-linkage false})] - {:parameter unique-name - :ident->symbol updated-identifier-map}))) - -(defn- resolve-parameters [params ident->symbol] - (reduce (fn [acc p] - (let [{:keys [parameter ident->symbol]} (resolve-parameter p (:ident->symbol acc))] - {:parameters (conj (:parameters acc) parameter) - :ident->symbol ident->symbol})) - {:parameters [] :ident->symbol ident->symbol} - params)) - -(defn- resolve-function-declaration - "Resolve function declaration. - - Ensures functions not declared twice in current scope with incorrect linkage." - [{:keys [identifier storage-class parameters function-type body] :as d} ident->symbol] - (let [prev-entry (get ident->symbol identifier) - already-declared-var? (and (contains? ident->symbol identifier) - (:from-current-scope (get ident->symbol identifier)) - (not (:has-linkage prev-entry))) - illegally-redeclared? (and (contains? ident->symbol identifier) - (:from-current-scope prev-entry) - (not (:has-linkage prev-entry))) - static? (= :static storage-class) - inside-function-definition? (not (:at-top-level ident->symbol)) - _ (when already-declared-var? - (exc/analyzer-error "Variable already declared in same scope." {:declaration d})) - _ (when illegally-redeclared? - (exc/analyzer-error "Function duplicate declaration." {:declaration d})) - updated-identifier-map (assoc ident->symbol identifier {:new-name identifier - :name identifier - :from-current-scope true - :has-linkage true}) - inner-map (copy-identifier-map updated-identifier-map) - {new-params :parameters, inner-map :ident->symbol} (resolve-parameters parameters inner-map) - _ (when (and body inside-function-definition?) - (exc/analyzer-error "Nested function definition not allowed." {:declaration d - :ident->symbol ident->symbol})) - _ (when (and inside-function-definition? static?) - (exc/analyzer-error "Nested static function declarations cannot exist." {:declaration d})) - new-body (when body (resolve-block body inner-map))] - {:declaration (p/function-declaration-node function-type storage-class identifier new-params (:block new-body)) - :ident->symbol updated-identifier-map})) - -(defn- resolve-declaration [{:keys [declaration-type] :as d} ident->symbol] - (condp = declaration-type - :variable (resolve-variable-declaration d ident->symbol) - :function (resolve-function-declaration d ident->symbol) - (exc/analyzer-error "Invalid declaration type" {:declaration d}))) - -(defn- resolve-for-init [for-init ident->symbol] - (if (= (:type for-init) :declaration) - (resolve-declaration for-init ident->symbol) - (resolve-optional-exp for-init ident->symbol))) - -(defmulti resolve-statement - "Resolves statements in a given scope. - - Scope here refers to the ident->symbol map, which holds declarations - visisble to statement at this time. - - Dispatches based on the type of statement. - - Returns statement after recursively resolving all expressions and statements. - " - (fn [statement _ident->symbol] - (:statement-type statement))) - -(defmethod resolve-statement :default [statement _] - (exc/analyzer-error "Invalid statement." {:statement statement})) - -(defmethod resolve-statement :return [{:keys [value]} ident->symbol] - (p/return-statement-node (resolve-exp value ident->symbol))) - -(defmethod resolve-statement :break [statement _] - statement) - -(defmethod resolve-statement :continue [statement _] - statement) - -(defmethod resolve-statement :empty [statement _] - statement) - -(defmethod resolve-statement :expression [{:keys [value]} ident->symbol] - (p/expression-statement-node (resolve-exp value ident->symbol))) - -(defmethod resolve-statement :if [{:keys [condition then-statement else-statement]} ident->symbol] - (if else-statement - (p/if-statement-node (resolve-exp condition ident->symbol) - (resolve-statement then-statement ident->symbol) - (resolve-statement else-statement ident->symbol)) - (p/if-statement-node (resolve-exp condition ident->symbol) - (resolve-statement then-statement ident->symbol)))) - -(defmethod resolve-statement :while [{:keys [condition body]} ident->symbol] - (p/while-statement-node (resolve-exp condition ident->symbol) - (resolve-statement body ident->symbol))) - -(defmethod resolve-statement :do-while [{:keys [condition body]} ident->symbol] - (p/do-while-statement-node (resolve-exp condition ident->symbol) - (resolve-statement body ident->symbol))) - -(defmethod resolve-statement :for [{:keys [init condition post body]} ident->symbol] - (let [for-scope-identifier-map (copy-identifier-map ident->symbol) - resolved-for-init (resolve-for-init init for-scope-identifier-map) - for-scope-identifier-map (if (:declaration resolved-for-init) ; updates symbol map if for initializer is declaration - (:ident->symbol resolved-for-init) - for-scope-identifier-map) - resolved-for-init (if (:declaration resolved-for-init) ; getting the underlying declaration, if it is - (:declaration resolved-for-init) - resolved-for-init) - condition (resolve-optional-exp condition for-scope-identifier-map) - post (resolve-optional-exp post for-scope-identifier-map) - body (resolve-statement body for-scope-identifier-map)] - (p/for-statement-node resolved-for-init condition post body))) - -(defmethod resolve-statement :compound [{:keys [block]} ident->symbol] - (p/compound-statement-node (:block (resolve-block block (copy-identifier-map ident->symbol))))) - -(defn- resolve-block-item [{:keys [type] :as item} ident->symbol] - (condp = type - :declaration (let [{d :declaration - i->s :ident->symbol} (resolve-declaration item ident->symbol)] - {:block-item d - :ident->symbol i->s}) - :statement {:block-item (resolve-statement item ident->symbol) - :ident->symbol ident->symbol})) - -(defn- resolve-block - "Resolves a block under a given symbol table. - - Block is list of block items. - - ident->symbol holds identifier to symbol mapping. - Symbol contains the type information, generated variable name etc. - - | key | description | - |----------------|-------------| - |`:at-top-level` | Is current level top or not ( default true)|" - ([block] - (resolve-block block {:at-top-level true})) - ([block ident->symbol] - (let [reduce-f (fn [acc block-item] - (let [res (resolve-block-item block-item (:ident->symbol acc))] - {:block (conj (:block acc) (:block-item res)) - :ident->symbol (:ident->symbol res)}))] - (reduce reduce-f - {:block [] - :ident->symbol ident->symbol} - block)))) - -;; Program is list of block items, which are themselves just blocks. -(defn resolve-program [program] - (let [res (:block (resolve-block program))] - ; _ (m/coerce s/Program res)] - res)) - -(comment - - (def file-path "./test-programs/example.c") - - (slurp "./test-programs/example.c") - - (-> file-path - slurp - p/parse-from-src) - - (-> file-path - slurp - p/parse-from-src - resolve-program) - - (pretty/explain - s/Program - (-> file-path - slurp - p/parse-from-src - resolve-program)) - - ()) diff --git a/src/cljcc/analyze/typecheck.clj b/src/cljcc/analyze/typecheck.clj deleted file mode 100644 index d1e79dc..0000000 --- a/src/cljcc/analyze/typecheck.clj +++ /dev/null @@ -1,537 +0,0 @@ -(ns cljcc.analyze.typecheck - (:require [malli.core :as m] - [malli.dev.pretty :as pretty] - [cljcc.parser :as p] - [cljcc.token :as t] - [cljcc.schema :as s] - [cljcc.symbol :as sym] - [clojure.core.match :refer [match]] - [cljcc.analyze.resolve :as r] - [cljcc.analyze.label-loops :as l] - [cljcc.exception :as exc] - [cljcc.util :as u])) - -(declare typecheck-block typecheck-declaration to-static-init) - -(defn set-type - "Assocs onto an expression given type." - [e t] (assoc e :value-type t)) - -(defn get-type [e] (:value-type e)) - -(defn- symbol-function? [s] - (= :function (:type (:type s)))) - -(defmulti typecheck-exp - "Returns the expression, after typechecking nested expressions." - (fn [{:keys [exp-type]} _ident->symbol] exp-type)) - -(defmethod typecheck-exp :constant-exp - [{:keys [value] :as e} _] - (condp = (:type value) - :int (set-type e {:type :int}) - :long (set-type e {:type :long}) - :uint (set-type e {:type :uint}) - :ulong (set-type e {:type :ulong}) - :double (set-type e {:type :double}) - (exc/analyzer-error "Invalid type for constant expression." {:e e}))) - -(defmethod typecheck-exp :variable-exp - [{:keys [identifier] :as e} ident->symbol] - (let [s (get ident->symbol identifier)] - (if (symbol-function? s) - (exc/analyzer-error "Function name used as variable." {:expression e}) - (set-type e (:type s))))) - -(defmethod typecheck-exp :cast-exp - [{:keys [target-type value]} ident->symbol] - (let [typed-inner-e (typecheck-exp value ident->symbol) - cast-exp (p/cast-exp-node target-type typed-inner-e)] - (set-type cast-exp target-type))) - -(defmethod typecheck-exp :unary-exp - [{:keys [unary-operator value] :as e} ident->symbol] - (let [typed-inner-e (typecheck-exp value ident->symbol) - _ (when (and (= unary-operator :complement) (= {:type :double} (get-type typed-inner-e))) - (exc/analyzer-error "Can't take bitwise complement of double" {:expression e})) - unary-exp (p/unary-exp-node unary-operator typed-inner-e)] - (condp = unary-operator - :logical-not (set-type unary-exp {:type :int}) - (set-type unary-exp (get-type typed-inner-e))))) - -(defn- get-common-type [t1 t2] - (cond - (= t1 t2) t1 - (or (= t1 {:type :double}) - (= t2 {:type :double})) {:type :double} - (= (u/get-type-size t1) - (u/get-type-size t2)) (if (u/type-signed? t1) - t2 - t1) - (> (u/get-type-size t1) - (u/get-type-size t2)) t1 - :else t2)) - -(defn- convert-to-exp - "Returns expression, using casting if necessary." - [e t] - (if (= (get-type e) t) - e - (set-type (p/cast-exp-node t e) t))) - -(defmethod typecheck-exp :binary-exp - [{:keys [left right binary-operator] :as e} ident->symbol] - (let - [typed-left-e (typecheck-exp left ident->symbol) - typed-right-e (typecheck-exp right ident->symbol)] - (if (t/logical? binary-operator) - (set-type (p/binary-exp-node typed-left-e - typed-right-e - binary-operator) - {:type :int}) - (let [tl (get-type typed-left-e) - tr (get-type typed-right-e) - _ (when (and (= :remainder binary-operator) - (or (= {:type :double} tl) - (= {:type :double} tr))) - (exc/analyzer-error "Operands to remainder operation cannot be double." {:expression e})) - common-type (get-common-type tl tr) - convert-left-exp (convert-to-exp typed-left-e common-type) - convert-right-exp (convert-to-exp typed-right-e common-type) - typed-binary-exp (p/binary-exp-node convert-left-exp convert-right-exp binary-operator)] - (if (t/arithmetic? binary-operator) - (set-type typed-binary-exp common-type) - (set-type typed-binary-exp {:type :int})))))) - -(defmethod typecheck-exp :assignment-exp - [{:keys [left right assignment-operator] :as _e} ident->symbol] - (let - [typed-left (typecheck-exp left ident->symbol) - typed-right (typecheck-exp right ident->symbol) - left-type (get-type typed-left) - converted-right (convert-to-exp typed-right left-type) - typed-assign-exp (p/assignment-exp-node typed-left converted-right assignment-operator)] - (set-type typed-assign-exp left-type))) - -(defmethod typecheck-exp :conditional-exp - [{:keys [left right middle] :as _e} m] - (let [t-left (typecheck-exp left m) - t-right (typecheck-exp right m) - t-middle (typecheck-exp middle m) - common-type (get-common-type (get-type t-middle) (get-type t-right)) - convert-right (convert-to-exp t-right common-type) - convert-middle (convert-to-exp t-middle common-type) - typed-cond-e (p/conditional-exp-node t-left convert-middle convert-right)] - (set-type typed-cond-e common-type))) - -(defmethod typecheck-exp :function-call-exp - [{:keys [identifier arguments] :as e} ident->symbol] - (let - [{ftype :type :as symbol} (get ident->symbol identifier)] - (if (symbol-function? symbol) - (let [_ (when (not= (count arguments) (count (:parameter-types ftype))) - (exc/analyzer-error "Function called with wrong number of arguments." - {:expected (count (:parameter-types ftype)) - :actual (count arguments)})) - cast-arg-to-param-type-f (fn [param-type arg] - (convert-to-exp (typecheck-exp arg ident->symbol) - param-type)) - converted-args (mapv cast-arg-to-param-type-f - (:parameter-types ftype) - arguments) - typed-fun-call-exp (p/function-call-exp-node identifier converted-args)] - (set-type typed-fun-call-exp (:return-type ftype))) - (exc/analyzer-error "Variable used as function name" {:symbol symbol - :expression e})))) - -(defmulti typecheck-statement - "Dispatches based on type of statement. - - Parameters: - - return-type: Return type of statement's enclosing function. - - statement - - ident->symbol: Symbol map for current scope." - (fn [_return-type {:keys [statement-type]} _ident->symbol] - statement-type)) - -(defmethod typecheck-statement :return - [return-type {:keys [value]} ident->symbol] - {:statement (p/return-statement-node - (convert-to-exp (typecheck-exp value ident->symbol) - return-type)) - :ident->symbol ident->symbol}) - -(defmethod typecheck-statement :expression - [_ {:keys [value]} ident->symbol] - {:statement (p/expression-statement-node (typecheck-exp value ident->symbol)) - :ident->symbol ident->symbol}) - -(defmethod typecheck-statement :break - [_ s m] - {:statement s - :ident->symbol m}) - -(defmethod typecheck-statement :continue - [_ s m] - {:statement s - :ident->symbol m}) - -(defmethod typecheck-statement :empty - [_ s m] - {:statement s - :ident->symbol m}) - -(defmethod typecheck-statement :while - [return-type {:keys [condition body] :as stmt} m] - (let [typed-cond (typecheck-exp condition m) - typed-body (typecheck-statement return-type body m)] - {:statement (merge stmt (p/while-statement-node - typed-cond - (:statement typed-body))) - :ident->symbol (:ident->symbol typed-body)})) - -(defmethod typecheck-statement :do-while - [return-type {:keys [condition body] :as stmt} m] - (let [typed-cond (typecheck-exp condition m) - typed-body (typecheck-statement return-type body m)] - {:statement (merge stmt (p/do-while-statement-node - typed-cond - (:statement typed-body))) - :ident->symbol (:ident->symbol typed-body)})) - -(defn- typecheck-optional-expression [e m] - (if (nil? e) - e - (typecheck-exp e m))) - -(defn- typecheck-for-init [for-init ident->symbol] - (if (= (:type for-init) :declaration) - (typecheck-declaration for-init ident->symbol) - (typecheck-optional-expression for-init ident->symbol))) - -(defmethod typecheck-statement :for - [return-type {:keys [init post condition body] :as stmt} m] - (let [f-init (typecheck-for-init init m) - m' (if (:declaration f-init) - (:ident->symbol f-init) - m) - f-init (if (:declaration f-init) - (:declaration f-init) - f-init) - t-condition (typecheck-optional-expression condition m') - t-post (typecheck-optional-expression post m') - typed-body-statement (typecheck-statement return-type body m')] - {:statement (merge stmt - (p/for-statement-node f-init t-condition t-post (:statement typed-body-statement))) - :ident->symbol (:ident->symbol typed-body-statement)})) - -(defmethod typecheck-statement :if - [return-type {:keys [condition then-statement else-statement]} m] - (if else-statement - (let [t-condition (typecheck-exp condition m) - {t-then :statement - m :ident->symbol} (typecheck-statement return-type then-statement m) - {t-else :statement - m :ident->symbol} (typecheck-statement return-type else-statement m)] - {:statement (p/if-statement-node t-condition t-then t-else) - :ident->symbol m}) - (let [t-condition (typecheck-exp condition m) - {t-then :statement - m :ident->symbol} (typecheck-statement return-type then-statement m)] - {:statement (p/if-statement-node t-condition t-then) - :ident->symbol m}))) - -(defmethod typecheck-statement :compound - [return-type {:keys [block]} m] - (let [typed-block (typecheck-block return-type block m)] - {:statement (p/compound-statement-node (:block typed-block)) - :ident->symbol (:ident->symbol typed-block)})) - -(defn- typecheck-item [return-type {:keys [type] :as item} m] - (condp = type - :declaration (let [v (typecheck-declaration item m)] - {:block-item (:declaration v) - :ident->symbol (:ident->symbol v)}) - :statement (let [v (typecheck-statement return-type item m)] - {:block-item (:statement v) - :ident->symbol (:ident->symbol v)}) - (exc/analyzer-error "Invalid statement/declaration." item))) - -(defn- typecheck-block [return-type block ident->symbol] - (reduce (fn [acc item] - (let [v (typecheck-item return-type item (:ident->symbol acc))] - {:block (conj (:block acc) (:block-item v)) - :ident->symbol (:ident->symbol v)})) - {:block [] - :ident->symbol ident->symbol} - block)) - -(defn- get-initial-value - [{:keys [initial storage-class variable-type] :as declaration}] - (let [constant-exp? (= :constant-exp (:exp-type initial))] - (cond - constant-exp? (to-static-init initial variable-type) - (nil? initial) (if (= :extern storage-class) - (sym/no-initializer-iv) - (sym/tentative-iv)) - :else (exc/analyzer-error "Non-constant initializer." declaration)))) - -(defn- const-convert - "Converts a constant initializer to a specific variable type. - - Does type conversion if necessary." - [{ttype :type :as target-type} {const-type :type value :value :as const}] - (match [ttype const-type] - [:double :ulong] {:type :double - :value (-> value - biginteger - (.doubleValue))} - [:double _] {:type :double - :value (double value)} - [:ulong :double] {:type :ulong - :value (-> value - biginteger - (.longValue))} - [(:or :int :uint) _] {:type ttype - :value (-> value - unchecked-int - long)} - [(:or :long :ulong) _] {:type ttype - :value (long value)} - :else (exc/analyzer-error "Invalid type passed to const-convert function." - {:const const - :target-type target-type}))) - -(defn- zero-initializer - "Returns zero const initializer based on passed type." - [{:keys [type] :as _t}] - (condp = type - :int (sym/int-init 0) - :uint (sym/uint-init 0) - :long (sym/long-init 0) - :ulong (sym/ulong-init 0) - :double (sym/double-init (double 0)))) - -(defn- to-static-init [{:keys [value exp-type] :as e} var-type] - (cond - (= :constant-exp exp-type) (let [{const-type :type - const-value :value} (const-convert var-type value)] - (condp = const-type - :int (sym/initial-iv (sym/int-init const-value)) - :long (sym/initial-iv (sym/long-init const-value)) - :uint (sym/initial-iv (sym/uint-init const-value)) - :ulong (sym/initial-iv (sym/ulong-init const-value)) - :double (sym/initial-iv (sym/double-init const-value)))) - (nil? e) (sym/initial-iv (zero-initializer var-type)) - :else (exc/analyzer-error "Non-constant initializer on static variable." e))) - -(defn- validate-file-scope-variable-declaration - [{:keys [variable-type storage-class] :as cur-decl} prev-symbol] - (let [_ (when (not= variable-type (:type prev-symbol)) - (exc/analyzer-error "Redeclared with different types." {:declaration1 cur-decl - :declaration2 prev-symbol})) - global? (not= :static storage-class) - global? (cond - (= :extern storage-class) (get-in prev-symbol [:attribute :global?]) - (not= global? (get-in prev-symbol [:attribute :global?])) (exc/analyzer-error "Conflicting variable linkage." {:d1 cur-decl - :d2 prev-symbol}) - :else global?) - initial-value (get-initial-value cur-decl) - initial-value (cond - (= - :initial - (get-in prev-symbol [:attribute :initial-value :type])) (if (= (:type initial-value) :initial) - (exc/analyzer-error "Conflicting file scope variable definition." {:d1 cur-decl - :d2 prev-symbol}) - (get-in prev-symbol [:attribute :initial-value])) - (and - (= :tentative (get-in prev-symbol [:attribute :initial-value :type])) - (not= :initial (:type initial-value))) {:type :tentative} - :else initial-value)] - {:global? global? - :initial-value initial-value})) - -(defn- typecheck-file-scope-variable-declaration - [{:keys [identifier storage-class variable-type] :as d} ident->symbol] - (let [prev-symbol (get ident->symbol identifier) - global? (not= :static storage-class) - initial-value (get-initial-value d) - {global? :global? - initial-value :initial-value} (if prev-symbol - (validate-file-scope-variable-declaration d prev-symbol) - {:global? global? - :initial-value initial-value})] - {:declaration d - :ident->symbol (assoc ident->symbol - identifier - (sym/create-symbol variable-type (sym/static-attribute initial-value global?)))})) - -(defn- typecheck-local-scope-variable-declaration - [{:keys [identifier variable-type storage-class initial] :as d} ident->symbol] - (condp = storage-class - :extern (let [_ (when (not (nil? initial)) - (exc/analyzer-error "Initializer on local extern variable declaration." d)) - prev-symbol (get ident->symbol identifier) - prev-type (:type prev-symbol) - _ (when (and prev-symbol (not= prev-type variable-type)) - (exc/analyzer-error "Redeclared with different types." {:declaration1 d - :declaration2 prev-symbol})) - symbols (if prev-symbol - ident->symbol - (assoc ident->symbol - identifier - (sym/create-symbol variable-type (sym/static-attribute (sym/no-initializer-iv) true))))] - {:declaration d - :ident->symbol symbols}) - :static (let [initial-value (to-static-init initial variable-type) - updated-symbols (assoc ident->symbol - identifier - (sym/create-symbol variable-type (sym/static-attribute initial-value false)))] - {:declaration d - :ident->symbol updated-symbols}) - (let [updated-symbols (assoc ident->symbol - identifier - (sym/create-symbol - variable-type - (sym/local-attribute))) - casted-e (if (nil? initial) - initial - (convert-to-exp initial variable-type)) - t-e (typecheck-optional-expression casted-e updated-symbols)] - {:declaration (assoc d :initial t-e) - :ident->symbol updated-symbols}))) - -(defn- validate-old-fn-decl-return-attribute - [cur-decl prev-symbol] - (let [prev-function? (= :function (get-in prev-symbol [:type :type])) - _ (when-not prev-function? - (exc/analyzer-error "Variable being redeclared as function." {:declaration cur-decl - :prev-symbol prev-symbol})) - same-type? (and (= (get-in cur-decl [:function-type :parameter-types]) - (get-in prev-symbol [:type :parameter-types])) - (= (get-in cur-decl [:function-type :return-type]) - (get-in prev-symbol [:type :return-type]))) - _ (when-not same-type? - (exc/analyzer-error "Incompatible function type declarations." {:declaration cur-decl - :prev-declaration-type prev-symbol})) - defined? (seq (:body cur-decl)) - prev-defined? (get-in prev-symbol [:attribute :defined?]) - _ (when (and defined? prev-defined?) - (exc/analyzer-error "Function defined more than once." {:declaration cur-decl})) - current-static? (= :static (:storage-class cur-decl)) - old-global? (get-in prev-symbol [:attribute :global?]) - _ (when (and old-global? current-static?) - (exc/analyzer-error "Static function definition follows non static." {:declaration cur-decl}))] - {:defined? prev-defined? - :global? old-global?})) - -(defn- add-parameter-to-symbols - [parameters function-type ident->symbol] - (if (zero? (count parameters)) - ident->symbol - (apply assoc - ident->symbol - (flatten - (map (fn [p t] - [p (sym/create-symbol t (sym/local-attribute))]) - parameters - (:parameter-types function-type)))))) - -(defn- typecheck-function-declaration - [{:keys [identifier storage-class body parameters function-type] :as d} ident->symbol] - (let [body? (seq body) - prev-symbol (get ident->symbol identifier) - {defined? :defined? - global? :global?} (if prev-symbol - (validate-old-fn-decl-return-attribute d prev-symbol) - {:defined? false - :global? (not= :static storage-class)}) - function-attribute (sym/fun-attribute (boolean (or defined? body?)) global?) - updated-symbols (assoc ident->symbol - identifier - (sym/create-symbol - function-type - function-attribute))] - (if body? - (let [with-parameter-symbols (add-parameter-to-symbols - parameters - function-type - updated-symbols) - with-body-symbols (typecheck-block (:return-type function-type) - body - (assoc with-parameter-symbols - :at-top-level false))] - {:declaration (assoc d :body (:block with-body-symbols)) - :ident->symbol (assoc (:ident->symbol with-body-symbols) - :at-top-level true)}) - {:declaration d - :ident->symbol updated-symbols}))) - -(defn- typecheck-declaration - [{:keys [declaration-type] :as d} ident->symbol] - (let [at-top-level? (:at-top-level ident->symbol)] - (condp = declaration-type - :variable (if at-top-level? - (typecheck-file-scope-variable-declaration d ident->symbol) - (typecheck-local-scope-variable-declaration d ident->symbol)) - :function (typecheck-function-declaration d ident->symbol) - (exc/analyzer-error "Invalid declaration for typechecker." {:declaration d})))) - -(defn- typecheck-program [program] - (let [rf (fn [acc decl] - (let [d (typecheck-declaration decl (:ident->symbol acc))] - {:program (conj (:program acc) (:declaration d)) - :ident->symbol (:ident->symbol d)}))] - (reduce rf - {:program [] - :ident->symbol {:at-top-level true}} - program))) - -(defn typecheck - "Typechecks given program. - - A program is a list of declarations." - [program] - (let [v (typecheck-program program) - program (:program v) - m (dissoc (:ident->symbol v) :at-top-level) - ;_ (m/coerce s/Program program) - ;_ (m/coerce s/SymbolMap m) - ] - {:program program - :ident->symbol m})) - -(comment - - (def file-path "./test-programs/example.c") - - (slurp "./test-programs/example.c") - - (-> file-path - slurp - p/parse-from-src) - - (-> file-path - slurp - p/parse-from-src - r/resolve-program - l/label-loops - typecheck) - - (-> - "unsigned long ul = 18446744073709549568.;" - p/parse-from-src - r/resolve-program - l/label-loops - typecheck) - - (pretty/explain - s/TypecheckedOut - (-> file-path - slurp - p/parse-from-src - r/resolve-program - l/label-loops - typecheck)) - - ()) |
