compile.ctr

#!/usr/bin/env ctr

Broom memoryLimit: 1024 * 1024 * 512.

(Program argCount = 2) ifTrue: {
  Pen writeln: 'Usage: compile <infile> [<outfile> (defaults to a.out)] [OPTIONS] [-- <compiler options>]'.
  Program exit.
}.

var prgargs is Array new fill: Program argCount - 2 with: \:i Program argument: i + 2.
prgargs on: 'shiftArg' do: {:self ^self count > 0 either: { ^self shift. } or: Nil. }.

import Library/Data/SwitchCase.
import Library/Data/IO/Pen: 'pPen'.
import Library/Data/Map.
import Library/AST/ast2ctrcode: 'ast2ctrcode'.

var errPen is pPen for: (File special: 'stderr').
var flags is Shell ctrconfig: '--ldflags --cflags', trim.

#:language XFrozen

Array on: 'toBoolean' do: { ^me count > 0. }.

var import_intrinsic is False.
var optimize is False.
var exceptions is True.
var dexceptions is False.
var dexceptions_s is ''.

var var_id is 0.
var gvar_id is 0.
var fun_id is 0.
# [type_s, name, value_s]
var variables is Array new.
var global_variables is Array new.

Array on: 'has_variable:' do: {:v
  ^any: \:x v = (x @ 1).
}.

# name -> code
var functions is Map new.

var generate_single_arg_t is {:arg
  ^['ctr_object*', 'arg_v$$var_id', arg].
}.
var generate_single_argn_t is {:*args
  ^['ctr_argument', 'arg_vp$$var_id', (Map new put: args @ 0 at: '.object', put: args @ 1 at: '.next')].
}.

var c_addrof is \:x '&$$x'.

var generate_args is {:count:args:receiver
  ^Array new fill: count with: {:x
    var_id +=: 1.
    var argv is generate_single_arg_t[compile[(args at: x), receiver]].
    variables push: argv.
    ^argv @ 1.
  }, reverse foldl: {:acc:x
    var_id +=: 1.
    var argvp is generate_single_argn_t[x, acc].
    variables push: argvp.
    ^c_addrof[argvp @ 1].
  } accumulator: 'NULL'.
}.

var return_now is False.

var strmap is Map new.

String on: 'literalEscape' do: {
  ^ me escapeAsciiControls escape: '"'.
  # ^(me ~ ?>s/\\/\\\\/g<?) escapeDoubleQuotes ~ 's/\n|\r|\t|\v|\a|\b|\f/\\\\n/g'.
}.

var make_or_get_str is {:s
  s is s literalEscape.
  s length = 0 ifTrue: { errPen yellow writeln: 'NULL creation requested in context %s (after %s)' % [contexts last, contexts init last], resetColor. ^'ctr_build_string("", 1)'. }.
  ^strmap at: s, or: {
    gvar_id +=: 1.
    var name is 'ctr_str_$$gvar_id'.
    # errPen writeln: '%s = %s' % [name, s].
    global_variables push: ['ctr_object*', name, 'ctr_build_string("%s", %d)' % [s, s length]].
    strmap put: name at: s.
    ^name.
  }.
}.

var generate_func_param_load is {:ps:_self
  var params is Array new fill: ps count with: {:i ^ps at: i, value. }.
  var x is make_or_get_str['me'].
  var s is 'ctr_object* self = ctr_find_(%s, 1);\nif (!self) ctr_assign_value_to_local_by_ref(%s, a_);\n' % [x, x].
  # _self isNil ifFalse: {
  #   s +=: 'self = ' + _self + ';\n'.
  # }.
  params each_v: {:param
    s +=: '/* param "%s" */\n' % [param].
    param = 'self' either: {
      s +=: 'ctr_assign_value_to_local_by_ref(%s, self);\n' % [make_or_get_str[param]].
      locals put: 'self' at: 'self'.
    } or: {
      var fname is 'param_$$param'.
      s +=: 'ctr_object* $$fname = b__->object;\n'.
      s +=: 'ctr_assign_value_to_local_by_ref(%s, b__->object);\nb__ = b__->next;\n' % [make_or_get_str[param]].
      locals put: fname at: param.
    }.
  }.
  ^s.
}.

var contexts is Array new.

var imported_files is Array new.

var compile_subprogram is {:*subs
  # Emits an inner block
  subs is subs fmap: (\:x x type = 'UNAMESSAGE' either: x or: {
    var xv is x value.
    ['__map2Array:', 'searchPaths', 'export:as:', 'require-parent', 'dir:',
     '__resolve_request:internally:', 'return:', 'return', '__realloc:', '__load:',
     '__unify:', 'respondTo:', 'respondTo:and:'
    ] contains: xv, continue.
    errPen red writeln: 'named imports are not supported yet(%s), All symbols will be imported as they are named' % [xv], resetColor.
    var vals is xv split: ':'.
    ^vals fmap: \:a ($(import something) @ 1) value: a.
  }), foldl: (\:acc:x x isA: Array, either: {^acc + (x fmap: \:x [True, x]).} or: acc + [[False, x]]) accumulator: [].
  var curdir is File new: '.', realPath.
  var parts is Array new.
  subs each_v: ({:sub
    var x is sub head either: {
      sub is sub last value.
      var res is import __resolve_request: sub internally: True.
      res any: \:x x isNil, ifTrue: { thisBlock error: 'Unknown import $$sub'. }.
      ^[sub, res].
    } or: {
      sub is sub last value.
      var res is import __resolve_request: sub internally: True.
      res any: \:x x isNil, ifTrue: { thisBlock error: 'Unknown import $$sub'. }.
      Pen writeln: 'Switching to dir ' + (res @ 1).
      Program changeDirectory: res @ 1.
      ^[sub, res].
    }.
    var f is x @ 1 @ 0.
    contexts push: 'import <%s>' % [f].
    imported_files contains: f, continue.
    imported_files push: f.
    var resv is x @ 1.
    var name is x @ 0.
    resv any: \:x x isNil, ifTrue: {
      thisBlock error: 'Could not find any import %s' % [name].
      True continue.
    }.
    var s is '/* import $$name */\n'.
    var oldvs is variables.
    var oldvarid is var_id.
    variables is Array new.

    s +=: compile[(AST parse: resv last read)].

    variables is oldvs.
    var_id is oldvarid.

    contexts pop.
    parts push: s.
  }).
  Program changeDirectory: curdir.

  ^parts join: '\n'. #fmap: \:x '{ $$x }', join: '\n'.
}.

var locals is Map new.

var compile is {:ast:receiver
  contexts push: ast.
  # Pen writeln: contexts count.
    var ret is (frozen __ is
    case: 'LTRNUM' do: {
      ^'ctr_build_number_from_float(%d)' % [ast evaluate].
    },
    case: 'LTRSTRING' do: {
      var value is ast value.
      ^make_or_get_str[value].
    },
    case: 'LTRNIL' do: {
      ^'CtrStdNil'.
    },
    case: 'LTRBOOLTRUE' do: {
      ^'ctr_build_bool(1)'.
    },
    case: 'LTRBOOLFALSE' do: {
      ^'ctr_build_bool(0)'.
    },
    case: 'REFERENCE' do: {
      var value is ast value.
      var cached is locals at: value.
      cached isNil ifTrue: {
        #^'(ctr_find_(%s, 1) ?: CtrStdNil)' % [make_or_get_str[value]].
        ^'ctr_find_(%s, 0)' % [make_or_get_str[value]].
      } ifFalse: {
        ^cached.
      }.
    },
    case: 'EXPRMESSAGE' do: {
      var rec is ast at: 0.
      (rec type = 'REFERENCE') & (rec value = 'import') ifTrue: {
        import_intrinsic ifTrue: {
          # Treat import as a compiler intrinsic
          ^compile_subprogram[(ast at: i),, (i: (Generator from: 1 to: ast count - 1))].
        }.
        ^'ctr_string_eval(%s, NULL)' % [make_or_get_str[ast2ctrcode[ast]]].
      }.
      var obj is compile[ast @ 0].
      # BUG: This _might_ evaluate an expression several times
      var msgs is Array new fill: ast count - 1 with: {:i ^compile[(ast at: i + 1), obj]. }.
      ^msgs foldl: (\:acc:x 'ctr_send_message(%s, %s)' % [acc, x]) accumulator: obj.
    },
    case: 'UNAMESSAGE' do: {
      var value is ast value.
      ^'"%s", %d, NULL' % [value, value length].
    },
    case: 'BINMESSAGE' do: {
      var value is ast value.
      ^'"%s", %d, %s' % [value, value length, generate_args[1, ast]].
    },
    case: 'KWMESSAGE' do: {
      var value is ast value.
      var req is value = 'on:do:' either: {
        ^[value, value length, generate_args[ast count, ast, receiver]].
      } or: {
        ^[value, value length, generate_args[ast count, ast]].
      }.
      ^'"%s", %d, %s' % req.
    },
    case: 'EXPRASSIGNMENT' do: {
      var ref is ast at: 0.
      var _value is ast at: 1.
      var name is ref value.
      locals at: name, isNil ifFalse: {
          # has previous value
          var res is compile[_value].
          locals put: res at: name.
          ^res.
      }.
      var compiled is compile[_value]. 
      var arg is generate_single_arg_t[compiled]. 
      global_variables any: \:x (x @ 1) = (arg @ 1), ifFalse: {
          global_variables push: [arg @ 0, arg @ 1, 'NULL'].
      }.
      variables push: ['', arg @ 1, arg @ 2].
      locals put: arg @ 1 at: name.

      ^(frozen __ is
        case: 0 do: {
          ^'ctr_assign_value(%s, %s)' % [make_or_get_str[ref value], arg @ 1].
        },
        case: 1 do: {
          ^'ctr_assign_value_to_my(%s, %s)' % [make_or_get_str[ref value], arg @ 1].
        },
        case: 2 do: {
          ^'ctr_assign_value_to_local(%s, %s)' % [make_or_get_str[ref value], arg @ 1].
        },
        case: 3 do: {
          ^'ctr_assign_value(%s, %s)' % [make_or_get_str[ref value], arg @ 1].
        },
        case: 4 do: {
          thisBlock error: 'modifier 4 not supported in assignments'.
          ^'ctr_assign_value'.
        },
        case: 5 do: {
          thisBlock error: 'modifier 5 not supported in assignments'.
          ^'ctr_assign_value'.
        },
        default: {
          ^'ctr_assign_value(%s, %s)' % [make_or_get_str[ref value], arg @ 1].
        }) switch: ref modifier.
    },
    case: 'SYMBOL' do: {
      var value is $!(ast) toString skip: 1.
      ^'ctr_get_or_create_symbol_table_entry("%s", %d)' % [value, value length].
    },
    case: 'NESTED' do: {
      ^compile[(ast at: 0)].
    },
    case: 'CODEBLOCK' do: {
      var oldvs is variables.
      var oldvarid is var_id.
      var instrs is ast at: 1.
      fun_id +=: 1.
      var funname is 'ctr_function_$$fun_id'.
      variables is Array new.
      var_id is 0.
      var old_locals is locals.
      locals is Map new.
      var funcodeargs is generate_func_param_load[ast @ 0, receiver] + '\n'.

      var funcode is '  ctr_object* result = (%:L);\n' % [', ', (
        (Array new fill: instrs count with: {:x
          ^compile[instrs @ x].
        })
          or: ['NULL']
      )].
        funcode is funcode + '   ctr_close_context();'.
      # ast modifier = 'My', ifTrue: {
        funcode is funcode + '  if (result == NULL) result = self;\n'.
        funcode is 'ctr_open_context();\n' + funcodeargs + generate_inits['  '] + funcode.
        funcode is funcode + '   return result;\n'.
      # }.
      var code is ast2ctrcode[ast].
      var instr_u is code replace: '\n' with: '<NL>'.
      funcode is '/* ' + instr_u + '*/\n' + funcode.
      locals is old_locals.
      variables is oldvs.
      var_id is oldvarid.
      functions put: funcode at: funname.
      ^'internal_ctr_create_block__(%s)' % [funname].
    },
    case: 'PROGRAM' do: {
      var instrs is ast.
      var res is Array new fill: instrs count with: {:x
        var old_vars is variables.
        variables is Array new.
        var instr is instrs @ x.
        # Pen writeln: '-> ' + instr.
        var s is compile[instr].
        var i is generate_inits[' '].
        variables is old_vars.
        var code is ast2ctrcode[instr].
        # Pen writeln: '< ' + code + ' >'.
        var instr_u is code replace: '\n' with: '<NL>'.
        # Pen writeln: '> ' + instr_u.
        ^'{/* $$instr_u */\n' + i + s + ';\n' + '}\n' + (dexceptions either: 'exc_check("%s");\n' % [instr_u escapeDoubleQuotes] or: '').
      }.
      ^res join: ''.
    },
    case: 'ENDOFPROGRAM' do: { ^'CtrStdNil'. },
    case: 'RETURNFROMBLOCK' do: { return_now is True. ^compile[ast @ 0]. },
    case: 'IMMUTABLE' do: {
      var elements is ast at: 0.
      var count is elements count.
      var_id +=: 1.
      var vname is 'ctr_tuple_$$var_id'.
      var props is Map new
        put: 'ctr_internal_create_object(CTR_OBJECT_TYPE_OTARRAY)' at: '', # initialize
        put: 'ctr_heap_allocate(sizeof (ctr_collection))' at: '->value.avalue',
        put: 'ctr_heap_allocate(sizeof (ctr_object *) * %d)' % [count] at: '->value.avalue->elements',
        put: count at: '->value.avalue->head',
        put: 0 at: '->value.avalue->tail',
        put: count at: '->value.avalue->length',
        put: 1 at: '->value.avalue->immutable'.
      var mp is Map new.
      Array new fill: count with: \:x compile[elements @ x], each: {:i:x
        props put: x at: '->value.avalue->elements[%d]' % [i].
      }.
      props each: {:k:v mp put: v at: k.}.
      variables push: ['ctr_object*', vname, mp].
      ^vname.
    },
    default: { errPen red writeln: '$$ast is not compilable at the moment', resetColor. }) switch: ast type.
    # Pen writeln: 'done ' + contexts count.
    contexts pop.
    ^ret.
}.

var single_argn_t is {:value
  var_id +=: 1.
  var argt is generate_single_arg_t[value].
  var_id +=: 1.
  var argnt is generate_single_argn_t[argt @ 1, 'NULL'].
  variables push: argt, push: argnt.
  ^c_addrof[argnt @ 1].
}.

var generate_inits is {:q
  var src is ''.
  variables each_v: {:v
    (v last isA: Map) either: {
      var vn is v @ 1.
      src +=: '%s %s;\n' % [v @ 0, vn].
      src +=: dexceptions_s.
      var vv is v @ 2.
      vv each: {:k:v
        src +=: '%s%s = %s;\n' % [vn, k, v].
        src +=: dexceptions_s.
      }.
    } or: {
      src +=: '%s%s %s = %s;\n' % ([q] + v).
      src +=: dexceptions_s.
    }.
  }.
  ^src.
}.

var generate_funcs is {
  var s is ''.
  var init is ''.
  functions each: {:k:v
    init +=: 'ctr_object* %s(ctr_object*a_, ctr_argument*b__);\n' % [k].
    s +=: 'ctr_object* %s(ctr_object*a_, ctr_argument*b__) {\n%s }\n' % [k, v].
  }.
  ^init + s.
}.

var generate_globals is {
  var decl is ''.
  var sv is ''.
  global_variables each_v: {:v
    decl +=: '%s %s; //global\n' % v init.
    (v last isA: Map) either: {
      var vn is v @ 1.
      var vv is v @ 2.
      vv each: {:k:v
        sv +=: '%s%s = %s;\n' % [vn, k, v].
      }.
    } or: {
      sv +=: '%s = %s;\n' % v tail.
    }.
  }.
  ^[decl, sv].
}.

var generate_defines is {
  var s is ''.
  exceptions ifTrue: {
    # s +=: 'static int msg_level = 0;'.
    s +=: 'ctr_object* ctr_send_message_check_exception(ctr_object* r, char* s, int l, ctr_argument* a){\n'.
    # s +=: '  for(int i=0; i<msg_level; i++) printf("-");'.
    # s +=: '  printf("> Sending message %.*s to object %p\\n", l, s, r);\n'.
    # s +=: '  msg_level++;\n'.
    s +=: '  ctr_object *rt = ctr_send_message(r,s,l,a);\n'.
    # s +=: '  msg_level--;printf("<");\n'.
    # s +=: '  for(int i=0; i<msg_level; i++) printf("-");'.
    # s +=: '  printf(" Received result %p (%s)\\n", rt, ctr_heap_allocate_cstring(ctr_internal_cast2string(rt)));\n'.
    s +=: '  if (CtrStdFlow) { CtrStdFlow = ctr_internal_cast2string(CtrStdFlow); printf("Panic: Uncaught exception\\n%.*s\\n", CtrStdFlow->value.svalue->vlen, CtrStdFlow->value.svalue->value); exit(1); }\n'.
    s +=: '  return rt;\n}\n'.
    s +=: '#define ctr_send_message ctr_send_message_check_exception\n'.
  }.
  dexceptions ifTrue: {
    s +=:
    'void exc_check_(char const* file, char const* func, int line, const char* s) {
        if (CtrStdFlow) {
            ctr_object* err = CtrStdFlow; CtrStdFlow = NULL;
            printf("in file %s, function %s (line %d) [program subsection \\"%s\\"] threw: ", file, func, line-1, s);
            ctr_send_message_variadic(CtrStdConsole, "writeln:", 8, 1, err);
            exit(1);
        }
    }\n'.
    s +=: '#define exc_check(x) exc_check_(__FILE__, __func__, __LINE__, x)\n'.
  }.
  ^s.
}.

var compile_complete is {:ast
  var s is compile[ast].
  var gl is generate_globals[].
  ^ '#include <Citron/citron.h>\n'
  + '#include <gc/gc.h>\n'
  + generate_defines[]
  + 'ctr_object* internal_ctr_create_block__(ctr_object*(fn(ctr_object*,ctr_argument*))) {\n'
  + '  ctr_object* obj = ctr_internal_create_object(CTR_OBJECT_TYPE_OTNATFUNC);\n'
  + '  obj->value.fvalue = fn;\n'
  + '  ctr_set_link_all(obj, CtrStdBlock);\n'
  + '  return obj;\n}\n'
  + (gl @ 0)
  + generate_funcs[]
  + 'int main() {\n'
  + '  ctr_initialize_ex();\n'
  + generate_options[]
  + (gl @ 1)
  + '/* Main program */\n'
  + s + ';\n'
  + '  if (CtrStdFlow) {\n'
  + '    ctr_object* err = CtrStdFlow; CtrStdFlow = NULL;\n'
  + '    ctr_send_message_variadic(CtrStdConsole, "writeln:", 8, 1, err);\n'
  + '    exit(1);\n}\n'
  + '  return 0;\n}'.
}.

var filename is prgargs shift.

filename = '-h' ifTrue: {
  Pen green writeln: 'Citron down-compiler'.
  Pen tab yellow writeln: '[WARNING] Incomplete software'.
  Pen resetColor writeln: 'Usage: compile <infile> [<outfile> (defaults to a.out)] [OPTIONS] [-- <compiler options>]'.
  Pen cyan writeln: 'OPTIONS'.
  Pen tab writeln: '--keep-intermediates \tKeep intermediate files',
      tab writeln: '-O\t\t\tEnable optimizations (also disables exceptions)',
      tab writeln: '--no-exceptions \tDisable exception checks',
      tab writeln: '--detailed-exceptions \tShows detailed runtime exceptions',
      tab writeln: '--import-intrinsic \tTreat import statements as compiler intrinsics',
      tab writeln: '--heap-size=SIZE \tSpecify starting heap size (SIZE format: number B|K|M|G)',
      tab writeln: '--heap-max=SIZE \tSpecify the maximum allowed heap size (program will abort if too small)',
  resetColor.
  Program exit.
}.

var ofilename is prgargs shiftArg or: 'a.out'.
var src is File new: filename, read.
var tgt is File new: ofilename + '.c'.

var byteDecls is Map new
    put: 1 at: 'b',
    put: 1024 at: 'k',
    put: 1024 * 1024 at: 'm',
    put: 1024 * 1024 * 1024 at: 'g'.
byteDecls on: 'applyAll:' do: {:args ^me at: args head lower. }.

var parseByteDecl is {:decl
    var num is -1.
    decl findPattern: ?>^(\d+)(b|B|k|K|m|M|g|G)<? do: {:grs
        num is (grs @ 1) toNumber * byteDecls[grs @ 2].
    }.
    num = -1 ifTrue: { thisBlock error: 'Invalid size spec $$decl'. }.
    ^num.
}.

var heapsize is -1.
var heapmax is -1.

prgargs each: {:_:v
    (v = '--') break.
    v startsWith: '--heap-size=', ifTrue: {
        heapsize is parseByteDecl[(v skip: 12)].
        True continue.
    }.
    v startsWith: '--heap-max=', ifTrue: {
        heapmax is parseByteDecl[(v skip: 11)].
        True continue.
    }.
    v = '--no-exceptions' ifTrue: {
      exceptions is False.
      True continue.
    }.
    v = '--detailed-exceptions' ifTrue: {
      dexceptions is True.
      dexceptions_s is 'exc_check("");\n'.
      True continue.
    }.
    v = '--import-intrinsic' ifTrue: {
      import_intrinsic is True.
      True continue.
    }.
    v = '-O' ifTrue: {
      optimize is True.
      exceptions is False.
      True continue.
    }.
}.


import_intrinsic ifTrue: { errPen magenta writeln: '--import-intrinsic is unstable and will probably not work correctly', resetColor. }.

errPen write: 'Compiling file $$filename into $$ofilename ...\n'.

var idx is prgargs indexOf: '--'.
var comp_opts is optimize either: ['-Ofast', '-ftree-vectorize', '-fomit-frame-pointer'] or: [].
idx > -1 ifTrue: {
  comp_opts is prgargs from: idx - 1 lengthMax: prgargs count.
  errPen green writeln: 'Will pass %:L to the compiler' % [' ', comp_opts], resetColor.
}.

var generate_options is {
    var s is ''.
    heapmax > 0 ifTrue: {
        s +=: '  ctr_gc_memlimit = %d;\n' % [heapmax].
    }.
    heapsize > 0 ifTrue: {
        s +=: '  GC_expand_hp(%s);\n' % [heapsize].
    }.
    ^s.
}.

tgt write: compile_complete[(AST parse: src)].
Shell g++: '%s -L/usr/local/lib %:L -ggdb3 %s -o %s' % [tgt path, '\x20', comp_opts, flags, ofilename].
prgargs contains: '--keep-intermediates', ifFalse: {
  tgt delete.
}.
Pen green writeln: 'Success'.