Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 8626b3851f
Fetching contributors…

Cannot retrieve contributors at this time

4729 lines (4346 sloc) 181.695 kb
;;; The Joxa Compiler
;;; =================
;;; * author: Eric Merritt
;;; * copyright: Erlware, LLC 2011 - 2012
;;;
;;; Licensed under the Apache License, Version 2.0 you may not use
;;; this file except in compliance with the License. You may obtain a
;;; copy of the License at http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Introduction
;;; ------------
;;;
;;; This provides the base compiler for the Joxa language. Due to the
;;; way code loading works on the Erlang VM it needs to be all in the
;;; same namespace, using no macros or external Joxa resources. While
;;; this severely restricts the syntax you can use in the compler, it
;;; does ensure that only a very minimal base language is supported.
;;;
(ns joxa-compiler
(require init getopt file
lists unicode sets
re ets proplists
filename
filelib file cerl
code compile
io crypto binary
(erlang :joxify)
(ec_dictionary :joxify)
(ec_lists :joxify)
(core_pp :joxify)
(gen_server :joxify)
(io_lib :joxify))
(use (erlang :joxify
:only (+/2
==/2
and/2
or/2
is-list/1
is-binary/1))))
;; defspecs
;; --------
;;
;; Forward declarations for functions that will be defined
;; later. Defspecs serve as descriptions for a function to tools like
;; dialyzer. However, they also serve as forward declarations in the
;; joxa language. In the language, functions have to be defined before
;; they are called. so you end up defining all the dependent functions
;; before you define the function that calls those. For functions that
;; are mutually recursive, this is a a problem. So defspecs serve to
;; document yoru intent to define a function as well as to document
;; the types of that function. of course, if you define a def spec and
;; then do not call it it will result in a compile time error. All the
;; types and specs for the joxa compiler are defined here.
(deftype+ index () {(erlang/non_neg_integer) (erlang/non_neg_integer)})
(deftype path () {(erlang/non_neg_integer) [(erlang/non_neg_integer)]})
(deftype context ()
{:context,
(erlang/atom)
(erlang/list)
(erlang/term)
(erlang/term)
(erlang/term)
(erlang/term)
(erlang/term)
(erlang/term)
(erlang/term)
(erlang/term)
(erlang/term)})
(defspec value ((binary) (index)) {:fail (erlang/any)})
(defspec transform-ast ((erlang/any) (erlang/any) (erlang/any) (erlang/any))
{(erlang/any) (erlang/list)})
(defspec make-literal ((path) (context) (erlang/term)) (cerl/cerl))
(defspec idx-from-context ([(erlang/atom)] (path) (context)) {(erlang/non_neg_integer)
(erlang/non_neg_integer)})
(defspec path? ((path)) (erlang/list))
(defspec get-idx-annots ((path) (erlang/term)) (index))
(defspec make-use ((path) (context) (erlang/term) (erlang/atom) (erlang/list))
(context))
(defspec make-expr ((path) (context) (erlang/term)) {(context) (cerl/cerl)})
(defspec make-pattern-element ((path) (context) [(erlang/term)] (erlang/term))
{(context) (erlang/term) (cerl/cerl)})
(defspec make-quasi-element ((path) (context) (erlang/term)) {(context) (cerl/cerl)})
(defspec make-quasi ((path) (context) (erlang/term)) {(context) (cerl/cerl)})
(defspec make-spec-expr ((path) (context) (erlang/term))
{(context) (erlang/term)})
(defspec make-forms ((path) (context) (erlang/term)) (context))
(defspec traverse-path ((path)) (path))
(defspec incr-path ((path)) (path))
(defspec get-line-annots ((path) (erlang/term)) (erlang/term))
;; Utilities Used by the Compiler
;; -----------------------------
(defn joxify-name (name)
(let* (str-name (erlang/atom_to_list name))
(erlang/list_to_atom (re/replace str-name "_" "-"
[:global,{:return, :list}]))))
(defn get-joxa-info (type namespace fun-name)
(try*
(let* (info-fun (erlang/make_fun namespace :--joxa-info 2))
(info-fun type fun-name))
(catch (type body)
(case {type body}
({:error :undef}
:false)
(_
(erlang/raise type body (erlang/get_stacktrace)))))))
(defn get-joxa-info (type namespace)
(try*
(let* (info-fun (erlang/make_fun namespace :--joxa-info 1))
(info-fun type))
(catch (type body)
(case {type body}
({:error :undef}
:false)
(_
(erlang/raise type body (erlang/get_stacktrace)))))))
;; The Compile Context
;; -------------------
;;
;; The context is the heart of the system. It stores all the
;; information about the namespace undergoing compilation.
;; ### Internal Context Implementation
(defn+ get-context (field raw-ctx)
(case field
(:namespace-name (erlang/element 2 raw-ctx))
(:annots (erlang/element 3 raw-ctx))
(:attrs (erlang/element 4 raw-ctx))
(:exports (erlang/element 5 raw-ctx))
(:type-exports (erlang/element 6 raw-ctx))
(:scopes (erlang/element 7 raw-ctx))
(:type-scopes (erlang/element 8 raw-ctx))
(:definitions (erlang/element 9 raw-ctx))
(:types (erlang/element 10 raw-ctx))
(:aliases (erlang/element 11 raw-ctx))
(:requires (erlang/element 12 raw-ctx))
(:uses (erlang/element 13 raw-ctx))
(:line (erlang/element 14 raw-ctx))
(:options (erlang/element 15 raw-ctx))
(:rests (erlang/element 16 raw-ctx))
(:anon-fun-index (erlang/element 17 raw-ctx))
(:fun-deps (erlang/element 18 raw-ctx))
(:macros (erlang/element 19 raw-ctx))
(:unexported-macros (erlang/element 20 raw-ctx))
(:warnings (erlang/element 21 raw-ctx))
(:errors (erlang/element 22 raw-ctx))
(:result (erlang/element 23 raw-ctx))
(:filename (erlang/element 24 raw-ctx))
(:function-name (erlang/element 25 raw-ctx))
(:namespace-transition (erlang/element 26 raw-ctx))
(_ (erlang/throw {:invalid-field, :context field}))))
(defn+ set-context (field value raw-ctx)
(case field
(:namespace-name (erlang/setelement 2 raw-ctx value))
(:annots (erlang/setelement 3 raw-ctx value))
(:attrs (erlang/setelement 4 raw-ctx value))
(:exports (erlang/setelement 5 raw-ctx value))
(:type-exports (erlang/setelement 6 raw-ctx value))
(:scopes (erlang/setelement 7 raw-ctx value))
(:type-scopes (erlang/setelement 8 raw-ctx value))
(:definitions (erlang/setelement 9 raw-ctx value))
(:types (erlang/setelement 10 raw-ctx value))
(:aliases (erlang/setelement 11 raw-ctx value))
(:requires (erlang/setelement 12 raw-ctx value))
(:uses (erlang/setelement 13 raw-ctx value))
(:line (erlang/setelement 14 raw-ctx value))
(:options (erlang/setelement 15 raw-ctx value))
(:rests (erlang/setelement 16 raw-ctx value))
(:anon-fun-index (erlang/setelement 17 raw-ctx value))
(:fun-deps (erlang/setelement 18 raw-ctx value))
(:macros (erlang/setelement 19 raw-ctx value))
(:unexported-macros (erlang/setelement 20 raw-ctx value))
(:warnings (erlang/setelement 21 raw-ctx value))
(:errors (erlang/setelement 22 raw-ctx value))
(:result (erlang/setelement 23 raw-ctx value))
(:filename (erlang/setelement 24 raw-ctx value))
(:function-name (erlang/setelement 25 raw-ctx value))
(:namespace-transition (erlang/setelement 26 raw-ctx value))
(_ (erlang/throw {:invalid-field, :context field}))))
(defn+ internal-new-context (key-values)
(lists/foldl (fn (set-val raw-ctx)
(case set-val
({field value}
(set-context field value raw-ctx))))
{:context
:undefined ; namespace-name
(ec-dictionary/new :ec_dict) ; annots
[] ; attrs
(sets/new) ; exports
(sets/new) ; type-exports
[] ; scopes
[] ; type-scopes
[] ; definitions
(ec-dictionary/new :ec_dict) ; types
(ec-dictionary/new :ec_dict) ; alias
(ec-dictionary/new :ec_dict) ; require
(ec-dictionary/new :ec_dict) ; use
[] ; options
:undefined ; line
[] ; rest functions
-1 ; anonymous function index
(sets/new) ; fun deps
[] ; macros functions
[] ; unexported macros
[] ; warnings
[] ; Errors
:undefined ; binary
"" ; Filename
:undefined ; function name
:no-transition ; namespace-transition
} key-values))
(defn internal-cleanup-after-transition (ctx)
;; We only want to retain the file level things
(internal-new-context
[{:options (get-context :options ctx)}
{:warnings (get-context :warnings ctx)}
{:errors (get-context :errors ctx)}
{:filename (get-context :filename ctx)}
{:namespace-transition (get-context :namespace-transition ctx)}]))
(defn internal-add-warning (warning raw-ctx)
(let* (warnings (get-context :warnings raw-ctx))
(set-context :warnings (warning . warnings) raw-ctx)))
(defn internal-add-error (error raw-ctx)
(let* (errors (get-context :errors raw-ctx))
(set-context :errors (error . errors) raw-ctx)))
(defn internal-erri-from-context (path raw-ctx)
(try*
(let* (idx (get-idx-annots (path? path) (get-context :annots raw-ctx))
filename (get-context :filename raw-ctx))
{filename idx})
(catch (type body)
{"" {0 0}})))
(defn internal-add-macro (name arity path raw-ctx)
(let* (macros (get-context :macros raw-ctx))
(case (lists/any (fn (el)
(erlang/== el {name arity})) macros)
(:true
(internal-add-error {{:rest-fun-exists name} (internal-erri-from-context path raw-ctx)} raw-ctx))
(:false
(set-context :macros ({name arity} . macros) raw-ctx)))))
(defn internal-add-def (path raw-ctx annots name vars body replace)
(let* (arity (erlang/length vars)
defs (get-context :definitions raw-ctx)
fun-deps (get-context :fun-deps raw-ctx)
cerl-name (cerl/ann_c_fname annots name arity)
cerl-body (cerl/ann_c_fun annots vars body)
fun-type (case replace
(:ephemeral :ephemeral)
(_ :durable))
raw
(case replace
(:ephemeral
;; we dont warn on an ephemeral we just go ahead and replace
(case (lists/keymember {name arity} 1 defs)
(:true
{raw-ctx defs})
(:false
{raw-ctx (lists/keystore {name arity} 1 defs
{{name arity} {cerl-name cerl-body fun-deps fun-type}})})))
(:replace
;; Again no warning on a replace its designed simply to be
;; replaced silently. We do however clear the fun deps
{(set-context :fun-deps (sets/new) raw-ctx)
(lists/keystore {name arity} 1 defs
{{name arity} {cerl-name cerl-body fun-deps fun-type}})})
(:no-replace
{(lists/foldl (fn (el raw-ctx1)
(case el
;; With no replace we warn when the last definition was durabl
;; That is it was both not expected to be replaced
({{name arity}, {_ _ _ :durable}}
(internal-add-warning
{{:function-exists name arity}
(internal-erri-from-context path raw-ctx1)} raw-ctx1))
(_
raw-ctx1)))
;; Same here the fun deps get cleared
(set-context :fun-deps (sets/new) raw-ctx) defs)
(lists/keystore {name arity} 1 defs
{{name arity} {cerl-name cerl-body fun-deps fun-type}})})))
(case raw
({new-ctx new-defs}
(set-context :definitions new-defs new-ctx)))))
(defn internal-add-alias (aliased-name namespace raw-ctx)
(let* (aliases (get-context :aliases raw-ctx))
(set-context :aliases
(ec-dictionary/add aliased-name namespace aliases)
raw-ctx)))
(defn propogate-require-info (namespace function possible-arity joxify dict)
(let* (detail (case (get-joxa-info :rest namespace function)
(:false
{{namespace function possible-arity}
{:remote :not-rest {namespace function possible-arity}}})
(arity (when (erlang/is_integer arity))
{{namespace function :rest}
{:remote :rest {namespace function arity}}})))
(case detail
({(= key {namespace function arity})
function-detail}
(let* (new-dict (ec-dictionary/add key function-detail dict))
(case joxify
(:true
(ec-dictionary/add {namespace (joxify-name function) arity}
function-detail new-dict))
(:false
new-dict)))))))
(defn internal-add-require (namespace joxify raw-ctx0)
(let* (requires (get-context :requires raw-ctx0)
exports ((erlang/make_fun namespace :module_info 1) :exports)
new-requires (lists/foldl (fn (fun-arity dict)
(case fun-arity
({function arity}
(propogate-require-info
namespace function arity
joxify dict))))
requires exports)
raw-ctx1 (set-context :requires new-requires raw-ctx0))
(case joxify
(:true
(internal-add-alias (joxify-name namespace) namespace raw-ctx1))
(_
raw-ctx1))))
(defspec internal-alias? ((erlang/atom) (erlang/atom)
(erlang/non_neg_integer) (erlang/term))
(erlang/term))
(defn internal-remote-function? (namespace function possible-arity raw-ctx aliased)
(try*
(let* (requires (get-context :requires raw-ctx))
(case (ec-dictionary/has_key {namespace function :rest} requires)
(:true
(ec-dictionary/get {namespace function :rest} requires))
(:false
(ec-dictionary/get {namespace function possible-arity} requires))))
(catch (_type body)
(case body
(:not_found
(case aliased
(:false
(internal-alias? namespace function possible-arity raw-ctx))
(:true
:not-a-reference)))))))
(defn internal-remote-function? (namespace function possible-arity raw-ctx)
(internal-remote-function? namespace function possible-arity raw-ctx :false))
(defn internal-alias? (namespace function possible-arity raw-ctx)
(try*
(let* (aliases (get-context :aliases raw-ctx)
aliased-namespace (ec-dictionary/get namespace aliases))
(internal-remote-function?
aliased-namespace function possible-arity raw-ctx :true))
(catch (type body)
(case body
(:not_found
:not-a-reference)))))
(defn internal-is-local-rest-fun? (name possible-arity raw-ctx)
(let* (rests (get-context :rests raw-ctx))
(lists/foldl (fn (el acc)
(case acc
(:false
(case el
({name arity} (when (erlang/>= possible-arity arity))
{:true arity})
(_
:false)))
(_
acc))) :false rests)))
(defn internal-is-speced? (name possible-arity raw-ctx)
(let* (types (get-context :types raw-ctx))
(case (ec-dictionary/get {name possible-arity} :undefined types)
(:undefined
:not-a-reference)
(_
{:apply :not-rest {name possible-arity}}))))
(defn internal-rest-used-function? (name uses)
(lists/foldl (fn (el acc)
(case acc
(:not-a-reference
(case el
({{name _} {real-fun namespace}}
(case (get-joxa-info :rest namespace real-fun)
(:false
:not-a-reference)
(arity (when (erlang/is_integer arity))
{:remote :rest {namespace real-fun arity}})))
(_
:not-a-reference)))
(_
acc))) :not-a-reference (ec-dictionary/to-list uses)))
(defn internal-used-function? (name possible-arity raw-ctx)
(let* (uses (get-context :uses raw-ctx))
(case (internal-rest-used-function? name uses)
(:not-a-reference
(case (ec-dictionary/get {name possible-arity} :undefined uses)
({fun-name namespace-name}
{:remote :not-rest {namespace-name fun-name possible-arity}})
(:undefined
(internal-is-speced? name possible-arity raw-ctx))))
(result
result))))
(defn internal-rest-defined-function? (function possible-arity raw-ctx)
(case (internal-is-local-rest-fun? function possible-arity raw-ctx)
({:true arity}
(when (erlang/>= possible-arity arity))
{:apply :rest {function arity}})
(x
:not-a-reference)))
(defn internal-defined-used-function? (name possible-arity raw-ctx)
(case (internal-rest-defined-function? name possible-arity raw-ctx)
(:not-a-reference
(let* (defs (get-context :definitions raw-ctx))
(case (lists/any (fn (el)
(case el
({{name possible-arity} _}
:true)
(_
:false)))
defs)
(:true
{:apply :not-rest {name possible-arity}})
(:false
(internal-used-function? name possible-arity raw-ctx)))))
(rest-apply
rest-apply)))
(defn internal-resolve-reference (ref arity path raw-ctx)
(case ref
({:--fun _ arity}
(when (erlang/is_integer arity))
{raw-ctx (internal-defined-used-function? ref arity raw-ctx)})
({:--fun namespace function}
(when (and (erlang/is_atom namespace)
(erlang/is_atom function)))
{raw-ctx (internal-remote-function? namespace function arity raw-ctx)})
({:--fun fun invalid-arity}
{(internal-add-error {{:mismatched-arity fun arity invalid-arity}
(internal-erri-from-context path raw-ctx)} raw-ctx)
:not-a-reference})
({:--fun namespace function arity}
{raw-ctx (internal-remote-function? namespace function arity raw-ctx)})
({:--fun namespace function invalid-arity}
{(internal-add-error {{:mismatched-arity function arity invalid-arity}
(internal-erri-from-context path raw-ctx)} raw-ctx)
:not-a-reference})
(name
(when (erlang/is_atom name))
(let* (scopes (get-context :scopes raw-ctx))
(case (ec-lists/search (fn (scope)
(try*
{:ok (ec-dictionary/get name scope)}
(catch (_type body)
(case body
(:not_found
:not_found))))) scopes)
({:ok {var new-arity} _}
(when (erlang/or (erlang/== -1 arity)
(erlang/== new-arity arity)))
{raw-ctx {:reference {var new-arity}}})
(_
{raw-ctx (internal-defined-used-function? name arity raw-ctx)}))))
(_
{raw-ctx :not-a-reference})))
(defn get-macro-tag (namespace function arity)
(case (get-joxa-info :macro namespace {function arity})
(:true
:macro)
(:false
:not-macro)))
(defn+ start-context ()
(gen-server/start-link :joxa-compiler [] []))
(defn+ start-context (initial-values)
(gen-server/start-link :joxa-compiler [initial-values] []))
;; ### gen_server callbacks
(defn+ init (args0)
(case args0
([]
{:ok (internal-new-context '())})
([args1]
(when (is-list args1))
{:ok (internal-new-context args1)})
([args1]
(when (erlang/and (erlang/is_tuple args1)
(erlang/== :context (erlang/element 1 args1))))
{:ok args1})))
(defn+ handle_call (request from raw-ctx)
(let* (result
(case request
(:annots
{raw-ctx (get-context :annots raw-ctx)})
(:filename
{raw-ctx (get-context :filename raw-ctx)})
(:function-name
{raw-ctx (get-context :function-name raw-ctx)})
(:anon-fun-index
{raw-ctx (get-context :anon-fun-index raw-ctx)})
(:options
{raw-ctx (get-context :options raw-ctx)})
(:exports
{raw-ctx (get-context :exports raw-ctx)})
(:definitions
{raw-ctx (get-context :definitions raw-ctx)})
(:rests
{raw-ctx (get-context :rests raw-ctx)})
(:macros
{raw-ctx (get-context :macros raw-ctx)})
(:types
{raw-ctx (get-context :types raw-ctx)})
(:type-exports
{raw-ctx (get-context :type-exports raw-ctx)})
(:unexported-macros
{raw-ctx (get-context :unexported-macros raw-ctx)})
(:namespace-name
{raw-ctx (get-context :namespace-name raw-ctx)})
(:warnings
{raw-ctx (get-context :warnings raw-ctx)})
(:errors
{raw-ctx (get-context :errors raw-ctx)})
(:line
{raw-ctx (get-context :line raw-ctx)})
(:attrs
{raw-ctx (get-context :attrs raw-ctx)})
(:requires
{raw-ctx (get-context :requires raw-ctx)})
(:uses
{raw-ctx (get-context :uses raw-ctx)})
({:thing-from-context actions path0 do-fun}
(let* (do-action (fn (action path1)
(case action
(:traverse
(traverse-path path1))
(:incr
(incr-path path1))))
path1 (case actions
(a1 (when (is-list a1))
(lists/foldl do-action/2 path0 actions))
(a2 (when (erlang/is_atom a2))
(do-action actions path0))))
{raw-ctx (do-fun (path? path1) (get-context :annots raw-ctx))}))
(:warning-count
{raw-ctx (erlang/length (get-context :warnings raw-ctx))})
(:error-count
{raw-ctx (erlang/length (get-context :errors raw-ctx))})
({:resolve-reference path ref arity}
(case (internal-resolve-reference ref arity path raw-ctx)
({raw-ctx1 {:remote rest (= mfa {namespace function rest-arity})}}
{raw-ctx1 {:remote rest (get-macro-tag namespace function rest-arity) mfa}})
({raw-ctx1 {:apply rest (= fa {function rest-arity})}}
{raw-ctx1 {:apply rest (get-macro-tag (get-context :namespace-name raw-ctx)
function rest-arity)
fa}})
(val
val)))
({:resolve-type-reference name arity}
{raw-ctx (let* (type-scopes (get-context :type-scopes raw-ctx)
types (get-context :types raw-ctx))
(case (lists/any (fn (set-scope)
(sets/is_element {name arity} set-scope)) type-scopes)
(:true
:true)
(:false
(case (ec-dictionary/get {name arity} :undefined types)
(:undefined
:false)
(_
:true)))))})
(:namespace-transition
{raw-ctx (get-context :namespace-transition raw-ctx)})
(:get-raw-context
{raw-ctx raw-ctx})
(:result
{raw-ctx (get-context :result raw-ctx)})))
(case result
({raw-ctx1 reply}
{:reply reply raw-ctx1}))))
(defn+ handle_cast (msg raw-ctx)
(case msg
({:exports new-exports}
{:noreply (set-context :exports new-exports raw-ctx)})
({:options options}
{:noreply (set-context :options options raw-ctx)})
({:filename filename}
{:noreply (set-context :filename filename raw-ctx)})
({:function-name name}
{:noreply (set-context :function-name name raw-ctx)})
({:namespace-name new-namespace-name}
{:noreply (set-context :namespace-name new-namespace-name raw-ctx)})
({:line line-annots}
{:noreply (set-context :line line-annots raw-ctx)})
({:namespace-transition ns-trans}
{:noreply (set-context :namespace-transition ns-trans raw-ctx)})
({:annots annots}
{:noreply (set-context :annots annots raw-ctx)})
({:add-warning path warning}
{:noreply (internal-add-warning {warning (internal-erri-from-context path raw-ctx)}
raw-ctx)})
({:add-error path error}
{:noreply (internal-add-error {error (internal-erri-from-context path raw-ctx)} raw-ctx)})
(:incr-fun-index
{:noreply (set-context :anon-fun-index (erlang/+ (get-context :anon-fun-index raw-ctx) 1) raw-ctx)})
({:add-export fun-name arity annots}
(let* (exports (get-context :exports raw-ctx))
{:noreply
(set-context
:exports (sets/add_element {fun-name arity annots} exports)
raw-ctx)}))
({:add-rest name arity path}
(let* (rests (get-context :rests raw-ctx))
(case (lists/any (fn (el)
(erlang/== el name)) rests)
(:true
{:noreply (internal-add-error {{:rest-fun-exists name}
(internal-erri-from-context path raw-ctx)} raw-ctx)})
(:false
{:noreply (set-context :rests ({name arity} . rests) raw-ctx)}))))
({:add-macro name arity path}
{:noreply (internal-add-macro name arity path raw-ctx)})
({:add-unexported-macro name arity path}
(let* (unexported-macros (get-context :unexported-macros raw-ctx))
{:noreply (set-context :unexported-macros ({name arity} . unexported-macros)
(internal-add-macro name arity path raw-ctx))}))
({:add-attr key value}
(let* (attrs (get-context :attrs raw-ctx))
{:noreply (set-context :attrs ({key value} . attrs) raw-ctx)}))
({:add-alias aliased-name namespace}
{:noreply (internal-add-alias aliased-name namespace raw-ctx)})
({:add-require namespace joxify}
{:noreply (internal-add-require namespace joxify raw-ctx)})
({:add-require namespace function arity is-rest}
(let* (requires (get-context :requires raw-ctx)
new-requires
(case is-rest
(:false (ec-dictionary/add {namespace function arity}
{:remote :not-rest {namespace function arity}}
requires))
(:true (ec-dictionary/add {namespace function :rest}
{:remote :rest {namespace function arity}}
requires))))
{:noreply (set-context :requires new-requires raw-ctx)}))
({:add-use alias arity target namespace}
(let* (use (get-context :uses raw-ctx))
{:noreply (set-context :uses (ec-dictionary/add {alias arity}
{target namespace} use)
raw-ctx)}))
({:add-def path annots name vars body replace}
{:noreply (internal-add-def path raw-ctx annots name vars body replace)})
({:add-fun-dep name arity}
(let* (fun-deps (get-context :fun-deps raw-ctx))
{:noreply (set-context :fun-deps (sets/add_element {name arity} fun-deps) raw-ctx)}))
(:push-scope
(let* (scopes (get-context :scopes raw-ctx))
{:noreply (set-context :scopes ((ec-dictionary/new :ec_dict) . scopes) raw-ctx)}))
(:pop-scope
(case (get-context :scopes raw-ctx)
((_ . scopes)
{:noreply (set-context :scopes scopes raw-ctx)})))
(:cleanup-after-transition
{:noreply (internal-cleanup-after-transition raw-ctx)})
({:add-reference path name arity cerl-var}
(let* (scopes (get-context :scopes raw-ctx))
(case scopes
((current . rest)
(case (ec-dictionary/get name :not-in-scope current)
(:not-in-scope
{:noreply (set-context :scopes
((ec-dictionary/add name {cerl-var arity} current) . rest) raw-ctx)})
(_
{:noreply (internal-add-error {{:variable-redefinition name}
(internal-erri-from-context path raw-ctx)} raw-ctx)})))
([]
{:noreply (internal-add-error {:no-scope
(internal-erri-from-context path raw-ctx)} raw-ctx)}))))
(:push-type-scope
(let* (type-scopes (get-context :type-scopes raw-ctx))
{:noreply (set-context :type-scopes ((sets/new) . type-scopes) raw-ctx)}))
(:pop-type-scope
(case (get-context :type-scopes raw-ctx)
((_ . scopes)
{:noreply (set-context :type-scopes scopes raw-ctx)})))
({:add-type-reference name arity}
(case (get-context :type-scopes raw-ctx)
((current . scopes)
{:noreply (set-context :type-scopes ((sets/add_element {name arity} current) . scopes) raw-ctx)})))
({:add-type-export name arity}
(let* (type-exports (get-context :type-exports raw-ctx))
{:noreply (set-context :type-exports (sets/add_element {name arity} type-exports) raw-ctx)}))
({:add-type type-name arity body}
(let* (types (get-context :types raw-ctx))
{:noreply (set-context :types (ec-dictionary/add {type-name arity} body types) raw-ctx)}))
({:set-context-all args}
{:noreply (lists/foldl (fn (set-val raw-ctx1)
(case set-val
({field value}
(set-context field value raw-ctx1))))
raw-ctx args)})
({:result result}
{:noreply (set-context :result result raw-ctx)})
({:errors errors}
{:noreply (set-context :errors errors raw-ctx)})
({:warnings warnings}
{:noreply (set-context :warnings warnings raw-ctx)})
(:stop-context
{:stop :normal raw-ctx})))
(defn+ handle_info (info state)
{:noreply state})
(defn+ terminate (reason state)
:ok)
(defn+ code_change (old-vsn state extra)
{:ok state})
;; ### Publically Facing Context API
(defn+ start-context (annots namespace-name)
(start-context ([(:annots . annots)
(:namespace-name . namespace-name)])))
(defn+ get-raw-context (ctx)
(gen-server/call ctx :get-raw-context))
(defn set-context-all-ctx (ctx args)
(gen-server/cast ctx {:set-context-all args}))
(defn add-warning-ctx (ctx path warning)
(gen-server/cast ctx {:add-warning path warning}))
(defn add-error-ctx (ctx path error)
(gen-server/cast ctx {:add-error path error}))
(defn+ namespace-name-ctx (ctx)
(gen-server/call ctx :namespace-name))
(defn+ namespace-name-ctx (ctx namespace-name)
(gen-server/cast ctx {:namespace-name namespace-name}))
(defn anon-fun-index-ctx (ctx)
(gen-server/call ctx :anon-fun-index))
(defn options-ctx (ctx)
(gen-server/call ctx :options))
(defn options-ctx (ctx options)
(gen-server/cast ctx {:options options}))
(defn exports-ctx (ctx)
(gen-server/call ctx :exports))
(defn exports-ctx (ctx exports)
(gen-server/cast ctx {:exports exports}))
(defn definitions-ctx (ctx)
(gen-server/call ctx :definitions))
(defn rests-ctx (ctx)
(gen-server/call ctx :rests))
(defn macros-ctx (ctx)
(gen-server/call ctx :macros))
(defn types-ctx (ctx)
(gen-server/call ctx :types))
(defn type-exports-ctx (ctx)
(gen-server/call ctx :type-exports))
(defn unexported-macros-ctx (ctx)
(gen-server/call ctx :unexported-macros))
(defn warnings-ctx (ctx)
(gen-server/call ctx :warnings))
(defn warnings-ctx (ctx warnings)
(gen-server/cast ctx {:warnings warnings}))
(defn errors-ctx (ctx)
(gen-server/call ctx :errors))
(defn errors-ctx (ctx errors)
(gen-server/cast ctx {:errors errors}))
(defn line-ctx (ctx)
(gen-server/call ctx :line))
(defn line-ctx (ctx line-annots)
(gen-server/cast ctx {:line line-annots}))
(defn attrs-ctx (ctx)
(gen-server/call ctx :attrs))
(defn error-count-ctx (ctx)
(gen-server/call ctx :error-count))
(defn+ annots-ctx (ctx)
(gen-server/call ctx :annots))
(defn+ annots-ctx (ctx annots)
(gen-server/cast ctx {:annots annots}))
(defn result-ctx (ctx)
(gen-server/call ctx :result))
(defn result-ctx (ctx result)
(gen-server/cast ctx {:result result}))
(defn function-name-ctx (ctx)
(gen-server/call ctx :function-name))
(defn function-name-ctx (ctx name)
(gen-server/cast ctx {:function-name name}))
(defn filename-ctx (ctx)
(gen-server/call ctx :filename))
(defn filename-ctx (ctx filename)
(gen-server/cast ctx {:filename filename}))
(defn namespace-transition-ctx (ctx)
(gen-server/call ctx :namespace-transition))
(defn namespace-transition-ctx (ctx namespace-transition)
(gen-server/cast ctx {:namespace-transition namespace-transition}))
(defn cleanup-after-transition-ctx (ctx)
(gen-server/cast ctx :cleanup-after-transition))
(defn warning-count-ctx (ctx)
(gen-server/call ctx :warning-count))
(defn incr-fun-index-ctx (ctx)
(gen-server/cast ctx :incr-fun-index))
(defn+ add-export-ctx (ctx annots fun-name arity)
(gen-server/cast ctx {:add-export fun-name arity annots}))
(defn add-rest-ctx (path ctx name arity)
(gen-server/cast ctx {:add-rest name arity path}))
(defn add-macro-ctx (ctx name arity path)
(gen-server/cast ctx {:add-macro name arity path}))
(defn add-unexported-macro-ctx (path ctx name arity)
(gen-server/cast ctx {:add-unexported-macro name arity path}))
(defn+ add-attr-ctx (ctx key value)
(gen-server/cast ctx {:add-attr key value}))
(defn+ add-alias-ctx (ctx aliased-name namespace)
(gen-server/cast ctx {:add-alias aliased-name namespace}))
(defn+ add-require-ctx (ctx namespace joxify)
(gen-server/cast ctx {:add-require namespace joxify}))
(defn+ add-require-ctx (ctx namespace)
(add-require-ctx ctx namespace :false))
(defn+ add-pre-require-ctx (ctx namespace function arity is-rest)
(gen-server/cast ctx {:add-require namespace function arity is-rest}))
(defn+ requires-ctx (ctx)
(gen-server/call ctx :requires))
(defn+ add-use-ctx (ctx alias arity target namespace)
(gen-server/cast ctx {:add-use alias arity target namespace}))
(defn+ uses-ctx (ctx)
(gen-server/call ctx :uses))
(defn+ add-def-ctx (path ctx annots name vars body replace)
(gen-server/cast ctx {:add-def path annots name vars body replace}))
(defn+ add-def-ctx (path ctx annots name vars body)
(add-def-ctx path ctx annots name vars body :no-replace))
(defn+ add-exported-def-ctx (path ctx annots name vars body replace)
(let* (arity (erlang/length vars))
(add-export-ctx ctx annots name arity)
(add-def-ctx path ctx annots name vars body replace)))
(defn+ add-exported-def-ctx (path ctx annots name vars body)
(add-exported-def-ctx path ctx annots name vars body :no-replace))
(defn add-fun-dep-ctx (ctx name arity)
(gen-server/cast ctx {:add-fun-dep name arity}))
(defn+ push-scope-ctx (ctx)
(gen-server/cast ctx :push-scope))
(defn+ pop-scope-ctx (ctx)
(gen-server/cast ctx :pop-scope))
(defn+ add-reference-to-scope-ctx (path ctx name arity cerl-var)
(gen-server/cast ctx {:add-reference path name arity cerl-var}))
(defn+ resolve-reference-ctx (path ctx ref possible-arity)
(gen-server/call ctx {:resolve-reference path ref possible-arity}))
(defn push-type-scope-ctx (ctx)
(gen-server/cast ctx :push-type-scope))
(defn pop-type-scope-ctx (ctx)
(gen-server/cast ctx :pop-type-scope))
(defn add-type-reference-to-scope-ctx (ctx name arity)
(gen-server/cast ctx {:add-type-reference name arity}))
(defn resolve-type-reference-ctx (ctx name arity)
(gen-server/call ctx {:resolve-type-reference name arity}))
(defn add-type-export-ctx (ctx type-name arity)
(gen-server/cast ctx {:add-type-export type-name arity}))
(defn add-type-ctx (ctx type-name arity body)
(gen-server/cast ctx {:add-type type-name arity body}))
(defn+ stop-context (ctx)
(gen-server/cast ctx :stop-context))
(defn add-error-r-nil-ctx (ctx path error)
(gen-server/cast ctx {:add-error path error})
(cerl/c_nil))
;; The Compiler
;; ------------
;;
;; The parser is complete and now its time to turn our attention to
;; the compiler. we start by defining a compilation context to use for
;; scope management and variable lookup.
;; #### Context Helper Functions
;;
;; These mostly exist to reduce the visual cost of function calls to
;; get values from the annotations.
(defn idx-from-context (actions path0 ctx)
(gen-server/call ctx {:thing-from-context actions path0 get-idx-annots/2}))
(defn annots-from-context (actions path0 ctx)
(gen-server/call ctx {:thing-from-context actions path0 get-line-annots/2}))
(defn erri-from-context (actions path0 ctx)
(let* (idx (idx-from-context actions path0 ctx)
filename (ec-dictionary/get :annots (annots-ctx ctx)))
{filename idx}))
;; The Lexer and Parser
;; --------------------
;;
;; The parser for Joxa is a [Parsing Expression
;; Grammer](http://en.wikipedia.org/wiki/Parsing_expression_grammar)3
;; based heavily on the Neotoma project. It provides two classes of
;; parse functions. The first set of parse functions are prefixed by a
;; 'p-' and are low level constructor functions that are not part of
;; the Joxa grammer. The second set are parsing functions that are not
;; prefixed with a 'p-' and represent parts of the Joxa grammer it
;; self. These are public because it is expected that they will be
;; used for reader macros.
(defn+ line (index)
(case index
({l _}
l)))
(defn+ column (index)
(case index
({_ c}
c)))
(defn+ p-advance-index (matched-input index)
(case index
({ln col}
(case matched-input
(mi
(when (or (is-list mi)
(is-binary mi)))
(lists/foldl p-advance-index/2 index
(unicode/characters_to_list mi)))
(\\n
{(+ ln 1) 1})
(_
{ln (+ col 1)})))))
(defn+ p-charclass (class)
(case class
(class (when (is-list class))
(p-charclass (erlang/list_to_binary class)))
(class
(when (is-binary class))
(case (re/compile class [:unicode :dotall])
({:ok re}
(fn (inp index)
(case (re/run inp re [:anchored])
({:match ({0 length} . _)}
(case (erlang/split_binary inp length)
({head tail}
{head tail (p-advance-index head index)})))
(_
{:fail {:expected {:character-class
(erlang/binary_to_list class)} index}}))))))))
(defn+ p-anything ()
(fn (input index)
(case input
(<<>>
{:fail {:expected :any-character index}})
(<<(c :utf8) (rest :binary)>>
{c rest (p-advance-index c index)}))))
(defn+ p-string (s)
(case s
(s (when (is-list s))
(p-string (erlang/list_to_binary s)))
(s (when (is-binary s))
(let* (length (erlang/byte_size s))
(fn (input index)
(case input
(<<(s :size length :binary) (rest :binary)>>
{s rest (p-advance-index s index)})
(_
{:fail {:expected {:string s} index}})))))))
(defn+ p-scan (p inp index acc)
(case inp
([]
{(lists/reverse acc) [] index})
(_
(case (p inp index)
({:fail _}
{(lists/reverse acc) inp index})
({result inprem new-index}
(p-scan p inprem new-index (result . acc)))))))
(defn+ p-one-or-more (p)
(fn (input index)
(let* (result (p-scan p input index []))
(case result
({(_ . _) _ _}
result)
(_
(case (p input index)
({:fail {:expected failure e}}
{:fail {:expected {:at-least-one failure} index}})))))))
(defn+ p-zero-or-more (p)
(fn (input index)
(p-scan p input index [])))
(defn+ p-attempt (in-p input index first-failure)
(case in-p
([]
first-failure)
((p . parsers)
(case (p input index)
((= {:fail _} failure)
(case first-failure
(:none
(p-attempt parsers input index failure))
(_
(p-attempt parsers input index first-failure))))
(result
result)))))
(defn+ p-choose (parsers)
(fn (input index)
(p-attempt parsers input index :none)))
(defn+ p-all (in-p input index acc)
(case in-p
([]
{(lists/reverse acc) input index})
((p . parsers)
(case (p input index)
((= {:fail _} failure)
failure)
({result input-rem new-index}
(p-all parsers input-rem new-index (result . acc)))))))
(defn+ p-seq (p)
(fn (input index)
(p-all p input index [])))
(defn+ p-and (p)
(fn (input index)
(p-all p input index [])))
(defn+ p-assert (p)
(fn (input index)
(case (p input index)
((= {:fail _} failure)
failure)
(_
{[] input index}))))
(defn+ p-not (p)
(fn (input index)
(case (p input index)
({:fail _}
{[] input index})
({result _ _}
{:fail {:expected {:no-match result} index}}))))
(defn+ p-optional (p)
(fn (input index)
(case (p input index)
({:fail _}
{[] input index})
((= {_ _ _} success)
success))))
(defn+ p-eol ()
(fn (input index)
((p-charclass <<"[\n\r]">>) input index)))
(defn+ p-eof ()
(fn (input index)
(case input
(<<>>
{:eof <<>> index})
(_
{:fail {:expected :eof index}}))))
;; ### Memoization Support Functions
;;
;; The following functions support memoization of for the parser. This
;; is critically important to getting any kind of reasonable speed at
;; all out of the parser.
(definline memo-table-name ()
(erlang/get :parse-memo-table))
(definline get-memo (index name)
(case (ets/lookup (memo-table-name) index)
([]
{:error :not-found})
([{index plist}]
(case (proplists/lookup name plist)
({name result}
{:ok result})
(_
{:error :not-found})))))
(definline memoize (index name result)
(let* (memo (case (ets/lookup (memo-table-name) index)
([]
[])
([{index plist}]
plist)))
(ets/insert (memo-table-name) {index ({name result} . memo)})))
(defn+ release-memo ()
(ets/delete (memo-table-name)))
(defn+ setup-memo ()
(erlang/put :parse-memo-table (ets/new :joxa-compiler [:set])))
(defn+ p (inp start-index name parse-fun transform-fun)
(case (get-memo start-index name)
({:ok memo}
memo)
(_
(let* (result (case (parse-fun inp start-index)
((= {:fail _} failure)
failure)
({match inp-rem new-index}
{(transform-fun match start-index)
inp-rem new-index})))
(memoize start-index name result)
result))))
(defn+ p (inp start-index name parse-fun)
(p inp start-index name parse-fun (fn (n idx) n)))
;; ### Joxa Grammer Lexer
;;
;; The following functions represent the grammer of Joxa and can be
;; built on and used by reader macros.
(defn+ space (input index)
(p input index :space
(p-charclass <<"[ \t\n\s\r]">>)))
(defn+ comment (input index)
(p input index :comment
(p-seq [(p-string <<";">>)
(p-zero-or-more (p-charclass <<"[^\n\r]">>))
(p-choose [(p-eol)
(p-eof)])])))
(defn+ ignorable (input index)
(p input index :ignorable
(p-optional (p-zero-or-more (p-choose [space/2
(p-string <<",">>)
comment/2])))
(fn (node idx)
[])))
(defn+ digit (input index)
(p input index :digit
(p-charclass <<"[0-9]">>)))
(defn+ int-part (input index)
(p input index :int-part
(p-seq [(p-optional (p-string <<"-">>)),
(p-one-or-more digit/2)])))
(defn+ frac-part (input index)
(p input index :frac-part
(p-seq [(p-string <<".">>)
(p-one-or-more digit/2)])))
(defn+ integer (input index)
(p input index :integer
int-part/2
(fn (node idx)
(let* (result
(erlang/list_to_integer
(erlang/binary_to_list
(erlang/iolist_to_binary node))))
{:integer result idx}))))
(defn+ e (input index)
(p input index :e
(p-seq [(p-charclass <<"[eE]">>)
(p-optional (p-choose [(p-string <<"+">>)
(p-string <<"-">>)]))])))
(defn+ exp-part (input index)
(p input index :exp-part
(p-seq [e/2
(p-one-or-more digit/2)])))
(defn+ float (input index)
(p input index :float
(p-seq [int-part/2
frac-part/2
(p-optional exp-part/2)])
(fn (node idx)
(let* (result (erlang/list_to_float
(erlang/binary_to_list
(erlang/iolist_to_binary node))))
{:float result idx}))))
(defn+ char (input index)
(p input index :char
(p-seq [(p-string <<"\\">>)
(p-choose [(p-string "\\\"")
(p-string "\\\\")
(p-string "\\b")
(p-string "\\f")
(p-string "\\n")
(p-string "\\r")
(p-string "\\t")
(p-anything)])])
(fn (node idx)
(case node
([_ <<"\\\"">>]
{:char \" idx})
([_ <<"\\\\">>]
{:char \\ idx})
([_ <<"\\b">>]
{:char \\b idx})
([_ <<"\\f">>]
{:char \\f idx})
([_ <<"\\n">>]
{:char \\n idx})
([_ <<"\\r">>]
{:char \\r idx})
([_ <<"\\t">>]
{:char \\t idx})
([_ char]
{:char char idx})))))
(defn+ ident (input index)
(p input index :ident
(p-one-or-more
(p-and [(p-not
(p-choose [(p-string <<"<<">>)
(p-string <<">>">>)
(p-string <<"~@">>)
(p-charclass <<"[,`~'\\\\{}/\t\n\s\r\\(\\)\\[\\]\"]">>)]))
(p-anything)]))
(fn (node idx)
(let* (result
(erlang/list_to_atom
(erlang/binary_to_list
(erlang/iolist_to_binary node))))
{:ident result idx}))))
(definline convert-stringlike-thing (node)
(case node
([_ string _]
(let* (convert (lists/map (fn (el)
(case el
([_ <<"\\'">>]
<<"'">>)
([_ <<"\\\"">>]
<<"\"">>)
([_ <<"\\\\">>]
<<"\\">>)
([_ <<"\\b">>]
<<"\b">>)
([_ <<"\\f">>]
<<"\f">>)
([_ <<"\\n">>]
<<"\n">>)
([_ <<"\\r">>]
<<"\r">>)
([_ <<"\\t">>]
<<"\t">>)
(_
el)))
string))
(erlang/binary_to_list (erlang/iolist_to_binary convert))))))
(defn+ quoted-ident (input index)
(p input index :quoted-ident
(p-seq [(p-string ":'")
(p-zero-or-more (p-seq [(p-not (p-string "'"))
(p-choose [(p-string "\\'")
(p-string "\\\"")
(p-string "\\\\")
(p-string "\\b")
(p-string "\\f")
(p-string "\\n")
(p-string "\\r")
(p-string "\\t")
(p-anything)])]))
(p-string "'")])
(fn (node idx)
{:ident (erlang/list_to_atom
(convert-stringlike-thing node)) idx})))
(defn inclusive-ident (input index)
(p input index :ident-types
(p-choose [quoted-ident/2
ident/2])))
(defn+ fun-reference (input index)
(p input index :fun-reference
(p-choose [(p-seq [inclusive-ident/2
(p-string "/")
inclusive-ident/2
(p-string "/")
integer/2])
(p-seq [inclusive-ident/2
(p-string "/")
integer/2])
(p-seq [inclusive-ident/2
(p-string "/")
inclusive-ident/2])])
(fn (node idx)
(case node
([{:ident namespace _} _
{:ident function _} _
{:integer arity _}]
{:call {:--fun namespace function arity} idx})
([{:ident function _} _
{:integer arity _}]
{:call {:--fun function arity} idx})
([{:ident namespace _} _
{:ident function _}]
{:call {:--fun namespace function} idx})))))
(defn+ string (input index)
(p input index :string
(p-seq [(p-string "\"")
(p-zero-or-more (p-seq [(p-not (p-string "\""))
(p-choose [(p-string "\\\"")
(p-string "\\\\")
(p-string "\\b")
(p-string "\\f")
(p-string "\\n")
(p-string "\\r")
(p-string "\\t")
(p-anything)])]))
(p-string "\"")])
(fn (node idx)
{:string (convert-stringlike-thing node) idx})))
(defn+ quote (input index)
(p input index :quote
(p-seq [(p-choose [ (p-string "'")
(p-string ":")])
value/2])
(fn (node idx)
(case node
([_ item]
{:quote item idx})))))
(defn+ quasiquote (input index)
(p input index :quasiquote
(p-seq [(p-string "`")
value/2])
(fn (node idx)
(case node
([_ item]
{:quasiquote item idx})))))
(defn+ unquote (input index)
(p input index :unquote
(p-seq [(p-string "~")
value/2])
(fn (node idx)
(case node
([_ item]
{:unquote item idx})))))
(defn+ unquote-splicing (input index)
(p input index :unquote-splicing
(p-seq [(p-string "~@")
value/2])
(fn (node idx)
(case node
([_ item]
{:unquote-splicing item idx})))))
(defn+ list (input index)
(p input index :list
(p-choose [(p-seq [(p-string "(")
ignorable/2
value/2
(p-zero-or-more (p-seq [ignorable/2
value/2]))
ignorable/2
(p-string ")")])
(p-seq [(p-string "(")
ignorable/2
(p-string ")")])
(p-seq [(p-string "[")
ignorable/2
value/2
(p-zero-or-more (p-seq [ignorable/2
value/2]))
ignorable/2
(p-string "]")])
(p-seq [(p-string "[")
ignorable/2
(p-string "]")])])
(fn (node idx)
(case node
([<<"(">> _ h t _ _]
{:list (lists/flatten [h t]) idx})
([<<"[">> _ h t _ _]
{:literal-list (lists/flatten [h t]) idx})
([<<"[">> _ _]
{:literal-list [] idx})
([_ _ _]
{:list [] idx})))))
(defn+ tuple (input index)
(p input index :tuple
(p-choose [(p-seq [(p-string "{")
ignorable/2
value/2
(p-zero-or-more (p-seq [ignorable/2
value/2]))
ignorable/2
(p-string "}")])
(p-seq [(p-string "{")
ignorable/2
(p-string "}")])])
(fn (node idx)
(case node
([_ _ h t _ _]
{:tuple (lists/flatten [h t]) idx})
([_ _ _]
{:tuple [] idx})))))
(defn+ binary (input index)
(let* (binary-contents (p-choose [integer/2
char/2
ident/2
list/2]))
(p input index :binary
(p-choose [(p-seq [(p-string "<<")
ignorable/2
binary-contents
(p-zero-or-more (p-seq [ignorable/2
binary-contents]))
ignorable/2
(p-string ">>")])
(p-seq [(p-string "<<")
ignorable/2
string/2
ignorable/2
(p-string ">>")])
(p-seq [(p-string "<<")
ignorable/2
(p-string ">>")])])
(fn (node idx)
(case node
([_ _ h t _ _]
{:binary (lists/flatten [h t]) idx})
([_ _ string _ _]
{:binary string idx})
([_ _ _]
{:binary [] idx}))))))
(defn+ value (input index)
(p input index :value
(p-seq [ignorable/2
(p-choose [float/2
integer/2
binary/2
fun-reference/2
quoted-ident/2
quote/2
ident/2
list/2
tuple/2
string/2
quasiquote/2
unquote-splicing/2
unquote/2
char/2])
ignorable/2])
(fn (node idx)
(lists/nth 2 node))))
;; ### Path Hashing for Line and Type Information
;;
;; We have the problem that for macros and for ease of parsing we want
;; to keep the AST as clean as possible. That is, we want it to be as
;; close to a normal list as we can get away with. However, we want to
;; be able to hang information on the graph that the AST
;; represents. Things like line numbers, additional type information
;; etc. However, in erlang we cant do that without polluting the graph
;; itself and making it harder for user written macros to be
;; implemented. So we need some way to identify specific points in the
;; graph that is the AST that we can then use as a key on this
;; additional information that we would like to show.
;;
;; In an AST nodes are identified by their location in the graph. That
;; is, every node in the graph is identified by the path leading to
;; that node. Lets look at an example.
;;
;; (hello world (I rock))
;;
;; In this case the 'I' node could be identified by the path [hello,
;; world, <start of children>, I]. This should be a unique identifier
;; for any point in the graph assuming that there is a single root
;; term being parsed.
;;
;; If that is true we can replace the actual elements with their
;; positions in the list. So the example above would become. [1, 3,
;; 1]. Where the outer list is 1 (everything starts at one) the 3rd
;; position is the list and the first element in that third
;; position. Lets look at something a bit more something more realistic.
;;
;; (defn+ hello-world [foo bar] (baz bang bong))
;;
;; In this example the bang node could be identified by everything
;; leading up to it. So the path would be [defn+, hello-world,
;; <children>, <start-of_children>, bang]. Lets translate this to our
;; simple numerical paths. [1, 4, 2]. This should work to any level in
;; the graph.
;;
;; We can make it even easier to manipulate buy having the firstest
;; point in the graph be the closest point in the list so that we can
;; push onto the list as we go forward. The actual path in the example
;; above would be [2, 4, 1] and built up each time we see a list.
(defn+ new-path ()
{1, []})
(defn+ incr-path (pos path)
(case path
({:suspended _}
path)
({oldpos oldpath}
{(+ pos oldpos) oldpath})))
(defn+ incr-path (path)
(incr-path 1 path))
(defn+ traverse-path (path)
(case path
({:suspended _}
path)
({old-position old-path}
{1, (old-position . old-path)})))
(defn+ path? (path)
(case path
({:suspended {_ old-path}} old-path)
({_ old-path}
old-path)))
(defn+ traverse-and-get-path (path)
(path? (traverse-path path)))
(defn+ traverse-incr-path (path)
(traverse-path (incr-path path)))
(defn+ traverse-incr-path (amount path)
(traverse-path (incr-path amount path)))
(defn suspend (path)
"Suspends all pathing additions. This is mostly useful for
macros. After a macro call is made paths no longer sensical. This
suspends all pathing at a specific point so all later path
manipulation calls have no effect. This means that the line number of
errors in a generated function will always be the line number of the macro."
(case path
({:suspended _}
path)
(_
{:suspended path})))
;; ### Annotation storage and retrieval
;;
;; With path support in place its time take care of the annotations
;; themselves. We want the api to handle formating and internal
;; storage forms. As long as we give it a good path we want to get
;; back what we ask for.
(defn+ new-annots ()
(ec-dictionary/new :ec_dict))
(defn+ make-annots (path filename type idx annotations)
(case idx
({line _}
(ec-dictionary/add path {type idx [line {:file filename}]}
annotations))))
;; sometimes an invalid path is passed in. This is unfortunate but
;; things like macros mangle the path in currently unforseable
;; ways. With this in mind we keep backing up the path until such time
;; that we get a valid annotation. This lets us give at least the line
;; number and annotations of the top most related form.
(defn get-valid-annots (path annotations)
(case path
([]
:not-found)
((_ . rest)
(try*
(ec-dictionary/get path annotations)
(catch (type body)
(case {type body}
({:throw :not_found}
(get-valid-annots rest annotations))))))))
(defn+ get-type-annots (path annotations)
(case (get-valid-annots path annotations)
(:not-found
:unknown)
({type _ _}
type)))
(defn+ get-idx-annots (path annotations)
(case (get-valid-annots path annotations)
(:not-found
{0 0})
({_ idx _}
idx)))
(defn+ get-line-annots (path annotations)
(case (get-valid-annots path annotations)
(:not-found
[0 {:file ""}])
({_ _ line}
line)))
(defn+ get-line-annots (path extra annotations)
(let* (annots (get-line-annots path annotations))
(extra . annots)))
;; ### The First Ast Transformation
;;
;; Most of the AST transformations in Joxa happen via macros. however,
;; this very first initial transformation happens here. Turning the
;; marked up AST into an annotated lisp AST where the annotations are
;; hidden unless requested.
(definline convert-list-ast (path0 filename annotations0 elements idx)
(let* (transformed
(lists/foldl
(fn (el, acc)
(case acc
({path1 annotations1 elements-acc}
(let* (result
(transform-ast (traverse-path path1) filename annotations1 el))
(case result
({annotations2 transformed}
{(incr-path path1) annotations2
(transformed . elements-acc)}))))))
{path0 annotations0 []}
elements))
transformed))
(definline convert-list-call-ast (path0 filename annotations0 elements idx type)
(let* (transformed
(convert-list-ast (incr-path path0) filename
annotations0 elements idx))
(case transformed
({_ annotations3 transform-list}
(let* (annotations4 (make-annots (traverse-and-get-path path0)
filename
:ident
idx annotations3))
{(make-annots (path? path0)
filename
type idx
annotations4)
(type . (lists/reverse transform-list))})))))
(definline convert-binary-string (path0 filename annotations0 elements idx)
(let* (transformed
(lists/foldl
(fn (el, acc)
(case acc
({path1 annotations1 elements-acc}
{(incr-path path1)
(make-annots (traverse-and-get-path path1)
filename
:integer
idx
annotations1)
(el . elements-acc)})))
{path0 annotations0 []}
elements))
(case transformed
({_ annotations3 transform-list}
(let* (annotations4 (make-annots
(traverse-and-get-path path0)
filename
:ident
idx annotations3))
{(make-annots (path? path0)
filename
:binary idx
annotations4)
(:binary . (lists/reverse transform-list))})))))
(defn+ transform-ast (path0 filename annotations node)
(case node
({:call mfa idx}
{(make-annots (path? path0)
filename
:call idx annotations) mfa})
({:literal-list list idx}
(convert-list-call-ast path0 filename annotations list idx :list))
({:binary {:string string _} idx}
(convert-binary-string path0 filename annotations string idx))
({:binary list idx}
(convert-list-call-ast path0 filename annotations list idx :binary))
({:tuple list idx}
(let* (transformed (convert-list-ast path0 filename annotations list idx))
(case transformed
({_ annotations1 transform-list}
{(make-annots (path? path0)
filename
:tuple idx
annotations1)
(erlang/list_to_tuple (lists/reverse transform-list))}))))
({:list list idx}
(let* (transformed (convert-list-ast path0 filename annotations list idx))
(case transformed
({_ annotations1 transform-list}
{(make-annots (path? path0)
filename
:list idx
annotations1)
(lists/reverse transform-list)}))))
({:string result idx}
{(make-annots (path? path0) filename :string idx
(make-annots (traverse-and-get-path path0)
filename
:ident idx
annotations))
[:string, result]})
({type (= val {_ _ _}) idx}
(let* (result (transform-ast (traverse-incr-path path0)
filename
annotations val))
(case result
({annotations1 p-val}
{(make-annots (path? path0) filename type idx
(make-annots (traverse-and-get-path path0)
filename
:ident idx
annotations1))
[type, p-val]}))))
({type val idx}
{(make-annots (path? path0) filename type idx annotations) val})))
;; These are mostly exponsed for testing purposes
(defn+ intermediate-parse (input index)
(setup-memo)
(let* (result (value input index))
(release-memo)
result))
(defn+ intermediate-parse (input)
(intermediate-parse input {1,1}))
(defn+ new-index ()
{1,1})
(defn+ has-more-data-to-parse (input)
(case input
(<<>>
:false)
({:parse-output <<>> _ _}
:false)
(_
:true)))
(defn do-parse (ctx path input idx0)
(case input
(<<>>
{<<>> path idx0})
(_
(case (intermediate-parse input idx0)
({:fail {:expected expected idx1}}
(add-error-ctx ctx path {:parse-fail expected idx1})
{:error input})
({intermediate-ast rest idx2}
(case (transform-ast
(traverse-path path)
(filename-ctx ctx)
(annots-ctx ctx)
intermediate-ast)
({annots1 final-ast}
(annots-ctx ctx annots1)
{final-ast {:parse-output rest path idx2}})))))))
(defn+ parse (ctx input)
(case input
(input (when (is-binary input))
(do-parse ctx
(new-path)
input
(new-index)))
({:parse-output new-input path index}
(do-parse ctx (incr-path path) new-input index))))
(defn+ parse-file (ctx filename)
(filename-ctx ctx filename)
(case (file/read_file filename)
({:ok bin}
(parse ctx bin))))
;; Namespace Compilation
;; ------------------
;;
;; The form of the namespace is defined as follows.
;;
;; (namespace <namespace_name>
;; <require>
;; <use>
;; <attributes>)
;;
;; The namespace clause is a special form and its contents are not evaluated.
;;
;; comp compiles the provided AST into a Joxa context. Later that context
;; must be compiled to core erlang.
(defn get-exports (namespace)
(let* (mod-info (erlang/make_fun namespace :module_info 1)
exports (mod-info :exports))
(lists/map (fn (el)
(case el
({fun arity}
{{fun arity} fun})))
exports)))
(defn gather-fun-arity-pairs (path ctx fun-arity-list acc)
(case fun-arity-list
(({:--fun fun arity} . rest)
(gather-fun-arity-pairs path ctx rest ({fun arity} . acc)))
([] acc)
(inv-f
(add-error-ctx ctx path {:invalid-use :invalid-fun-spec inv-f})
acc)))
(defn gather-fun-alias-pairs (path ctx fun-alias-pairs acc)
(case fun-alias-pairs
(([{:--fun fun arity} alias] . rest)
(when (erlang/is_atom alias))
(gather-fun-alias-pairs path ctx rest ({{fun arity} alias} . acc)))
([]
acc)
(inv-f
(add-error-ctx ctx path {:invalid-use :invalid-fun-spec inv-f})
acc)))
(defn populate-use-into-context (ctx namespace-name imports)
(case imports
([]
:ok)
(_
(lists/foreach (fn (el)
(case el
({{fun-name arity} alias-name}
(add-use-ctx ctx alias-name arity fun-name namespace-name))))
imports))))
;; Joxa Namespace Definitions
;; -----------------------
;;
;; Namespace declarations in Joxa are more complex then namespace definitions in
;; Erlang. They follow the Clojure model much more closely then the Erlang
;; namespace. That is that all namespaces used in the system must be required. You
;; may provide an alias for a dependent namespace name in both the require
;; clause and the use clauses. You may also import functions from namespaces in
;; the use clause.
;;
;; ### Namespace Form
;; The form of the namespace is defined as follows.
;;
;; (namespace <namespace_name>
;; <require>
;; <use>
;; <attributes>)
;;
;; The namespace clause is a special form and its contents are not evaluated.
;;
;; comp compiles the provided AST into a Joxa context. Later that context
;; must be compiled to core erlang.
(defn check-for-invalid-fun-arity-pairs (path ctx fun-arity-pairs imports)
(lists/foreach (fn (fun-arity)
(case fun-arity
({fun arity}
(case (lists/any (fn (import)
(case import
({{_ arity} fun}
:true)
(_
:false))) imports)
(:true :ok)
(:false
(add-error-ctx ctx path {:invalid-use :non-existant-fun-name {fun arity}}))))))
fun-arity-pairs))
(defn filter-imports-to-onlys (path ctx target-funs imports0)
(let* (fun-arity-pairs (gather-fun-arity-pairs path ctx target-funs '()))
;; check for fun-arity-pairs that doent actually exist
(check-for-invalid-fun-arity-pairs path ctx fun-arity-pairs imports0)
(lists/filter (fn (import)
(case import
({{fun arity} alias}
(lists/any (fn (fun-arity)
(case fun-arity
({alias arity}
:true)
(_
:false))) fun-arity-pairs)))) imports0)))
(defn exclude-specific-funs (path ctx excluded-funs imports0)
(let* (fun-arity-pairs (gather-fun-arity-pairs path ctx excluded-funs []))
(check-for-invalid-fun-arity-pairs path ctx fun-arity-pairs imports0)
(lists/filter (fn (import)
(case import
({{fun arity} alias}
(lists/all (fn (fun-arity)
(case fun-arity
({alias arity}
:false)
(_
:true))) fun-arity-pairs)))) imports0)))
(defn rename-funs (path ctx renames imports0)
(let* (fun-alias-pairs (gather-fun-alias-pairs path ctx renames []))
(lists/map (fn (import)
(case import
({{fun arity} alias}
(case (ec-lists/search (fn (el)
(case el
({{alias arity} new-alias}
{:ok new-alias})
(_
:not_found)))
fun-alias-pairs)
({:ok new-alias _}
{{fun arity} new-alias})
(:not_found
import))))) imports0)))
(defn handle-use-clauses (path ctx forms namespace-name imports0)
(case forms
([]
(populate-use-into-context ctx namespace-name imports0))
(('(quote joxify) . rest)
(add-alias-ctx ctx (joxify-name namespace-name) namespace-name)
(handle-use-clauses path ctx rest namespace-name
(lists/map (fn (el)
(case el
({{fun arity} alias}
{{fun arity} (joxify-name alias)})))
imports0)))
(('(quote only) . (target-funs . rest))
(when (and (erlang/is_atom namespace-name)
(is-list target-funs)))
(let* (imports1 (filter-imports-to-onlys path ctx target-funs imports0))
(handle-use-clauses path ctx rest namespace-name imports1)))
(('(quote exclude) . (target-funs . rest))
(when (and (erlang/is_atom namespace-name)
(is-list target-funs)))
(let* (imports1 (exclude-specific-funs path ctx target-funs imports0))
(handle-use-clauses path ctx rest namespace-name imports1)))
(('(quote rename) . (target-funs . rest))
(when (and (erlang/is_atom namespace-name)
(is-list target-funs)))
(let* (imports1 (rename-funs path ctx target-funs imports0))
(handle-use-clauses path ctx rest namespace-name imports1)))
(_
(add-error-ctx ctx path {:invalid-use-clause {:bad-use-part forms}}))))
(defn namespace-exists? (ctx mod-name)
(try*
(case (code/ensure_loaded mod-name)
({:module _}
:true)
({:error :embedded}
:true)
({:error :native_code}
:true)
(_
:false))
(catch (_type _body)
:false)))
;; Use Parsing and Compilation
(defn+ make-use (path ctx form namespace-name imports)
(case form
([]
(populate-use-into-context ctx namespace-name imports))
(((use-namespace-name . clause-body) . rest)
(when (erlang/is_atom use-namespace-name))
(case (namespace-exists? ctx use-namespace-name)
(:true
(let* (imports (get-exports use-namespace-name))
(add-require-ctx ctx use-namespace-name)
(handle-use-clauses path ctx
clause-body use-namespace-name imports)
(make-use path ctx rest :undefined '())))
(:false
(add-error-ctx ctx path {:invalid-use-clause {:bad-namespace use-namespace-name}}))))
((use-namespace-name . rest)
(when (erlang/is_atom use-namespace-name))
(let* (imports (get-exports use-namespace-name))
(populate-use-into-context ctx use-namespace-name imports)
(make-use path ctx rest :undefined '())))))
;; Attribute Clauses
;; -----------------
(defn+ make-attr (path0 ctx form)
(case form
([key value]
(add-attr-ctx ctx
(make-literal (traverse-path path0) ctx key)
(make-literal (traverse-incr-path path0) ctx value)))
(_
(add-error-ctx ctx path0 :invalid-attr-clause))))
;; Require Clauses
;; ---------------
(defn+ handle-require-clause (path0 ctx namespace-name form)
(case form
([]
ctx)
(new-namespace-name
(when (erlang/and (erlang/is_atom new-namespace-name)
(erlang/== namespace-name :undefined)))
(case (namespace-exists? ctx new-namespace-name)
(:true
(add-require-ctx ctx new-namespace-name)
ctx)
(:false
(let* (idx (idx-from-context [] path0 ctx))
(add-error-ctx ctx path0
{:invalid-require-clause
{:bad-namespace new-namespace-name}})))))
((new-namespace-name . rest)
(when (erlang/and (erlang/is_atom namespace-name)
(erlang/== namespace-name :undefined)))
(case (namespace-exists? ctx new-namespace-name)
(:true
(add-require-ctx ctx new-namespace-name)
(handle-require-clause (incr-path path0) ctx new-namespace-name rest))
(:false
(let* (idx (idx-from-context [] path0 ctx))
(add-error-ctx ctx path0
{:invalid-require-clause
{:bad-namespace new-namespace-name}})))))
(([quote :joxify] . rest)
;; adding this a second time (if it happens works just fine as we
;; just overwrite the previous entries
(add-require-ctx ctx namespace-name :true)
(handle-require-clause (incr-path path0) ctx namespace-name rest))
(([quote :as] . (namespace-alias . rest))
(when (erlang/is_atom namespace-alias))
(add-alias-ctx ctx namespace-alias namespace-name)
(handle-require-clause (incr-path path0) ctx namespace-name rest))
(clause
(let* (idx (idx-from-context :traverse path0 ctx))
(add-error-ctx ctx path0 {:invalid-require-clause clause})))))
(defn+ make-require (path0 ctx forms)
(lists/foreach (fn (clause)
(handle-require-clause path0 ctx :undefined clause))
forms))
;; Namespace Body
;; --------------
(defn+ make-namespace-body (path0 ctx form)
(case form
([]
ctx)
((:require . body)
(make-require (incr-path path0) ctx body))
((:attr . body)
(make-attr (incr-path path0) ctx body))
((:use . body)
(make-use path0 ctx body :undefined []))
(_
(add-error-ctx ctx path0 :invalid-form))))
(defspec do-final-comp (context) (erlang/any))
(defn attempt-namespace-transition (path0 ctx namespace-name)
(case (namespace-name-ctx ctx)
;; Nothing to do in the case where there is no namespace
(:undefined :ok)
;; In the case there is, we need to run the transition and cleanup the context
(_
(do-final-comp ctx)
(let* (ns-trans (namespace-transition-ctx ctx))
(case ns-trans
(:no-transition :no-transition)
({transition-state transition-fun}
(namespace-transition-ctx ctx (transition-fun transition-state path0 ctx))))
(cleanup-after-transition-ctx ctx)))))
(defn+ make-namespace (path0 ctx forms)
(let* (path1 (traverse-path path0))
(case forms
((:ns . (namespace-name . rest))
(attempt-namespace-transition path0 ctx namespace-name)
(namespace-name-ctx ctx namespace-name)
(let* (annots (annots-from-context [] path0 ctx))
(lists/foldl
(fn (form path2)
(make-namespace-body (traverse-path path2) ctx form)
(incr-path path2))
(incr-path 2 path0) rest)
(line-ctx ctx annots)
:ok))
(_
(add-error-ctx ctx path0 :invalid-namespace-declaration)))))
(defn make-tuple-expr (path0 ctx values)
(case (lists/foldl (fn (val acc0)
(case acc0
({path1 acc1}
(let* (element (make-expr (traverse-path path1) ctx val))
{(incr-path path1) (element . acc1)}))))
{path0 []} values)
({_ body}
(cerl/ann_c_tuple (annots-from-context [] path0 ctx)
(lists/reverse body)))))
(defn make-seq (path0 ctx form)
(let* (annots (annots-from-context :traverse path0 ctx))
(case form
([arg1 arg2]
(let* (cerl-arg1 (make-expr (traverse-path path0) ctx arg1)
cerl-arg2 (make-expr (traverse-incr-path path0) ctx arg2))
(cerl/ann_c_seq annots cerl-arg1 cerl-arg2)))
([arg1]
(make-expr (traverse-path path0) ctx arg1))
((arg1 . rest)
(let* (cerl-arg1 (make-expr (traverse-path path0) ctx arg1)
cerl-arg2 (make-seq (incr-path path0) ctx rest))
(cerl/ann_c_seq annots cerl-arg1 cerl-arg2)))
([]
(add-error-r-nil-ctx ctx path0 :invalid-sequence)))))
(defn make-cons (annots arg1-path arg2-path ctx arg1 arg2)
(let* (cerl-arg1 (make-expr arg1-path ctx arg1)
cerl-arg2 (make-expr arg2-path ctx arg2))
(cerl/ann_c_cons annots cerl-arg1 cerl-arg2)))
(defn args-to-list (args)
(case args
([]
(cerl/ann_c_nil [:compiler_generated]))
((arg . rest)
(cerl/ann_c_cons [:compiler_generated]
arg
(args-to-list rest)))))
(defn called->rest (args0 count arity acc)
(case args0
([]
(case acc
([]
;; This is a special case to handle issues when a rest arg of
;; 1 is called.
[(cerl/ann_c_nil [:compiler_generated])])
(_
(lists/reverse acc))))
((arg . rest)
(case (erlang/< count arity)
(:true
(called->rest rest (erlang/+ count 1) arity (arg . acc)))
(:false
(called->rest [] 0 arity ((args-to-list args0) . acc)))))))
(defn runtime-called->rest (args0 count arity acc)
(case args0
([]
(case acc
([]
;; This is a special case to handle issues when a rest arg of
;; 1 is called.
[[]])
(_
(lists/reverse acc))))
((arg . rest)
(case (erlang/< count arity)
(:true
(runtime-called->rest rest (erlang/+ count 1) arity (arg . acc)))
(:false
(runtime-called->rest [] count arity (args0 . acc)))))))
(defn eval-args (path0 ctx args0)
(case (lists/foldl (fn (arg acc0)
(case acc0
({path1 acc1}
(let* (cerl (make-expr (traverse-path path1) ctx arg))
{(incr-path path1) (cerl . acc1)}))))
{path0 []} args0)
({_ args1}
(lists/reverse args1))))
(defn add-to-annots (cerl-thing annots)
(let* (old-annots (lists/filter (fn (el)
(case el
({:rest _}
:true)
({:not-rest _}
:true)
(_
:false)))
(cerl/get_ann cerl-thing)))
(cerl/set_ann cerl-thing (lists/append old-annots annots))))
(defn gensym-body ()
(let* (x (erlang/phash2 {(erlang/node) (erlang/now) (crypto/rand_bytes 16)}))
(lists/map (fn (el)
(io-lib/format "~.16B" [el]))
(erlang/binary_to_list
(binary/encode_unsigned x)))))
(defn+ gensym ()
(erlang/list_to_atom
(lists/flatten (io-lib/format "#:G~s" [(gensym-body)]))))
(defn+ gensym (prefix)
(erlang/list_to_atom
(lists/flatten (io-lib/format "#:|~s~s|" [prefix (gensym-body)]))))
(defn is-rest-var? (var)
(let* (annots (cerl/get_ann var))
(case (lists/keysearch :rest 1 annots)
({value val}
val)
(_
(case (lists/keysearch :not-rest 1 annots)
({value val}
val)
(_
:unknown))))))
(defn make-rest-apply-var (ctx annots cerl-var arg-list)
(case (is-rest-var? cerl-var)
({:rest arity}
(cerl/ann_c_apply annots
cerl-var
(called->rest arg-list 1 arity [])))
(_
(cerl/ann_c_apply annots
cerl-var
arg-list))))
(defn make-apply (path0 ctx form)
(let* (annots (annots-from-context [] path0 ctx))
(case form
((:apply . (target . args))
(let* (arg-list (eval-args (incr-path 2 path0) ctx args))
(case (resolve-reference-ctx path0 ctx target (erlang/length args))
({:remote :not-rest _ {namespace function arity}}
(cerl/ann_c_call annots
(cerl/ann_c_atom annots namespace)
(cerl/ann_c_atom annots function)
(eval-args (incr-path 2 path0) ctx args)))
({:remote :rest _ {namespace function arity}}
(cerl/ann_c_call annots
(cerl/ann_c_atom annots namespace)
(cerl/ann_c_atom annots function)
(called->rest arg-list 1 arity [])))
({:apply :not-rest _ {function arity}}
(add-fun-dep-ctx ctx function arity)
(cerl/ann_c_apply annots
(cerl/ann_c_fname annots function arity)
arg-list))
({:apply :rest _ {function arity}}
(add-fun-dep-ctx ctx function arity)
(cerl/ann_c_apply annots
(cerl/ann_c_fname annots function arity)
(called->rest arg-list 1 arity [])))
({:reference {val _}}
(make-rest-apply-var ctx annots val arg-list))
(:not-a-reference
(cerl/ann_c_apply annots
(make-expr (traverse-path path0) ctx target)
arg-list)))))
(_
(add-error-r-nil-ctx ctx path0 {:invalid-reference form})))))
(defn make-apply-rest-fun (ctx f-var arity rest-arity)
(let* (arg-list (lists/map (fn (_)
(cerl/ann_c_var [:compiler_generated]
(gensym)))
(lists/seq 1 arity))
annots [:compiler_generated])
(incr-fun-index-ctx ctx)
(cerl/ann_c_fun annots arg-list
(cerl/ann_c_apply annots
f-var
(called->rest arg-list 1 rest-arity [])))))
(defn make-remote-rest-fun (ctx namespace function arity rest-arity)
(let* (arg-list (lists/map (fn (_)
(cerl/ann_c_var [:compiler_generated]
(gensym)))
(lists/seq 1 arity))
annots [:compiler_generated])
(incr-fun-index-ctx ctx)
(cerl/ann_c_fun annots arg-list
(cerl/ann_c_call annots
(cerl/ann_c_atom annots namespace)
(cerl/ann_c_atom annots function)
(called->rest arg-list 1 rest-arity [])))))
(defn make-fun (path0 ctx form)
(let* (annots (annots-from-context [] path0 ctx))
(case form
({:--fun f a} (when (erlang/is_integer a))
(case (resolve-reference-ctx path0 ctx f a)
({:reference {var _}}
(case (erlang/and (cerl/is_c_fname var)
(== (cerl/fname_arity var) a))
(:true
(add-to-annots var annots))
(:false
(add-error-r-nil-ctx ctx path0 {:invalid-reference {f a}}))))
({:apply :not-rest _ {name a}}
(add-fun-dep-ctx ctx name a)
(cerl/ann_c_fname annots name a))
({:apply :rest _ {name rest-arity}}
(add-fun-dep-ctx ctx name rest-arity )
(make-apply-rest-fun ctx
(cerl/ann_c_fname annots name a)
a rest-arity))
(_
(add-error-r-nil-ctx ctx path0 {:invalid-reference {f a}}))))
((= ref {:--fun _ _ a})
(when (erlang/is_integer a))
(case (resolve-reference-ctx path0 ctx ref a)
({:reference (= detail {_ _})}
(add-error-r-nil-ctx ctx path0 {:invalid-reference detail}))
({:remote :not-rest _ {namespace function arity}}
(when (erlang/and (erlang/is_atom namespace)
(erlang/is_atom function)))
(cerl/ann_c_call annots
(cerl/ann_c_atom annots
:erlang)
(cerl/ann_c_atom annots
:make_fun)
[(cerl/ann_c_atom annots namespace)
(cerl/ann_c_atom annots function)
(cerl/ann_c_int annots arity)]))
({:remote :rest _ {namespace function rest-arity}}
(when (erlang/and (erlang/is_atom namespace)
(erlang/is_atom function)))
(make-remote-rest-fun ctx namespace function a rest-arity))
(_
(add-error-r-nil-ctx ctx path0 {:undefined-reference ref}))))
(_
(add-error-r-nil-ctx ctx path0 {:undefined-reference form})))))
(defn make-list (path0 ctx form)
(let* (annots (annots-from-context :traverse path0 ctx))
(case form
([]
(cerl/c_nil))
((h . t)
(let* (cerl-h (make-expr (traverse-path path0) ctx h)
cerl-t (make-list (incr-path path0) ctx t))
(cerl/ann_c_cons annots cerl-h cerl-t))))))
(defn call-macro (path ctx namespace function args continuation)
(try*
(continuation (erlang/apply namespace function args))
(catch (type body)
(add-error-r-nil-ctx ctx path
{:macro-failure {namespace function
(erlang/length args)}
{type body (erlang/get-stacktrace)}}))))
;; We auto require anything required by the namespace exporting the
;; macro. The reduces by quite a bit the confusion involved in using
;; macros
(defn auto-require (ctx namespace)
(case (get-joxa-info :requires namespace)
(:false
:ok)
(external-requires
(lists/foreach (fn (mod-name)
(add-require-ctx ctx mod-name))
external-requires))))
(defn+ make-call (path0 ctx val args macro-only?)
(let* (annots (annots-from-context [] path0 ctx))
(let* (possible-arity (erlang/length args)
path1 (traverse-path path0)
call-annots (annots-from-context [] path1 ctx))
(case (resolve-reference-ctx path0 ctx val possible-arity)
({:apply :not-rest :macro {function arity}}
(call-macro path0 ctx (namespace-name-ctx ctx) function args
(fn (expr)
(make-expr (suspend path0) ctx expr))))
({:apply :rest :macro {function arity}}
(call-macro path0 ctx (namespace-name-ctx ctx) function
(runtime-called->rest args 1 arity [])
(fn (expr)
(make-expr (suspend path0) ctx expr))))
({:remote :not-rest :macro {namespace function arity}}
(auto-require ctx namespace)
(call-macro path0 ctx namespace function args
(fn (expr)
(make-expr (suspend path0) ctx expr))))
({:remote :rest :macro {namespace function arity}}
(auto-require ctx namespace)
(call-macro path0 ctx namespace function
(runtime-called->rest args 1 arity [])
(fn (expr)
(make-expr (suspend path0) ctx expr))))
(ref
(let* (arg-list (eval-args (incr-path path0) ctx args))
(case ref
({:reference {var _}}
(when (erlang/== :false macro-only?))
(make-rest-apply-var ctx annots (add-to-annots var annots) arg-list))
({:apply :not-rest _ {name arity}}
(when (erlang/== :false macro-only?))
(add-fun-dep-ctx ctx name arity)
(cerl/ann_c_apply annots
(cerl/ann_c_fname call-annots
name
arity)
arg-list))
({:apply :rest _ {name arity}}
(when (erlang/== :false macro-only?))
(add-fun-dep-ctx ctx name arity)
(cerl/ann_c_apply annots
(cerl/ann_c_fname call-annots
name
arity)
(called->rest arg-list 1 arity [])))
({:remote :not-rest _ {namespace function possible-arity}}
(when (erlang/== :false macro-only?))
(cerl/ann_c_call annots
(cerl/ann_c_atom call-annots
namespace)
(cerl/ann_c_atom call-annots
function)
arg-list))
({:remote :rest _ {namespace function arity}}
(when (erlang/== :false macro-only?))
(cerl/ann_c_call annots
(cerl/ann_c_atom call-annots
namespace)
(cerl/ann_c_atom call-annots
function)
(called->rest arg-list 1 arity [])))
({:error error}
(add-error-r-nil-ctx ctx path0 error))
(:not-a-reference
(when (erlang/and (erlang/== :false macro-only?)
(is-list val)))
(let* (cerl-val (make-expr (traverse-path path0) ctx val))
(make-rest-apply-var ctx annots (add-to-annots cerl-val annots) arg-list)))
(:not-a-reference
(when (erlang/== :false macro-only?))
(case (resolve-reference-ctx path0 ctx val -1)
({:reference {var _}}
(make-rest-apply-var ctx annots (add-to-annots var annots) arg-list))
(_
(add-error-r-nil-ctx ctx path0 {:invalid-reference {val possible-arity}})))))))))))
(defn make-macroexpand-1 (path0 ctx val args)
(let* (annots (annots-from-context [] path0 ctx)
possible-arity (erlang/length args)
path1 (traverse-path path0)
call-annots (annots-from-context [] path1 ctx)
process-args (fn (args)
(lists/map
(fn (arg)
(cerl/ann_make_data annots {:atomic arg} []))
args)))
(case (resolve-reference-ctx path0 ctx val possible-arity)
({:apply :not-rest :macro {function arity}}
(cerl/ann_c_apply annots
(cerl/ann_c_fname call-annots
function
arity)
(process-args args)))
({:apply :rest :macro {function arity}}
(cerl/ann_c_apply annots
(cerl/ann_c_fname call-annots
function
arity)
(process-args
(runtime-called->rest args 1 arity []))))
({:remote :not-rest :macro {namespace function arity}}
(cerl/ann_c_call annots
(cerl/ann_c_atom call-annots
namespace)
(cerl/ann_c_atom call-annots
function)
(process-args args)))
({:remote :rest :macro {namespace function arity}}
(cerl/ann_c_call annots
(cerl/ann_c_atom call-annots
namespace)
(cerl/ann_c_atom call-annots
function)
(process-args (runtime-called->rest args 1 arity []))))
(_
(add-error-r-nil-ctx ctx path1 {:not-a-macro
{val possible-arity}})))))
(defn make-try (path0 ctx form)
(let* (annots (annots-from-context [] path0 ctx))
(case form
([:try* expr [:catch [type value] catch-expr]]
(when (erlang/and (erlang/is_atom type)
(erlang/is_atom value)))
(let* (cerl-expr (make-expr (traverse-incr-path path0) ctx expr)
try-var (cerl/ann_c_var (:compiler_generated . annots) (gensym))
type-var (cerl/ann_c_var annots type)
value-var (cerl/ann_c_var annots value)
ignore-var (cerl/ann_c_var (:compiler_generated . annots) (gensym)))
(push-scope-ctx ctx)
(add-reference-to-scope-ctx path0 ctx value -1 value-var)
(add-reference-to-scope-ctx path0 ctx type -1 type-var)
(let* (cerl-catch (make-expr (traverse-incr-path 2
(traverse-incr-path 2 path0))
ctx catch-expr))
(pop-scope-ctx ctx)
(cerl/ann_c_try annots cerl-expr [try-var] try-var
[type-var value-var ignore-var]
cerl-catch)
)))
(_
(add-error-r-nil-ctx ctx path0 :invalid-try-expression)))))
(defn get-bitstring (field bit)
(case field
(:var (erlang/element 2 bit))
(:size (erlang/element 3 bit))
(:unit (erlang/element 4 bit))
(:type (erlang/element 5 bit))
(:signedness (erlang/element 6 bit))
(:endianness (erlang/element 7 bit))
(_ (erlang/throw {:invalid-field :bitstring field}))))
(defn set-bitstring (field value bit)
(case field
(:var (erlang/setelement 2 bit value))
(:size (erlang/setelement 3 bit value))
(:unit (erlang/setelement 4 bit value))
(:type (erlang/setelement 5 bit value))
(:signedness (erlang/setelement 6 bit value))
(:endianness (erlang/setelement 7 bit value))
(_ (erlang/throw {:invalid-field :bitstring field}))))
(defn new-bitstring ()
{:bitstring
:undefined
:undefined
:undefined
:integer
:unsigned
:big})
(defn resolve-bitstring-defaults (value)
(case value
(_
(let* (annots '(compiler_generated)
size0 (get-bitstring :size value)
unit0 (get-bitstring :unit value)
type0 (get-bitstring :type value)
size1 (case size0
(:undefined
(case type0
(:integer 8)
(:float 64)
(:binary [:quote :all])
(:bitstring 1)
(:bits 1)
(:utf8 [:quote :undefined])
(:utf16 [:quote :undefined])
(:utf32 [:quote :undefined])))
(val
val))
unit1 (case unit0
(:undefined
(case type0
(:float (cerl/ann_c_int annots 1))
(:integer (cerl/ann_c_int annots 1))
(:bitstring (cerl/ann_c_int annots 1))
(:bits (cerl/ann_c_int annots 1))
(:binary (cerl/ann_c_int annots 8))
(:utf8 (cerl/ann_c_int annots :undefined))
(:utf16 (cerl/ann_c_int annots :undefined))
(:utf32 (cerl/ann_c_int annots :undefined))))
(val
(when (erlang/is_integer val))
(cerl/ann_c_int annots val))))
(set-bitstring :size size1
(set-bitstring :unit unit1 value))))))
(defn convert-bitstring (path ctx pairs bitstring)
(case pairs
(([:quote :size] . (value . rest))
(convert-bitstring ctx path rest (set-bitstring :size value bitstring)))
(([:quote :unit] . (value . rest))
(convert-bitstring ctx path rest (set-bitstring :unit value bitstring)))
(([:quote :little] . rest)
(convert-bitstring ctx path rest (set-bitstring :endianness :little bitstring)))
(([:quote :big] . rest)
(convert-bitstring ctx path rest (set-bitstring :endianness :big bitstring)))
(([:quote :native] . rest)
(convert-bitstring ctx path rest (set-bitstring :endianness :native bitstring)))
(([:quote :signed] . rest)
(convert-bitstring ctx path rest (set-bitstring :signedness :signed bitstring)))
(([:quote :unsigned] . rest)
(convert-bitstring ctx path rest (set-bitstring :signedness :unsigned bitstring)))
(([:quote :integer] . rest)
(convert-bitstring ctx path rest (set-bitstring :type :integer bitstring)))
(([:quote :binary] . rest)
(convert-bitstring ctx path rest (set-bitstring :type :binary bitstring)))
(([:quote :utf8] . rest)
(convert-bitstring ctx path rest (set-bitstring :type :utf8 bitstring)))
(([:quote :utf16] . rest)
(convert-bitstring ctx path rest (set-bitstring :type :utf16 bitstring)))
(([:quote :utf32] . rest)
(convert-bitstring ctx path rest (set-bitstring :type :utf32 bitstring)))
(([:quote :float] . rest)
(convert-bitstring ctx path rest (set-bitstring :type :float bitstring)))
([]
bitstring)
(_
(add-error-ctx ctx path :invalid-bitstring-spec)
bitstring)))
(defn make-binary-element (element acc0)
(case acc0
({path0 ctx acc1}
(let* (idx (idx-from-context [] path0 ctx))
(case element
((var . pairs0)
(let* (path1 (traverse-path path0)
bitstring
(resolve-bitstring-defaults
(convert-bitstring path0 ctx pairs0
(new-bitstring)))
annots (annots-from-context :traverse path1 ctx)
cerl-var (make-expr path1 ctx var)
size (make-expr path1 ctx (get-bitstring :size bitstring)))
{(incr-path path1) ctx
((cerl/ann_c_bitstr annots
cerl-var
size
(get-bitstring :unit bitstring)
(cerl/ann_c_atom annots
(get-bitstring :type bitstring))
(cerl/ann_make_list annots
[(cerl/ann_c_atom annots
(get-bitstring :signedness bitstring))
(cerl/ann_c_atom annots
(get-bitstring :endianness bitstring))]))
. acc1)}))
(var (when (erlang/or (erlang/is_atom var)
(erlang/is_integer var)))
(let* (annots (annots-from-context :traverse path0 ctx)
bitstring (resolve-bitstring-defaults (new-bitstring))
cerl-var (make-expr path0 ctx var)
size (make-expr path0 ctx (get-bitstring :size bitstring)))
{(incr-path path0)
ctx
((cerl/ann_c_bitstr annots
cerl-var
size
(get-bitstring :unit bitstring)
(cerl/ann_c_atom annots (get-bitstring :type bitstring))
(cerl/ann_make_list annots
[(cerl/ann_c_atom annots
(get-bitstring :signedness bitstring))
(cerl/ann_c_atom annots
(get-bitstring :endianness bitstring))]))
. acc1)}))
(_
(add-error-ctx ctx path0 :invalid-bitstring )
{(incr-path path0)
ctx
acc1}))))))
(defn make-binary (path0 ctx form)
(let* (annots (annots-from-context [] path0 ctx))
(case form
((:binary . args)
(case (lists/foldl make-binary-element/2 {(incr-path path0) ctx []} args)
({_ ctx acc}
(cerl/ann_c_binary annots (lists/reverse acc))))))))
(defn get-expr-arity (expr)
(case (cerl/type expr)
(:var
(case (cerl/var_name expr)
({_ arity} (when (erlang/is_integer arity))
arity)
(_
-1)))
(:fun
(cerl/fun_arity expr))
(_ -1)))
(defn arg-arity (args count)
(case args
([]
{[{:not-rest count}] count})
((:&rest . _)
{[{:rest (+ count 1)}] (+ count 1)})
((_ . rest)
(arg-arity rest (+ count 1)))))
(defn make-let-binding (body-path0 binding-path0 ctx var expr continuation)
(let* (binding-path1 (traverse-path binding-path0)
annots (annots-from-context [] binding-path1 ctx))
(case expr
((:fn . (args . _))
(case (arg-arity args 0)
({new-annots arity}
(let* (fn-annots (lists/append annots new-annots)
cerl-var (cerl/ann_c_fname fn-annots var arity))
(push-scope-ctx ctx)
(add-reference-to-scope-ctx binding-path1 ctx
var arity cerl-var)
(let* (cerl-expr (make-expr (traverse-incr-path binding-path0) ctx expr)
cerl-body (continuation body-path0 (incr-path binding-path0) ctx))
(pop-scope-ctx ctx)
(cerl/ann_c_letrec annots
[{cerl-var cerl-expr}]
cerl-body))))))
(_
(let* (cerl-expr (make-expr (traverse-incr-path binding-path0)
ctx
expr))
(push-scope-ctx ctx)
(add-reference-to-scope-ctx binding-path1 ctx var
(get-expr-arity cerl-expr)
(cerl/ann_c_var annots var))
(let* (cerl-body (continuation body-path0 (incr-path binding-path0) ctx))
(pop-scope-ctx ctx)
(cerl/ann_c_let annots
[(cerl/ann_c_var annots var)]
cerl-expr
cerl-body)))))))
(defn make-let-bindings (body-path0 binding-path0 ctx bindings body)
(case bindings
([var expr]
(make-let-binding body-path0 binding-path0 ctx var expr
(fn (body-path1 binding-path1 ctx)
(make-seq body-path1 ctx body))))
((var . (expr . rest))
(make-let-binding body-path0 binding-path0 ctx var expr
(fn (body-path1 binding-path1 ctx)
(make-let-bindings body-path1
(incr-path binding-path1)
ctx rest body))))
(_
(add-error-r-nil-ctx ctx binding-path0 :invalid-let-binding ))))
(defn make-let (path0 ctx form)
(let* (path1 (traverse-incr-path path0))
(case form
((:let* . (bindings . body))
(make-let-bindings (incr-path 2 path0) path1 ctx bindings body))
(_
(add-error-r-nil-ctx ctx path0 :invalid-form)))))
(defn valid-guard (namespace function arity)
(case {namespace function arity}
({:erlang :abs 1} :true)
({:erlang :bitsize 1} :true)
({:erlang :byte_size 1} :true)
({:erlang :element 2} :true)
({:erlang :float 1} :true)
({:erlang :hd 1} :true)
({:erlang :length 1} :true)
({:erlang :node 0} :true)
({:erlang :node 1} :true)
({:erlang :round 1} :true)
({:erlang :self 0} :true)
({:erlang :size 1} :true)
({:erlang :tl 1} :true)
({:erlang :trunc 1} :true)
({:erlang :tuple_size 1} :true)
({:erlang :is_binary 1} :true)
({:erlang :is_alive 0} :true)
({:erlang :is_boolean 1} :true)
({:erlang :is_function 1} :true)
({:erlang :is_function 2} :true)
({:erlang :is_integer 1} :true)
({:erlang :is_float 1} :true)
({:erlang :is_list 1} :true)
({:erlang :is_atom 1} :true)
({:erlang :is_number 1} :true)
({:erlang :is_pid 1} :true)
({:erlang :is_port 1} :true)
({:erlang :is_record 2} :true)
({:erlang :is_record 3} :true)
({:erlang :is_reference 1} :true)
({:erlang :is_tuple 1} :true)
({:erlang :and 2} :true)
({:erlang :or 2} :true)
({:erlang :> 2} :true)
({:erlang :'<' 2} :true)
({:erlang :== 2} :true)
({:erlang :=< 2} :true)
({:erlang :>= 2} :true)
({:erlang :/= 2} :true)
({:erlang :=:= 2} :true)
({:erlang :'=/=' 2} :true)
(_ :false)))
(defn check-guards (ast)
(case (cerl/type ast)
(:call
(erlang/and (valid-guard (cerl/atom_val (cerl/call_module ast))
(cerl/atom_val (cerl/call_name ast))
(cerl/call_arity ast))
(lists/all check-guards/1 (cerl/call_args ast))))
(:cons
(erlang/and (check-guards (cerl/cons_hd ast))
(check-guards (cerl/cons_tl ast))))
(:binary :true)
(:bitstring :true)
(:tuple (lists/all check-guards/1 (cerl/tuple_es ast)))
(:var :true)
(:literal :true)
(_ :false)))
(defn check-guards (ctx path0 ast)
(case (check-guards ast)
(:true ast)
(:false
(add-error-r-nil-ctx ctx path0 :invalid-guard))))
(defn make-guards (annots guards)
(case guards
([]
(cerl/ann_c_atom annots :true))
([guard]
guard)
((pattern . rest)
(cerl/ann_c_call annots
(cerl/ann_c_atom annots :erlang)
(cerl/ann_c_atom annots :and)
[pattern (make-guards annots rest)]))))
(defn make-pattern-var (path0 ctx guards0 var0)
(let* (annots (:compiler_generated .
(annots-from-context [] path0 ctx)))
(case (resolve-reference-ctx path0 ctx var0 -1)
({:reference {var1 _}}
;; The reference already exists. So we create a new variable and
;; add a guard for to test for equality
(let* (gensym (gensym)
cerl-var (cerl/ann_c_var annots gensym)
guards1 ((cerl/ann_c_call annots
(cerl/ann_c_atom [:compiler_generated]
:erlang)
(cerl/ann_c_atom annots
:=:=)
[cerl-var (add-to-annots var1 annots)])
. guards0))
;; We don't add the generated variable to the scope as we
;; don't want it to be available to the user (The user really
;; should not even be aware of it)
{guards1 cerl-var}))
(_
(let* (annots-bare (annots-from-context [] path0 ctx)
;; The variable is not in the scope so we turn it to a
;; variable
cerl-var (cerl/ann_c_var annots-bare var0))
(add-reference-to-scope-ctx path0 ctx var0 -1 cerl-var)
{guards0 cerl-var})))))
(defn make-pattern-alias (alias-path pattern-path ctx guards0 alias pattern)
(let* (alias-annots (annots-from-context [] alias-path ctx)
pattern-annots (annots-from-context [] pattern-path ctx)
alias-var (cerl/ann_c_var alias-annots alias))
(case (make-pattern-element (traverse-incr-path pattern-path)
ctx guards0 pattern)
({guards1 cerl-pattern}
(case (resolve-reference-ctx alias-path ctx alias -1)
(:not-a-reference
(add-reference-to-scope-ctx alias-path ctx alias -1 alias-var)
{guards1
(cerl/ann_c_alias alias-annots alias-var cerl-pattern)})
(_
(add-error-r-nil-ctx ctx alias-path {:reference-already-defined alias})))))))
(defn make-binary-pattern-element (arg acc0)
(case acc0
({path0 ctx guards0 acc1}
(let* (annots (annots-from-context [] path0 ctx))
(case arg
((var . pairs0)
(let* (path1 (traverse-path path0)
bitstring (resolve-bitstring-defaults
(convert-bitstring path0 ctx pairs0 (new-bitstring))))
(case (make-pattern-element path1 ctx guards0 var)
({guards1 cerl-var}
(let* (size (make-expr path1 ctx (get-bitstring :size bitstring)))
{(incr-path path1) ctx guards1
((cerl/ann_c_bitstr annots
cerl-var
size
(get-bitstring :unit bitstring)
(cerl/ann_c_atom annots (get-bitstring :type bitstring))
(cerl/ann_make_list annots
[(cerl/ann_c_atom annots
(get-bitstring :signedness bitstring))
(cerl/ann_c_atom annots
(get-bitstring :endianness bitstring))]))
. acc1)})))))
(var (when (erlang/or (erlang/is_atom var)
(erlang/is_integer var)))
(let* (bitstring (resolve-bitstring-defaults (new-bitstring)))
(case (make-pattern-element path0 ctx guards0 var)
({guards1 cerl-var}
(let* (size (make-expr path0 ctx (get-bitstring :size bitstring)))
{(incr-path path0)
ctx guards1
((cerl/ann_c_bitstr annots
cerl-var
size
(get-bitstring :unit bitstring)
(cerl/ann_c_atom annots (get-bitstring :type bitstring))
(cerl/ann_make_list annots
[(cerl/ann_c_atom annots
(get-bitstring :signedness bitstring))
(cerl/ann_c_atom annots
(get-bitstring :endianness bitstring))])) . acc1)})))))
(_
(add-error-r-nil-ctx ctx path0 :invalid-bitstring)))))))
(defn make-binary-pattern (path0 ctx guards0 pairs)
(case (lists/foldl make-binary-pattern-element/2
{(incr-path path0) ctx guards0 []} pairs)
({_ ctx guards1 acc}
{guards1 (cerl/ann_c_binary (annots-from-context [] path0 ctx)
(lists/reverse acc))})))
(defn make-pattern-tuple (path0 ctx guards0 args)
(let* (annots (annots-from-context [] path0 ctx))
(case (lists/foldl (fn (arg acc0)
(case acc0
({:nil nil-result}
{:nil nil-result})
({path1 guards1 acc1}
(case (make-pattern-element
(traverse-path path1) ctx guards1 arg)
({guards2 element}
{(incr-path path1)
guards2 (element . acc1)})
(nil-result
{:nil nil-result})))))
{path0 guards0 []} args)
({:nil nil-result}
{[] nil-result})
({_ guards3 acc}
{guards3 (cerl/ann_c_tuple annots (lists/reverse acc))})
)))
(defn make-pattern-list (path0 ctx guards0 l)
(let* (annots (annots-from-context [] path0 ctx))
(case l
([]
{guards0 (cerl/c_nil)})
((h . t)
(case (make-pattern-element (traverse-path path0) ctx guards0 h)
({guards1 cerl-h}
(case (make-pattern-list (incr-path path0) ctx guards1 t)
({guards2 cerl-t}
{guards2 (cerl/ann_c_cons annots cerl-h cerl-t)})))
(nil-result
{[] nil-result}))))))
(defn make-literal-string (_path0 annots _ctx string)
(cerl/ann_c_string annots string))
(defn make-pattern-element (path0 ctx guards0 arg0)
(let* (annots (annots-from-context [] path0 ctx))
(case arg0
(arg0 (when (is-binary arg0))
{guards0 (cerl/ann_make_data annots {:atomic arg0} [])})
(:_
(let* (gensym (erlang/list_to_atom (lists/append "_"
(erlang/atom_to_list (gensym))))
cerl-var (cerl/ann_c_var annots gensym))
(add-reference-to-scope-ctx path0 ctx gensym -1 cerl-var)
{guards0 cerl-var}))
(arg0 (when (erlang/is_atom arg0))
(make-pattern-var path0 ctx guards0 arg0))
(arg0 (when (erlang/is_integer arg0))
{guards0 (cerl/ann_c_int annots arg0)})
(arg0 (when (erlang/is_float arg0))
{guards0 (cerl/ann_c_float annots arg0)})
(args0 (when (erlang/is_tuple args0))
(make-pattern-tuple path0 ctx guards0 (erlang/tuple_to_list args0)))
([:= alias pattern] (when (erlang/is_atom alias))
(make-pattern-alias (incr-path path0) (traverse-incr-path 2 path0)
ctx guards0 alias pattern))
([:= pattern alias] (when (erlang/is_atom alias))
(make-pattern-alias (traverse-incr-path 2 path0) (incr-path path0)
ctx guards0 alias pattern))
([:quote args]
(let* (literal (make-literal (traverse-incr-path path0) ctx args))
{guards0 literal}))
([:$file-name]
{guards0 (cerl/ann_c_string annots (filename-ctx ctx))})
([:$namespace]
{guards0 (cerl/ann_c_atom annots (namespace-name-ctx ctx))})
([:$line-number]
(case (get-line-annots (path? path0) (annots-ctx ctx))
([line-number _]
{guards0 (cerl/ann_c_int annots line-number)})))
([:$function-name]
{guards0 (cerl/ann_c_atom annots (function-name-ctx ctx))})
([:string str0]
(let* (literal (make-literal-string (traverse-incr-path path0) annots ctx str0))
{guards0 literal}))
((:binary . pairs)
(make-binary-pattern path0 ctx guards0 pairs))
((:list . args)
(make-pattern-list (incr-path path0) ctx guards0 args))
((:tuple . args)
(make-pattern-tuple (incr-path path0) ctx guards0 args))
([arg1 :. arg2]
(case (make-pattern-element (traverse-path path0) ctx guards0 arg1)
({guards1 cerl-arg1}
(case (make-pattern-element (traverse-incr-path 2 path0)
ctx guards1 arg2)
({guards2 cerl-arg2}
{guards2 (cerl/ann_c_cons annots cerl-arg1 cerl-arg2)})
(_
{guards1 (cerl/ann_c_cons annots (cerl/c_nil) (cerl/c_nil))})))
(_
{guards0 (cerl/c_nil)})))
([:cons arg1 arg2]
(case (make-pattern-element (traverse-incr-path path0) ctx guards0 arg1)
({guards1 cerl-arg1}
(case (make-pattern-element (traverse-incr-path 2 path0)
ctx guards1 arg2)
({guards2 cerl-arg2}
{guards2 (cerl/ann_c_cons annots cerl-arg1 cerl-arg2)})))))
((var . args)
(case (resolve-reference-ctx path0 ctx var (erlang/length args))
({:apply :not-rest :macro {function arity}}
(call-macro path0 ctx (namespace-name-ctx ctx)
function
args
(fn (pat)
(make-pattern-element (suspend path0) ctx guards0 pat))))
({:apply :rest :macro {function arity}}
(call-macro path0 ctx (namespace-name-ctx ctx) function
(runtime-called->rest args 1 arity [])
(fn (pat)
(make-pattern-element (suspend path0) ctx guards0 pat))))
({:remote :not-rest :macro {namespace function arity}}
(auto-require ctx namespace)
(call-macro path0 ctx namespace function
args
(fn (pat)
(make-pattern-element (suspend path0) ctx guards0 pat))))
({:remote :rest :macro {namespace function arity}}
(auto-require ctx namespace)
(call-macro path0 ctx namespace function
(runtime-called->rest args 1 arity [])
(fn (pat)
(make-pattern-element (suspend path0) ctx guards0 pat))))
(_
(add-error-r-nil-ctx ctx path0 :invalid-definition))))
(_
(add-error-r-nil-ctx ctx path0 :invalid-pattern)))))
(defn make-pattern-clause-body (path0 ctx form)
(push-scope-ctx ctx)
(let* (annots (annots-from-context [] path0 ctx))
(case form
((pattern . ([:when guards] . body))
(case (make-pattern-element (traverse-path path0) ctx [] pattern)
({pattern-guards cerl-pattern}
(let* (guard-annots (annots-from-context []
(traverse-incr-path path0) ctx)
cerl-guard (make-expr (traverse-incr-path (traverse-incr-path path0)) ctx guards)
cerl-body (make-seq (incr-path 2 path0) ctx body))
(pop-scope-ctx ctx)
(cerl/ann_c_clause annots
[cerl-pattern]
(check-guards ctx (traverse-incr-path path0)
(make-guards guard-annots
(cerl-guard . pattern-guards)))
cerl-body)))))
((pattern . body)
(case (make-pattern-element (traverse-path path0) ctx [] pattern)
({pattern-guards cerl-pattern}
(let* (cerl-body (make-seq (incr-path path0) ctx body))
(pop-scope-ctx ctx)
(cerl/ann_c_clause annots
[cerl-pattern]
(make-guards annots pattern-guards)
cerl-body)))
(_
(add-error-r-nil-ctx ctx path0 :invalid-case-clause))))
(_
(add-error-r-nil-ctx ctx path0 :invalid-case-clause)))))
(defn do-clause-terminator (path0 ctx clause)
(let* (actual-clause (make-pattern-clause-body (traverse-path path0) ctx clause)
annots (:compiler_generated . (annots-from-context [] path0 ctx))
var (gensym))
{actual-clause
[(cerl/ann_c_clause
annots
[(cerl/ann_c_var annots var)]
(cerl/ann_c_atom annots :true)
(cerl/ann_c_primop annots
(cerl/ann_c_atom annots :match_fail)
[(cerl/ann_c_tuple
annots [(cerl/ann_c_atom annots :case_clause)
(cerl/ann_c_var annots var)])]))]}))
(defn make-pattern (path0 ctx form acc)
(case form
([]
(add-error-r-nil-ctx ctx path0 :no-clauses-provided))
([clause]
(case (do-clause-terminator path0 ctx clause)
({clauses special-terminator}
(lists/append (lists/reverse (clauses . acc)) special-terminator))))
((clause . rest)
(let* (clauses (make-pattern-clause-body (traverse-path path0) ctx clause))
(make-pattern (incr-path path0) ctx rest (clauses . acc))))))
(defn gen-args (path0 ctx arg-list acc)
(let* (annots
(annots-from-context :traverse path0 ctx))
(case arg-list
([:&rest rest-arg]
{(lists/reverse ((cerl/ann_c_var annots rest-arg) . acc)) :true})
((:&rest . rest-arg)
(add-error-ctx ctx path0 :invalid-rest-arguments)
{(lists/reverse acc) :false})
((a . rest) (when (erlang/is_atom a))
(gen-args (incr-path path0) ctx rest ((cerl/ann_c_var annots a) . acc)))
([]
{(lists/reverse acc) :false})
(_
(add-error-r-nil-ctx ctx path0 :invalid-arg-list)
{(lists/reverse acc) :false}))))
(defn do-function-body (path0 ctx is-anon name args0 expressions0)
(push-scope-ctx ctx)
;; Add all of the args to the current scope
(lists/foreach (fn (arg)
(case arg
(_ (when (erlang/is_atom arg))
(add-reference-to-scope-ctx path0 ctx arg -1 (cerl/c_var arg)))
(else
(add-error-ctx ctx path0 {:arg-is-not-proper-name else}))))
args0)
(let* (arg-detail (gen-args (traverse-path path0) ctx args0 []))
;; Correctly setup forward declarations
(case {is-anon arg-detail}
({:true {arg-list :true}}
(let* (index (anon-fun-index-ctx ctx))
(add-rest-ctx path0 ctx {:anon index} (erlang/length arg-list))))
({:false {arg-list :true}}
(add-rest-ctx path0 ctx name (erlang/length arg-list)))
({:true {arg-list :false}}
(incr-fun-index-ctx ctx))
({:false {arg-list :false}}
;; predefine the function so it can be used recursively
(add-def-ctx path0 ctx [] name arg-list :undefined :ephemeral)))
(case arg-detail
({arg-list _}
;; Here we do something a bit different if there is a
;; docstring verses no docstring.
(case expressions0
(([:string docstring] . expressions1)
(when (erlang/is_list docstring))
(let* (result (make-seq (incr-path 2 path0) ctx expressions1))
(pop-scope-ctx ctx)
{arg-list result}))
(_
(let* (result (make-seq (incr-path path0) ctx expressions0))
(pop-scope-ctx ctx)
{arg-list result})))))))
(defn make-quasi-tuple (path0 ctx arg0)
(let* (annots (annots-from-context [] path0 ctx)
result (lists/foldl (fn (element acc)
(case acc
({path1 acc0}
(let* (cerl-el (make-quasi-element (traverse-path path1) ctx element))
{(incr-path path1)
( cerl-el . acc0)}))))
{path0 []} (erlang/tuple_to_list arg0)))
(case result
({_ elements1}
(cerl/ann_c_tuple annots (lists/reverse elements1))))))
(defn make-quasi-element (path0 ctx arg0)
(let* (annots (annots-from-context [] path0 ctx))
(case arg0
(arg1
(when (is-binary arg1))
(cerl/ann_make_data annots {:atomic arg1} []))
(arg1
(when (erlang/is_atom arg1))
(cerl/ann_c_atom annots arg1))
(arg1
(when (erlang/is_tuple arg1))
(make-quasi-tuple path0 ctx arg1))
(arg1
(when (erlang/is_integer arg1))
(cerl/ann_c_int annots arg1))
(arg1
(when (erlang/is_float arg1))
(cerl/ann_c_float annots arg1))
([:unquote arg1]
(make-expr (incr-path (traverse-path path0)) ctx arg1))
(arg1
(when (is-list arg1))
(make-quasi (traverse-path path0) ctx arg1)))))
(defn make-quasi (path0 ctx arg0)
(let* (annots (annots-from-context [] path0 ctx))
(case arg0
([]
(cerl/ann_c_nil annots))
(([:unquote-splicing arg1] . t)
(let* (cerl-h (make-expr (incr-path (traverse-path path0)) ctx arg1)
cerl-t (make-quasi (incr-path path0) ctx t))
(cerl/ann_c_call annots
(cerl/ann_c_atom annots :lists)
(cerl/ann_c_atom annots :append)
[cerl-h cerl-t])))
((h . t)
(let* (cerl-h (make-quasi-element path0 ctx h)
cerl-t (make-quasi (incr-path path0) ctx t))
(cerl/ann_c_cons annots
cerl-h
cerl-t)))
(else
(make-quasi-element path0 ctx else)))))
(defn make-expr (path0 ctx form)
(let* (annots (annots-from-context [] path0 ctx))
(case form
(arg (when (is-binary arg))
(cerl/ann_make_data annots {:atomic arg} []))
(arg (when (erlang/is_integer arg))
(cerl/ann_c_int annots arg))
(arg (when (erlang/is_float arg))
(cerl/ann_c_float annots arg))
(arg (when (erlang/is_atom arg))
(case (resolve-reference-ctx path0 ctx arg -1)
({:reference {var _}}
(add-to-annots var annots))
(e
(add-error-r-nil-ctx ctx path0 {:invalid-reference e arg}))))
(arg (when (erlang/and
(erlang/is_tuple arg)
(== (erlang/element 1 arg) :--fun)))
(make-fun path0 ctx form))
(arg (when (erlang/is_tuple arg))
(make-tuple-expr path0 ctx (erlang/tuple_to_list arg)))
((:let* . _)
(make-let path0 ctx form))
((:case . (expr . clauses))
(let* (cerl-expr (make-expr (traverse-incr-path path0) ctx expr)
cerl-clauses (make-pattern (incr-path 2 path0) ctx clauses []))
(cerl/ann_c_case annots cerl-expr cerl-clauses)))
((:receive . ((:after . (timeout . do-exprs)) . clauses))
(let* (timeout-val (make-expr (incr-path (traverse-incr-path path0))
ctx timeout)
timeout-expr (make-seq (incr-path 2 (traverse-incr-path path0))
ctx do-exprs)
cerl-clauses (make-pattern (incr-path 2 path0) ctx clauses []))
(case (cerl/is_c_int timeout-val)
(:true
(cerl/ann_c_receive annots
cerl-clauses
timeout-val
timeout-expr))
(:false
(add-error-r-nil-ctx ctx path0 :invalid-receive)))))
((:receive . ((:after . _) . _))
(add-error-r-nil-ctx ctx path0 :invalid-receive))
((:receive . clauses)
(let* (cerl-clauses (make-pattern (incr-path path0) ctx clauses []))
(cerl/ann_c_receive annots cerl-clauses)))
((:do . args)
(make-seq (incr-path path0) ctx args))
((:binary . _)
(make-binary path0 ctx form))
([:$file-name]
(cerl/ann_c_string annots (filename-ctx ctx)))
([:$namespace]
(cerl/ann_c_atom annots (namespace-name-ctx ctx)))
([:$line-number]
(case (get-line-annots (path? path0) (annots-ctx ctx))
([line-number _]
(cerl/ann_c_int annots line-number))))
([:$function-name]
(cerl/ann_c_atom annots (function-name-ctx ctx)))
([arg1 :. arg2]
(make-cons annots (traverse-path path0) (traverse-incr-path 2 path0)
ctx arg1 arg2))
([:cons arg1 arg2]
(make-cons annots (incr-path path0) (incr-path 2 path0) ctx arg1 arg2))
((:apply . _)
(make-apply path0 ctx form))
([:quote args]
(make-literal (traverse-incr-path path0) ctx args))
([:quasiquote args]
(make-quasi (traverse-incr-path path0) ctx args))
([:string args]
(make-literal-string (traverse-incr-path path0) annots ctx args))
((:list . args)
(make-list (incr-path path0) ctx args))
((:tuple . args)
(make-tuple-expr (incr-path path0) ctx args))
([:macroexpand-1 (val . args)]
(make-macroexpand-1 (incr-path path0) ctx val args))
((:try* . _)
(make-try path0 ctx form))
((:fn . fn-body)
(case fn-body
((args . expression)
(case (do-function-body (incr-path path0) ctx :true :anon args expression)
({arg-list body}
(cerl/ann_c_fun annots arg-list body))
(_
(add-error-r-nil-ctx ctx path0 :invalid-fn-form))))))
((val . args)
(make-call path0 ctx val args :false))
(_
(add-error-r-nil-ctx ctx path0 :invalid-fn-form)))))
(defn default-type ()
[{:--fun :erlang :any}])
(defn make-spec-tuple (line path0 ctx form)
(case (lists/foldl (fn (el acc0)
(case acc0
({path1 acc1}
(let* (comp-el (make-spec-expr path1 ctx el))
{(incr-path path1) (comp-el . acc1)}))))
{path0 []} (erlang/tuple_to_list form))
({_ tuple-values}
{:tuple line (erlang/list_to_tuple (lists/reverse tuple-values))})))
(defn make-spec-args (line ctx args)
(let* (comp-args (lists/foldl (fn (el acc)
(add-type-reference-to-scope-ctx ctx el -1)
({:var line el} . acc))
[] args))
(lists/reverse comp-args)))
(defn def-anon-function-spec (path0 ctx args0 expr0)
(let* (line1 (case (idx-from-context [] path0 ctx)
({line0 _}
line0)))
(push-type-scope-ctx ctx)
(let* (args1 (make-spec-args path0 (push-type-scope-ctx ctx) args0)
expr1 (make-spec-expr (incr-path 2 path0) ctx expr0))
(pop-type-scope-ctx ctx)
[{:type line1 :fun
[{:type line1 :product (lists/reverse args1)}
expr1]}])))
(defn make-binary-spec (line1 path0 ctx form)
(case form
([:binary]
{:type line1 :binary [{:integer line1 0} {:integer line1 0}]})
([:binary arg]
(when (erlang/is_integer arg))
{:type line1 :binary [{:integer line1 arg} {:integer line1 0}]})
([:binary :* arg]
(when (erlang/is_integer arg))
{:type line1 :binary [{:integer line1 0} {:integer line1 arg}]})
([:binary arg1 :* arg2]
(when (erlang/and (erlang/is_integer arg1)
(erlang/is_integer arg2)))
{:type line1 :binary [{:integer line1 arg1} {:integer line1 arg2}]})
(_
(add-error-ctx ctx path0 :invalid-binary-type-spec)
{:type line1 :binary [{:integer line1 0} {:integer line1 0}]})))
(defn make-function-spec (line1 path0 ctx form)
(case form
([:fn]
{:type line1 :fun []})
([:fn [:...] expr]
(let* (cerl-expr (make-expr (traverse-incr-path 2 path0) ctx expr))
{:type line1 :fun [{:type line1 :any} cerl-expr]}))
([:fn args expr]
(def-anon-function-spec (incr-path path0) ctx args expr))))
(defn make-type-call-spec (line path0 ctx form)
(case form
([{:--fun :erlang :range} a1 a2]
(when (erlang/and (erlang/is_integer a1)
(erlang/is_integer a2)))
(let* (comp-args (make-spec-args (incr-path path0) ctx [a1 a2]))
{:type line :range
comp-args}))
(({:--fun :erlang func} . args)
;; Things in erlang get treated a bit differently then things in
;; other namespaces. It sucks that they have to be special
{:type line func (make-spec-args (incr-path path0) ctx args)})
(({:--fun namespace func} . args)
(when (erlang/and (erlang/is_atom namespace)
(erlang/is_atom func)))
{:remote_type line [{:atom line namespace}
{:atom line func}
(make-spec-args (incr-path path0) ctx args)]})))
(defn make-spec-literal (path0 ctx arg0)
(let* (line1 (case (idx-from-context [] path0 ctx)
({line0 _}
line0)))
(case arg0
(arg1
(when (erlang/is_atom arg1))
{:atom line1 arg1})
(arg1
(when (erlang/is_integer arg1))
{:integer line1 arg1})
([args]
{:list line1 (make-spec-literal (traverse-path path0) ctx args)})
(arg1
(when (is-list arg1))
(let* (specs (lists/foldl (fn (el acc0)
(case acc0
({path1 acc1}
{(incr-path path1)
((make-spec-literal path1 ctx el) . acc1)})))
{path0 []} arg1))
{:list line1 (lists/reverse specs)}))
(arg1
(when (erlang/is_tuple arg1))
(let* (specs (lists/foldl (fn (el acc0)
(case acc0
({path1 acc1}
{(incr-path path1)
((make-spec-literal path1 ctx el) . acc1)})))
{path0 []} (erlang/tuple_to_list arg1)))
{:tuple line1 (lists/reverse specs)}))
(_
(add-error-ctx ctx path0 :invalid-type-literal)))))
(defn make-spec-expr (path0 ctx form)
(let* (line1 (case (idx-from-context [] path0 ctx)
({line0 _}
line0)))
(case form
([:quote value]
(make-spec-literal (traverse-incr-path path0) ctx value))
(arg
(when (erlang/is_tuple arg))
(make-spec-tuple line1 path0 ctx form))
(arg
(when (erlang/is_integer arg))
(make-spec-literal path0 ctx arg))
((:binary . _)
(make-binary-spec line1 path0 ctx form))
((:fn . _)
(make-function-spec line1 path0 ctx form))
(({:--fun _ _} . _)
(make-type-call-spec line1 path0 ctx form))
([:list arg]
{:list line1
(make-spec-expr (traverse-incr-path path0) ctx arg)})
(name
(when (erlang/is_atom name))
(case (resolve-type-reference-ctx ctx name -1)
(:true
{:var line1 name})
(:false
(add-error-r-nil-ctx ctx path0 {:invalid-type-reference name}))))
((var . args)
(let* (arg-count (erlang/length args))
(case (resolve-type-reference-ctx ctx var arg-count)
(:false
(let* (idx (idx-from-context [] path0 ctx))
(add-error-r-nil-ctx ctx path0 {:invalid-type-reference var})))
(:true
{:type line1 var
(make-spec-args (incr-path path0) ctx args)}))))
(_
(add-error-r-nil-ctx ctx path0 :invalid-type-reference)))))
(defn rewrite-spec-args (args acc)
(case args
((:&rest . arg)
(lists/reverse ([arg] . acc)))
([]
(lists/reverse acc))
((arg . rest)
(rewrite-spec-args rest (arg . acc)))))
(defn make-implicit-spec (path0 ctx name args expr)
(let* (annots (annots-from-context [] path0 ctx)
arity (erlang/length args)
is-rest (lists/member :&rest args)
new-args (case is-rest
(:true
(rewrite-spec-args args []))
(:false
args)))
(case name
({:--fun namespace function}
(add-pre-require-ctx ctx namespace function arity is-rest))
(name (when (erlang/is_atom name))
(case is-rest
(:true
(add-rest-ctx path0 ctx name (erlang/length new-args)))
(:false ctx))
(let* (body (def-anon-function-spec (incr-path 2 path0) ctx args expr))
(add-type-ctx ctx name arity {{:c_literal annots :spec}
{:c_literal annots [{{name arity}
[body]}]}}))))))
(defn def-top-level-function-spec (path0 ctx name args expression)
(let* (line1 (case (idx-from-context [] path0 ctx)
({line0 _}
line0))
arity (erlang/length args))
(push-type-scope-ctx ctx)
(add-type-reference-to-scope-ctx ctx name arity)
(lists/foreach (fn (arg0)
(case arg0
(arg1 (when (erlang/is_atom arg1))
(add-type-reference-to-scope-ctx
ctx arg1 -1))
(_
(add-error-r-nil-ctx ctx path0 :invalid-type-definition))))
args)
(let* (expr (make-spec-expr (incr-path 3 path0) ctx expression))
(pop-type-scope-ctx ctx)
(add-type-ctx ctx name arity {{:c_literal [line1] :type}
{:c_literal [line1]
[{name expr
(lists/map
(fn (el)
{:var line1 el})
args)}]}}))))
(defn make-spec (path0 ctx form)
(case form
([:deftype+ name args expression]
(when (erlang/and (erlang/is_atom name)
(is-list args)))
(let* (arity (erlang/length args))
(add-type-export-ctx ctx name arity)
(def-top-level-function-spec (incr-path path0) ctx name args expression)))
([:deftype name args expression]
(when (erlang/and (erlang/is_atom name)
(is-list args)))
(make-implicit-spec (incr-path path0) ctx name args expression))
([:defspec name args expression]
(make-implicit-spec (incr-path path0) ctx name args expression))
(_
(add-error-r-nil-ctx ctx path0 :invalid-type-definition))))
(defn make-function1 (path0 ctx name args expressions)
(function-name-ctx ctx name)
(case (do-function-body (incr-path path0) ctx :false name args expressions)
({arg-list body}
(function-name-ctx ctx :undefined)
{name arg-list body})))
(defn make-function (path0 ctx form)
(case form
((name . (args . expressions))
(when (and (is-list args)
(erlang/is_atom name)))
(make-function1 path0 ctx name args expressions))
(_
(add-error-ctx ctx path0 :invalid-definition)
{:no-name [] (cerl/c_nil)})))
(defn+ make-definition (path0 ctx form)
(let* (annots (annots-from-context :traverse path0 ctx))
(case form
; An empty form is perfectly acceptable as it helps us have
; macros that do validation but do not return anything compilable
([] :ok)
((:defn+ . details)
(case (make-function (incr-path path0) ctx details)
({name arg-list body}
(add-exported-def-ctx path0 ctx annots name arg-list body))))
((:defn . details)
(case (make-function (incr-path path0) ctx details)
({name arg-list body}
(add-def-ctx path0 ctx annots name arg-list body))))
((:definline . details)
(let* (inline-annots (:inline . annots))
(case (make-function (incr-path path0) ctx details)
({name arg-list body}
(add-def-ctx path0 ctx inline-annots name arg-list body)))))
((:defmacro+ . details)
(case (make-function (incr-path path0) ctx details)
({name arg-list body}
(add-exported-def-ctx path0 ctx annots name arg-list body)
(add-macro-ctx ctx name (erlang/length arg-list) path0))))
((:defmacro . details)
(case (make-function (incr-path path0) ctx details)
({name arg-list body}
;; Initially all macros have to be exported, since the
;; caller is the compiler and not the namespace
;; itself. However, we keep a list of macros that need to be
;; hidden so that after the fact we can roll through the
;; list unexporting things that do not need to be exported.
(add-exported-def-ctx path0 ctx annots name arg-list body)
(add-unexported-macro-ctx path0 ctx name (erlang/length arg-list)))))
((:deftype+ . _)
(make-spec path0 ctx form))
((:deftype . _)
(make-spec path0 ctx form))
((:defspec . _)
(make-spec path0 ctx form))
((var . args)
(case (resolve-reference-ctx path0 ctx var (erlang/length args))
({:apply :not-rest :macro {function arity}}
(call-macro path0 ctx (namespace-name-ctx ctx) function args
(fn (form)
(make-forms (suspend path0) ctx form))))
({:apply :rest :macro {function arity}}
(call-macro path0 ctx (namespace-name-ctx ctx) function
(runtime-called->rest args 1 arity [])
(fn (form)
(make-forms (suspend path0) ctx form))))
({:remote :not-rest :macro {namespace function arity}}
(auto-require ctx namespace)
(call-macro path0 ctx namespace function
args
(fn (form)
(make-forms (suspend path0) ctx form))))
({:remote :rest :macro {namespace function arity}}
(auto-require ctx namespace)
(call-macro path0 ctx namespace function
(runtime-called->rest args 1 arity [])
(fn (form)
(make-forms (suspend path0) ctx form))))
(_
(add-error-ctx ctx path0 {:invalid-definition-or-macro form}))))
(_
(add-error-ctx ctx path0 :invalid-definition)))))
(defn make-literal-list (path0 annots ctx list)
(case list
([] (cerl/c_nil))
((h . t)
(cerl/ann_c_cons annots
(make-literal (traverse-path path0) ctx h)
(make-literal-list (incr-path path0) annots ctx t)))))
(defn make-literal-tuple (path0 annots ctx elements0)
(let* (result (lists/foldl (fn (element acc)
(case acc
({path1 acc0}
(let* (acc1 ((make-literal (traverse-path path1) ctx element) . acc0)
path2 (incr-path path1))
{path2 acc1}))))
{path0 []} (erlang/tuple_to_list elements0)))
(case result
({_ elements1}
(cerl/ann_c_tuple annots (lists/reverse elements1))))))
(defn make-literal (path0 ctx arg0)
(let* (annots (annots-from-context [] path0 ctx))
(case arg0
(arg1
(when (is-binary arg1))
(cerl/ann_make_data annots {:atomic arg1} []))
(arg1
(when (erlang/is_atom arg1))
(cerl/ann_c_atom annots arg1))
(arg1
(when (erlang/is_tuple arg1))
(make-literal-tuple path0 annots ctx arg1))
(arg1
(when (erlang/is_integer arg1))
(cerl/ann_c_int annots arg1))
(arg1
(when (erlang/is_float arg1))
(cerl/ann_c_float annots arg1))
([:string str1]
(make-literal-string (traverse-incr-path path0) annots ctx str1))
(arg1
(when (is-list arg1))
(make-literal-list path0 annots ctx arg1)))))
(defn+ make-forms (path0 ctx form0)
(case form0
((:do . rest)
(lists/foldl (fn (form1 path1)
(make-forms path1 ctx form1)
(incr-path path1))
(traverse-incr-path path0) rest))
((:ns . _)
(make-namespace path0 ctx form0))
(_
(make-definition path0 ctx form0))))
;; Compilation Infrastructure
;; -------------------------
;;
;; The following functions comprise most of the UI for the Joxa
;; compiler. Organizing the compilation and adding various metadata
;; functions.
(definline handle-errors-and-warnings (ctx errors warnings)
(case (erlang/> (erlang/length errors) 0)
(:true
(add-error-ctx ctx (new-path) {:system-errors errors}))
(:false
:ok))
(case (erlang/> (erlang/length warnings) 0)
(:true
(add-warning-ctx ctx (new-path) {:system-warnings warnings}))
(:false
:ok)))
(defn get-definitions (ctx)
(lists/map (fn (el)
(case el
({_ value}
value)))
(definitions-ctx ctx)))
(defn gather-inline-funs (ctx)
(let* (defs (definitions-ctx ctx)
inlinables
(lists/foldl (fn (cvar acc)
(case cvar
({name-arity {_ body _ _}}
(case (lists/member :inline (cerl/get_ann body))
(:true
(name-arity . acc))
(:false acc)))))
[]
defs))
(case inlinables
([] [])
(_
{:inline inlinables}))))
(definline hipe-option (ctx)
(let* (attrs (attrs-ctx ctx))
(case (lists/any (fn (val)
(case val
({k v}
(erlang/and (erlang/== (cerl/concrete k) :pragma)
(erlang/== (cerl/concrete v) :native)))))
attrs)
(:true
(case (erlang/system_info :hipe_architecture)
(:undefined [])
(_ :native)))
(_ []))))
(definline compile-options (ctx type)
(let* (additional-opts (case type
(:final [(hipe-option ctx) :inline (gather-inline-funs ctx)])
(_ [])))
(lists/flatten [(options-ctx ctx)
additional-opts
:from_core
:binary
:return_errors
:return_warnings])))
(defn erl-comp (ctx cerl-ast type)
(case type
(:final
(case (lists/member :to_core (options-ctx ctx))
(:true
[(core-pp/format cerl-ast) \\n])
(:false
(case (lists/member :to_ast (options-ctx ctx))
(:true
(io-lib/format "~p" [cerl-ast]))
(_
(case (compile/forms cerl-ast
(compile-options ctx type))
({ok [] result []}
result)
({ok errors result warnings}
(handle-errors-and-warnings ctx errors warnings)
result)
({error errors warnings}
(handle-errors-and-warnings ctx errors warnings)
:error)))))))
(_
(case (compile/forms cerl-ast [:debug_info
:from_core
:return_errors
:return_warnings
:binary])
({ok [] result []}
result)
({ok errors result warnings}
(handle-errors-and-warnings ctx errors warnings)
result)
({error errors warnings}
(handle-errors-and-warnings ctx errors warnings)
:error)))))
(defn get-context-exports (ctx)
(lists/map (fn (el)
(case el
({fun arity annots}
(cerl/ann_c_fname annots fun arity))))
(sets/to_list (exports-ctx ctx))))
;; ### make-joxa-info-1 Function Set
;;
;; The make-joxa-info-1 set of functions creates a namespace level
;; function that returns information sigficant to the joxa compilation
;; system for each function. This set of functions builds a function,
;; that if written in normal joxa would look like.
;;
;; (defn __joxa_info (type)
;; (case type
;; (:rest
;; <rest-info>...)
;; (:macro
;; <macro-info>...)))
;;
;; more may be added to this over time.
;; at the moment the <rest-info> looks as follows
;;
;; [{<fun-id> <restish-arity>}]
;;
;; Where <fun-id> is either the name of the function if it is a named
;; namespace level function. Or the tuple {:anon index} in the case of an
;; anonymous function where the index is the index of the fun in the
;; namespaces function table.
;;
;; macros follow a similar senario with the exception that there are
;; currently no anonymous macros. so macros are defined by function
;; name and return :true or :false depending on if the function is a
;; macro.
;;
(defn make-joxa-info-rest-1 (ctx)
(let* (annots [:compiler_generated]
rests (rests-ctx ctx))
(cerl/ann_c_clause [:compiler_generated]
[(cerl/ann_c_atom annots :rest)]
(cerl/ann_c_atom annots :true)
(cerl/ann_make_data annots
{:atomic rests} []))))
(defn make-joxa-info-macro-1 (ctx)
(let* (annots [:compiler_generated]
macros (macros-ctx ctx))
(cerl/ann_c_clause [:compiler_generated]
[(cerl/ann_c_atom annots :macro)]
(cerl/ann_c_atom annots :true)
(cerl/ann_make_data annots
{:atomic macros} []))))
(defn make-joxa-info-require-1 (ctx)
(let* (annots [:compiler_generated]
requires (sets/to_list
(sets/from_list
(lists/foldl (fn (req-info acc)
(case req-info
({{mod _ _} _}
(mod . acc))))
[] (ec-dictionary/to-list (requires-ctx ctx))))))
(cerl/ann_c_clause [:compiler_generated]
[(cerl/ann_c_atom annots :requires)]
(cerl/ann_c_atom annots :true)
(cerl/ann_make_data annots
{:atomic requires} []))))
(defn make-joxa-info-use-1 (ctx)
(let* (annots [:compiler_generated]
uses (ec-dictionary/to-list (uses-ctx ctx)))
(cerl/ann_c_clause [:compiler_generated]
[(cerl/ann_c_atom annots :uses)]
(cerl/ann_c_atom annots :true)
(cerl/ann_make_data annots
{:atomic uses} []))))
(defn make-joxa-info-terminator (ctx)
(let* (annots [:compiler_generated]
var (gensym))
(cerl/ann_c_clause
annots
[(cerl/ann_c_var annots var)]
(cerl/ann_c_atom annots :true)
(cerl/ann_c_primop annots
(cerl/ann_c_atom annots :match_fail)
[(cerl/ann_c_tuple
annots
[(cerl/ann_c_atom annots :case_clause)
(cerl/ann_c_var annots var)])]))))
(defn make-joxa-info-1 (ctx)
(let* (annots [:compiler_generated]
clauses [(make-joxa-info-rest-1 ctx)
(make-joxa-info-macro-1 ctx)
(make-joxa-info-require-1 ctx)
(make-joxa-info-use-1 ctx)
(make-joxa-info-terminator ctx)]
detail-var (gensym)
var-name (cerl/c_var detail-var))
(add-exported-def-ctx (new-path) ctx
annots :--joxa-info
[var-name]
(cerl/ann_c_case annots
var-name
clauses)
:replace)))
;; ### make-joxa-info-2 function set
;;
;; The make-joxa-info-2 functions are similar to the
;; make-joxa-info-1. However, they also take a function id as well as
;; the type. this allows you to get information about a specific
;; function. if written in normal joxa would look like.
;;
;; (defn __joxa_info (type fun-id)
;; (case type
;; (:rest
;; (case fun-id
;; <fun-clauses>...))
;; (:macro
;; (case fun-id
;; <macro-clauses>...))
;;
;; more may be added to this over time.
;;
;; In this case the fun and macro clauses provide the same information
;; as the single arg __joxa_info function, however just for the
;; function specifid.
;;
(defn make-joxa-info-rest-2 (fun-var ctx)
(let* (annots [:compiler_generated]
rests (rests-ctx ctx)
catch-all-var (cerl/ann_c_var [:compiler_generated] (gensym)))
(cerl/ann_c_case annots
fun-var
(lists/append
(lists/map (fn (rest-el)
(case rest-el
({fun-id, value}
(cerl/ann_c_clause annots
[(cerl/ann_make_data annots
{:atomic fun-id} [])]
(cerl/ann_c_atom annots :true)
(cerl/ann_make_data annots
{:atomic value} [])))))
rests)
[(cerl/ann_c_clause annots
[catch-all-var]
(cerl/ann_c_atom annots :true)
(cerl/ann_c_atom annots :false))
(make-joxa-info-terminator ctx)]))))
(defn make-joxa-info-macro-2 (fun-var ctx)
(let* (annots [:compiler_generated]
macros (macros-ctx ctx)
catch-all-var (cerl/ann_c_var [:compiler_generated] (gensym)))
(cerl/ann_c_case annots
fun-var
(lists/append
(lists/map (fn (macro-el)
(cerl/ann_c_clause annots
[(cerl/ann_make_data annots
{:atomic macro-el} [])]
(cerl/ann_c_atom annots :true)
(cerl/ann_c_atom annots :true)))
macros)
[(cerl/ann_c_clause annots
[catch-all-var]
(cerl/ann_c_atom annots :true)
(cerl/ann_c_atom annots :false))
(make-joxa-info-terminator ctx)]))))
(defn make-joxa-info-2 (ctx)
(let* (annots [:compiler_generated]
type-var (cerl/c_var (gensym))
fun-id-var (cerl/c_var (gensym))
rest-clause (cerl/ann_c_clause annots
[(cerl/ann_c_atom annots :rest)]
(cerl/ann_c_atom annots :true)
(make-joxa-info-rest-2 fun-id-var ctx))
macro-clause (cerl/ann_c_clause annots
[(cerl/ann_c_atom annots :macro)]
(cerl/ann_c_atom annots :true)
(make-joxa-info-macro-2 fun-id-var ctx))
clauses [rest-clause macro-clause (make-joxa-info-terminator ctx)])
(add-exported-def-ctx (new-path) ctx
[:compiler_generated] :--joxa-info
[type-var fun-id-var]
(cerl/ann_c_case [:compiler_generated]
type-var
clauses)
:replace)))
(defn make-joxa-info (ctx)
(make-joxa-info-1 ctx)
(make-joxa-info-2 ctx))
(defn make-namespace-info (ctx)
(let* (namespace-name (cerl/c_atom (namespace-name-ctx ctx))
argless-body (cerl/c_call (cerl/c_atom :erlang)
(cerl/c_atom :get_module_info)
[namespace-name])
detail-var (gensym)
var-name (cerl/c_var detail-var)
arg-body (cerl/c_call (cerl/c_atom :erlang)
(cerl/c_atom :get_module_info)
[namespace-name var-name]))
(add-exported-def-ctx (new-path) ctx
[:compiler_generated] :module_info []
argless-body
:replace)
(add-exported-def-ctx (new-path) ctx
[:compiler_generated] :module_info
[var-name] arg-body :replace)))
(defn compile-types (ctx)
(let* (exported-types (sets/to_list (type-exports-ctx ctx))
all-types (ec-dictionary/to-list (types-ctx ctx)))
({(cerl/c_atom :export_type) (cerl/make_data {:atomic exported-types} [])} .
(lists/map (fn (el)
(case el
({_ attr}
attr))) all-types))))
(defn sort-fun-deps (dep state)
(case state
({unresolved0 resolved0}
(case (sets/is_element dep resolved0)
(:true
state)
(:false
{(sets/add_element dep unresolved0) resolved0})))))
(defn has-errors-or-warnings? (ctx)
(erlang/or (erlang/> (warning-count-ctx ctx) 0)
(erlang/> (error-count-ctx ctx) 0)))
(defn has-unresolved-dependencies? (ctx)
(let* (reqs (get-definitions ctx)
result (lists/foldl
(fn (el acc)
(case el
({var _ deps _}
(case acc
({unresolved0 resolved0}
(let* (element {(cerl/fname_id var) (cerl/fname_arity var)}
resolved1 (sets/add_element element resolved0)
unresolved1 (sets/del_element element unresolved0))
(lists/foldl sort-fun-deps/2 {unresolved1 resolved1} (sets/to_list deps))))))))
{(sets/new) (sets/new)} reqs))
(case result
({unresolved _}
(case (erlang/> (sets/size unresolved) 0)
(:true
(add-error-ctx ctx (new-path) {:undefined-functions (sets/to_list unresolved)})
:true)
(:false
:false))))))
(defn+ compilable? (ctx)
(erlang/not (erlang/or (has-unresolved-dependencies? ctx)
(has-errors-or-warnings? ctx))))
(defn post-process-macros (ctx)
(let* (unexported-macros (unexported-macros-ctx ctx)
exports0 (exports-ctx ctx)
exports1 (sets/filter (fn (export)
(case export
({fun arity _}
(erlang/not (lists/member {fun arity}
unexported-macros)))))
exports0))
(exports-ctx ctx exports1)))
(defn post-processing (compile-type ctx)
(case compile-type
(:final
(post-process-macros ctx))
(_
:ok)))
;; There are certain errors that get regenernated each compilation
;; attempt. Those errors are produced by the post checking and the
;; core erlang compiler. We need to remove them before each
;; compilation, otherwise there is just a nasty buildup that serves no
;; purpose.
(defn clear-post-comp-errors (ctx)
(let* (errors (errors-ctx ctx)
warnings (warnings-ctx ctx))
(errors-ctx ctx (lists/filter (fn (el)
(case el
({{:system-errors _} _}
:false)
({{:undefined-functions _} _}
:false)
(_
:true)))
errors))
(warnings-ctx ctx (lists/filter (fn (el)
(case el
({{:system-warnings _} _}
:false)
({{:undefined-functions _} _}
:false)
(_
:true)))
warnings))))
(defn+ compile-context (ctx compile-type)
(clear-post-comp-errors ctx)
(case (compilable? ctx)
(:true
(post-processing compile-type ctx)
(make-namespace-info ctx)
(make-joxa-info ctx)
(let* (annots (line-ctx ctx)
namespace-name (cerl/ann_c_atom annots
(namespace-name-ctx ctx))
exports (get-context-exports ctx)
attrs (lists/append (attrs-ctx ctx)
(compile-types ctx))
defs (lists/map (fn (def)
(case def
({var body _ _}
{var body})
(else
(erlang/throw {:error-processing-defs else}))))
(get-definitions ctx))
result (erl-comp ctx (cerl/ann_c_module annots namespace-name exports attrs defs)
compile-type))
(result-ctx ctx result)))
(:false
(when (erlang/== compile-type :final))
:error)
(:false
:uncompilable)))
(defn format-fun-ref (ref)
(case ref
({:--fun name function}
(io-lib/format "~s/~s" [name function]))
({:--fun namespace function arity}
(io-lib/format "~s/~s/~p" [namespace function arity]))
({:reference {var -1}}
(io-lib/format "~s" [var]))
({:reference {var arity}}
(io-lib/format "~s/~p" [var arity]))
(_
(io-lib/format "~p" [ref]))))
(defn format-detail (message)
(case message
({:invalid-reference :not-a-reference ref}
(io-lib/format "reference does not exist: ~s" [ref]))
({:invalid-reference ref arity}
(io-lib/format "invalid reference ~s/~p" [(format-fun-ref ref) arity]))
({:invalid-use :invalid-fun-spec inv-f}
(io-lib/format "invalid use declaration: invalid function reference (~p)"
[inv-f]))
({:invalid-use :invalid-fun-spec}
"invalid use declaration: invalid function reference")
({:invalid-use :non-existant-fun-name {fun arity}}
(io-lib/format "invalid use declaration: function does not exist ~s/~p"
[fun arity]))
({:invalid-use-clause {:bad-namespace use-namespace-name}}
(io-lib/format "invalid use declaration: bad namespace name ~p"
[use-namespace-name]))
(:invalid-attr-clause
"invalid attribute clause")
({:invalid-require-clause {:bad-namespace namespace-name}}
(io-lib/format "invalid require declaration: bad namespace name ~p"
[namespace-name]))
({:invalid-require-clause _}
"invalid require declaration")
(:invalid-form
"invalid form")
(:invalid-namespace-declaration
"invalid namespace declaration")
(:invalid-sequence
"invalid sequence")
({:invalid-use-clause {:bad-use-part forms}}
(io-lib/format "invalid use clause ~p" [forms]))
({:invalid-reference {f -1}}
(io-lib/format "invalid reference ~s" [(format-fun-ref f) ]))
({:invalid-reference {f a}}
(io-lib/format "invalid reference ~s/~p" [(format-fun-ref f) a]))
({:undefined-reference ref}
(io-lib/format "invalid reference ~s" [(format-fun-ref ref)]))
({:invalid-reference form}
(io-lib/format "invalid reference (~p)" [form]))
({:arg-is-not-proper-name form}
(io-lib/format "argument is not a proper reference name (~p)" [form]))
({:function-exists fun-name arity}
(io-lib/format "~p/~p already exists" [fun-name arity]))
({:not-a-macro {ref arity}}
(io-lib/format "not a macro ~s called with ~p args" [(format-fun-ref ref) arity]))
(:invalid-receive
"invalid receive clause")
({:invalid-try-expression}
"invalid try expression")
(:invalid-bitstring-spec
"invalid bitstring specification")
(:invalid-bitstring
"invalid bitstring ")
(:invalid-let-binding
"invalid let binding")
(:no-clauses-provided
"no clauses provided for case statement")
(:invalid-guard
"invalid guard expression")
({:reference-already-defined ref}
(io-lib/format "reference already defined ~s" [(format-fun-ref ref)]))
({:invalid-definition-or-macro name}
(io-lib/format "invalid definition or macro (~s)" [(format-fun-ref name)]))
({:renamed-fun-does-not-exist {fun arity}}
(io-lib/format "function ~p/~p defined in rename does not exist" [fun arity]))
({:macro-failure {namespace function arity} error-info}
(io-lib/format "error during evaluation of macro ~p/~p/~p: (~p)" [namespace function arity
error-info]))
(:invalid-definition
"invalid definition")
(:invalid-pattern
"invalid guard pattern")
(_
(io-lib/format "~p" [message]))))
(defn print-erl-errors-or-warnings (errs)
(lists/foreach (fn (err)
(case err
({file sub-errors}
(lists/foreach
(fn (sub-err)
(case sub-err
({line namespace error-descriptor}
(let* (p-fun (erlang/make_fun namespace :format_error 1))
(io/format "~s:~p ~s~n" [file line (p-fun error-descriptor)])))))
sub-errors))))
errs))
;; The goal with compiler messages to print them out in a well
;; understood format. Taking the approach specified by the GNU Coding
;; standards and understood by emacs makes good sense.
;;
;; sourcefile:lineno:column: message
;;
;; http://www.gnu.org/prep/standards/html_node/Errors.html
(defn print-compiler-message (type message)
(case message
({{:system-errors errors} _}
(print-erl-errors-or-warnings errors))
({{:system-warnings warnings} _}
(print-erl-errors-or-warnings warnings))
({{:parse-fail expected {line column}} {file-name _}}
(io/format "~s:~p:~p *~p* parsing failed, expected ~p~n" [file-name line column type expected]))
({detail {file-name {line column}}}
(io/format "~s:~p:~p *~p* ~s~n" [file-name line column type (format-detail detail)]))
(msg
(io/format "UNKNOWN_TYPE ~p~n" [msg]))))
(defn report-errors-warnings (ctx)
(let* (warnings (lists/reverse (warnings-ctx ctx))
errors (lists/reverse (errors-ctx ctx)))
(lists/foreach (fn (message)
(print-compiler-message :warning message))
warnings)
(lists/foreach (fn (message)
(print-compiler-message :error message))
errors)))
(defn should-load? (options)
(erlang/not
(lists/any (fn (no-compile-option)
(lists/member no-compile-option options))
'(to_ast to_core bootstrap))))
(defn post-compile-process (ctx)
(case (should-load? (options-ctx ctx))
(:false :ok)
(:true
(let* (namespace-name (namespace-name-ctx ctx)
filename (filename-ctx ctx)
load-result (code/load_binary namespace-name filename (result-ctx ctx)))
(case load-result
({:module namespace-name}
;; The current namespace should always have up to date
;; requirements
(add-require-ctx ctx namespace-name)
:ok)
(_
(erlang/throw {:unable-to-load filename})))))))
(defn do-final-comp (ctx)
(let* (options (options-ctx ctx)
result (compile-context ctx :final))
(case result
(:uncompilable
:error)
(:error
:error)
(:ok (post-compile-process ctx)))))
;; Iterative Compilation
;; ---------------------
;;
;; This is the primary interface for users of the joxa system. It
;; implements the normal iterative approach to compilation that allows
;; the full use of the language.
(defn internal-forms (ctx input)
(case (has-more-data-to-parse input)
(:false
:ok)
(:true
(case (parse ctx input)
({:error _}
:error)
({ast0 (= rest {:parse-output _ path _})}
(make-forms (traverse-path path) ctx ast0)
(case (compile-context ctx :intermediate)
(:uncompilable
(internal-forms ctx rest))
(:ok
(post-compile-process ctx)
(internal-forms ctx rest))))))))
(defn forms (ctx binary options)
(set-context-all-ctx ctx [{:options options}])
(internal-forms ctx binary)
(do-final-comp ctx)
(get-raw-context ctx))
(defn+ forms (binary options)
(case (start-context)
({:ok ctx}
(let* (result (forms ctx binary options))
(report-errors-warnings ctx)
(stop-context ctx)
result))))
;; Namespace Info
;; -----------
;;
;; This does not compile a file. It simply evaluates a namespace enough
;; to get a complete context. there by providing information about the
;; namespace.
(defn get-require (form acc)
(case form
([]
acc)
((namespace-name . rest)
(when (erlang/is_atom namespace-name))
(get-require rest (namespace-name . acc)))
(([namespace-name [quote as] _] . rest)
(when (erlang/is_atom namespace-name))
(get-require rest (namespace-name . acc)))
(_
acc)))
(defn get-use (ctx form acc)
(case form
([]
acc)
(((use-namespace-name . clause-body) . rest)
(when (erlang/is_atom use-namespace-name))
(get-use ctx rest (use-namespace-name . acc)))
((use-namespace-name . rest)
(when (erlang/is_atom use-namespace-name))
(get-use ctx rest (use-namespace-name . acc)))
(_
(add-error-ctx ctx (new-path) {:invalid-use :invalid-form form})
acc)))
(defn internal-info (ctx input acc)
(case (has-more-data-to-parse input)
(:false
acc)
(:true
(case (parse ctx input)
({:error _}
[])
({(:ns . (namespace-name . rest)) rest-input}
(internal-info ctx rest-input
({namespace-name
(lists/flatten (lists/foldl
(fn (form iacc)
(case form
((:require . req-rest)
((get-require req-rest []) . iacc))
((:use . use-rest)
((get-use ctx use-rest []) . iacc))
(_
iacc))) [] rest))
} . acc)))
({_ rest-input}
(internal-info ctx rest-input acc))))))
(defn info (ctx binary options)
(set-context-all-ctx ctx [{:options options}])
(internal-info ctx binary []))
(defn+ info (input options)
(case input
(_ (when (is-binary input))
(case (start-context)
({:ok ctx}
(let* (result (info ctx input options))
(stop-context ctx)
result))))
(_ (when (is-list input))
(case (file/read_file input)
({:ok binary}
(info binary options))
({:error reason}
{:error {:file-access reason input}})))))
(defn+ info (file)
(info file []))
;; Interactive Compilation
;; -----------------------
;;
;; This section describes interactive compilation. That is the
;; compilation as it is designed be used in something like joxa-shell
;; or the eventual swank implementation for joxa. It is probably not
;; of interest to your average coder.
;;
;; Interactive basically takes the iterative approach and splits it up
;; into an API that can be called externally by tha user.
(defn+ clear-errors (ctx)
(errors-ctx ctx [])
(warnings-ctx ctx []))
(defn+ start-interactive ()
(case (start-context)
({:ok ctx}
ctx)))
(defn make-interactive-fun (ctx name ast)
(case (make-function (new-path) ctx ast)
({_ arg-list body}
(add-exported-def-ctx (new-path) ctx [] name arg-list body :replace))))
(defn make-dispatch (ctx interactive-name ast)
(let* (dispatchables
'(
defn+
defn
definline
deftype
deftype+
defspec
ns
defmacro
do
))
(case ast
((:ns . _)
(make-namespace (new-path) ctx ast)
:defn)
((element . rest)
(case (lists/member element dispatchables)
(:true
(make-definition (new-path) ctx ast))
(:false
(case element
(:require
(make-require (new-path) ctx rest)
:defn)
(:use
(make-use {0 0} ctx rest :undefined [])
:defn)
(_
(make-interactive-fun ctx interactive-name [interactive-name [] ast])
:expr)))))
(_
(make-interactive-fun ctx interactive-name [:interactive-name [] ast])
:expr))))
(defn internal-comp-interactive (ctx interactive-name input result0)
(case (has-more-data-to-parse input)