aboutsummaryrefslogtreecommitdiff
path: root/src/cljcc/analyze
diff options
context:
space:
mode:
authorYour Name <agrawalshagun07@gmail.com>2025-03-16 02:00:40 +0530
committerYour Name <agrawalshagun07@gmail.com>2025-03-16 02:00:40 +0530
commit0321df3708cfa4d1440faf3f407611df85484b4b (patch)
tree8c23154afaf1afd78363eb0fa639edd5d8a32821 /src/cljcc/analyze
parente458b2fadee1eaf0a6cf4ed4881da6f3f25acc21 (diff)
Refactor files to cljcc-compiler and cli tool.
Diffstat (limited to 'src/cljcc/analyze')
-rw-r--r--src/cljcc/analyze/core.clj10
-rw-r--r--src/cljcc/analyze/label_loops.clj105
-rw-r--r--src/cljcc/analyze/resolve.clj300
-rw-r--r--src/cljcc/analyze/typecheck.clj537
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))
-
- ())