src/voodoo_translator/to_core.sb

   1 # Translates Antimony to Antimony core language.
   2
   3 section functions
   4 import _global_namespace *namespace* absolute_symbol antimony_builtins \
   5   array array_length array_nth array_t \
   6   blob_length block block_length block_nth block_t \
   7   concatenate_arrays \
   8   dynarray dynarray_add dynarray_to_array encode_symbol eq false gt lt ne \
   9   get_namespace get_namespace_absolute hash_table_get \
  10   hash_table_get_or_put hash_table_put \
  11   intern make_blob make_hash_table \
  12   namespace_intern namespace_name sb_core sb_core_call symbol_eq symbol_hash \
  13   subarray symbol_name symbol_namespace symbol_t true type_of
  14 export make_to_core_env to_core
  15
  16 function make_to_core_env {
  17   let table make_hash_table symbol_hash symbol_eq
  18
  19   hash_table_put table #`if if_to_core
  20   hash_table_put table #`import import_to_core
  21   hash_table_put table #`let letset_to_core
  22   hash_table_put table #`log log_to_core
  23   hash_table_put table #`quote quote_to_core
  24   hash_table_put table #`section section_to_core
  25   hash_table_put table #`set letset_to_core
  26   hash_table_put table #`struct struct_to_core
  27   hash_table_put table #`var var_to_core
  28
  29   let builtins (antimony_builtins)
  30   loop {
  31     let len array_length builtins
  32     var i = 0
  33     var sym = 0
  34     do
  35     while (lt i len)
  36     set sym array_nth builtins i
  37     if (ne sym #`alias) {
  38       hash_table_get_or_put table sym array_to_core_passthrough
  39     }
  40     set i add i 1
  41   }
  42
  43   return table
  44 }
  45
  46 function to_core env code {
  47   let type type_of code
  48   if (eq type array_t) {
  49     return (array_to_core env code)
  50   } else if (eq type block_t) {
  51     return (block_to_core env code)
  52   } else {
  53     return code
  54   }
  55 }
  56
  57 function array_to_core env code {
  58   let len array_length code
  59   if (gt len 0) {
  60     let first-item array_nth code 0
  61     if (eq (type_of first-item) symbol_t) {
  62       let fun hash_table_get env first-item -1
  63       if (eq fun -1) {
  64         if (eq (symbol_namespace first-item) (get_namespace #`core)) {
  65           return (array_to_core_passthrough env code)
  66         } else {
  67           let c auto-words 1
  68           set-word c 0 #`call
  69           return (array_to_core env (concatenate_arrays (array 1 c) code))
  70         }
  71       } else {
  72         return (fun env code)
  73       }
  74     }
  75   }
  76   return code
  77 }
  78
  79 function array_to_core_passthrough env code {
  80   let len array_length code
  81   let result auto-words len
  82   set-word result 0 (symbol_passthrough (array_nth code 0))
  83   loop {
  84     var i = 1
  85     do
  86     while (lt i len)
  87     set-word result i (to_core env (array_nth code i))
  88     set i add i 1
  89   }
  90   return (array len result)
  91 }
  92
  93 function blob_to_core env code {
  94   let items auto-words 4
  95   set-word items 0 @sb_core_call
  96   set-word items 1 #`make_blob
  97   set-word items 2 code
  98   set-word items 3 (add 1 (shl (blob_length code) 2))
  99   return (array 4 items)
 100 }
 101
 102 function block_to_core env code {
 103   let result dynarray 0 0
 104   loop {
 105     let len block_length code
 106     var i = 0
 107     do
 108     while (lt i len)
 109     dynarray_add result (to_core env (block_nth code i))
 110     set i add i 1
 111   }
 112   return (block (dynarray_to_array result))
 113 }
 114
 115 function if_to_core env code {
 116   let len array_length code
 117   let items auto-words len
 118   loop {
 119     var i = 0
 120     do
 121     while (lt i len)
 122     set-word items i (symbol_passthrough (array_nth code i))
 123     set i add i 1
 124     set-word items i (to_core env (array_nth code i))
 125     set i add i 1
 126     set-word items i (to_core env (array_nth code i))
 127     set i add i 1
 128     while (lt i len)
 129     set-word items i (symbol_passthrough (array_nth code i))
 130     set i add i 1
 131     if (ne (array_nth code i) #`if) {
 132       set-word items i (to_core env (array_nth code i))
 133       set i add i 1
 134     }
 135   }
 136   return (array len items)
 137 }
 138
 139 function import_to_core env code {
 140   let len array_length code
 141   let items auto-words len
 142   set-word items 0 #`core.import
 143   loop {
 144     var i = 1
 145     do
 146     while (lt i len)
 147     if (eq @*namespace* (symbol_namespace #`true)) {
 148       set-word items i (array_nth code i)
 149     } else {
 150       set-word items i (absolute_symbol (array_nth code i))
 151     }
 152     set i add i 1
 153   }
 154   return (array len items)
 155 }
 156
 157 function log_to_core env code {
 158   let items auto-words 1
 159   set-word items 0 #`__log
 160   return (to_core env (concatenate_arrays (array 1 items) (subarray code 1)))
 161 }
 162
 163 function letset_to_core env code {
 164   let len array_length code
 165   let items auto-words 3
 166   set-word items 0 (symbol_passthrough (array_nth code 0))
 167   set-word items 1 (array_nth code 1)
 168   if (gt len 3) {
 169     let rest subarray code 2
 170     return (concatenate_arrays (array 2 items) (to_core env rest))
 171   } else {
 172     set-word items 2 (to_core env (array_nth code 2))
 173     return (array 3 items)
 174   }
 175 }
 176
 177 function namespace_lookup_to_core env ns {
 178   if (eq ns @_global_namespace) {
 179     return #`@_global_namespace
 180   }
 181   let name namespace_name ns
 182   let parent symbol_namespace name
 183   let items auto-words 3
 184   set-word items 0 @sb_core_call
 185   if (eq parent @_global_namespace) {
 186     set-word items 1 #`get_namespace_absolute
 187     set-word items 2 (blob_to_core env (symbol_name name))
 188     return (array 3 items)
 189   } else {
 190     set-word items 1 #`get_namespace
 191     set-word items 2 (symbol_to_core env name)
 192     return (array 3 items)
 193   }
 194 }
 195
 196 function quote_to_core env code {
 197   let item array_nth code 1
 198   let type type_of item
 199   if (eq type symbol_t) {
 200     return (symbol_to_core env item)
 201   } else {
 202     return item
 203   }
 204 }
 205
 206 function section_to_core env code {
 207   let len array_length code
 208   let items auto-words len
 209   loop {
 210     var i = 0
 211     var sym = 0
 212     do
 213     while (lt i len)
 214     set sym array_nth code i
 215     set-word items i (symbol_passthrough sym)
 216     set i add i 1
 217   }
 218   return (array len items)
 219 }
 220
 221 function struct_to_core env code {
 222   let items auto-words 1
 223   set-word items 0 (symbol_passthrough (array_nth code 0))
 224   return (concatenate_arrays (array 1 items) (subarray code 1))
 225 }
 226
 227 function symbol_passthrough sym {
 228   # Returns a symbol with the same name as sym, but in the core namespace.
 229   return (namespace_intern (get_namespace #`core) (symbol_name sym))
 230 }
 231
 232 function symbol_to_core env sym {
 233   let items auto-words 4
 234   set-word items 0 @sb_core_call
 235   set-word items 1 #`namespace_intern
 236   set-word items 2 (namespace_lookup_to_core env (symbol_namespace sym))
 237   set-word items 3 (blob_to_core env (symbol_name sym))
 238   return (array 4 items)
 239 }
 240
 241 function var_to_core env code {
 242   let len array_length code
 243   let items auto-words 4
 244   set-word items 0 (symbol_passthrough (array_nth code 0))
 245   set-word items 1 (array_nth code 1)
 246   set-word items 2 (array_nth code 2)
 247   if (gt len 4) {
 248     let rest subarray code 3
 249     return (concatenate_arrays (array 3 items) (to_core env rest))
 250   } else {
 251     set-word items 3 (to_core env (array_nth code 3))
 252     return (array 4 items)
 253   }
 254 }