/* ------------------------------------------------------------------------- */
/*   "veneer" : Compiling the run-time "veneer" of any routines invoked      */
/*              by the compiler (e.g. DefArt) which the program doesn't      */
/*              provide                                                      */
/*                                                                           */
/*   Part of Inform 6    copyright (c) Graham Nelson 1993, 1994, 1995, 1996  */
/*                                                                           */
/* ------------------------------------------------------------------------- */

#include "header.h"

int veneer_mode;                      /*  Is the code currently being
                                          compiled from the veneer?          */

extern void compile_initial_routine(void)
{
    /*  The first routine present in memory in any Inform game, beginning
        at the code area start position, always has 0 local variables
        (since the interpreter begins execution with an empty stack frame):
        and it must "quit" rather than "return".

        In order not to impose these restrictions on "Main", we compile a
        trivial routine consisting of a call to "Main" followed by "quit".   */

    int32 j;
    assembly_operand AO, AO2;

    assign_symbol(j = symbol_index("Main__", -1),
        assemble_routine_header(0, FALSE, "Main__"),
        ROUTINE_T);
    sflags[j] |= SYSTEM_SFLAG + USED_SFLAG;

    AO.value = 0; AO.type = LONG_CONSTANT_OT; AO.marker = MAIN_MV;
    AO2.value = 255; AO2.type = VARIABLE_OT; AO2.marker = 0;

    assemble_1_to(call_vs_zc, AO, AO2);

    assemble_0(quit_zc);
    assemble_routine_end(FALSE);
}

/* ------------------------------------------------------------------------- */
/*   The rest of the veneer is applied at the end of the pass, as required.  */
/* ------------------------------------------------------------------------- */

static int   veneer_routine_needs_compilation[VENEER_ROUTINES];
int32 veneer_routine_address[VENEER_ROUTINES];

typedef struct VeneerRoutine_s
{   char *name;
    char *source_code;
} VeneerRoutine;

static VeneerRoutine VRs[VENEER_ROUTINES] =
{
    /*  Box__Routine:  the only veneer routine used in the implementation of
                       an actual statement ("box", of course), written in a
                       hybrid of Inform and assembly language.  Note the
                       transcription of the box text to the transcript
                       output stream (-1, or $ffff).                         */

    {   "Box__Routine",
        "maxw table n w w2 line lc t;\
         n = table --> 0;\
         @add n 6 -> sp;\
         @split_window sp;\
         @set_window 1;\
         w = 0 -> 33;\
         if (w == 0) w=80;\
         w2 = (w - maxw)/2;\
         style reverse;\
         @sub w2 2 -> w;\
         line = 5;\
         lc = 1;\
         @set_cursor 4 w;\
         spaces maxw + 4;\
         do\
         {   @set_cursor line w;\
             spaces maxw + 4;\
             @set_cursor line w2;\
             t = table --> lc;\
             if (t~=0) print (string) t;\
             line++; lc++;\
         } until (lc > n);\
         @set_cursor line w;\
         spaces maxw + 4;\
         @buffer_mode 1;\
         style roman;\
         @set_window 0;\
         @split_window 1;\
         @output_stream $ffff;\
         print \"[ \";\
         lc = 1;\
         do\
         {   w = table --> lc;\
             if (w ~= 0) print (string) w;\
             lc++;\
             if (lc > n)\
             {   print \"]^^\";\
                 break;\
             }\
             print \"^  \";\
         } until (false);\
         @output_stream 1;\
         ]"\
    },

    /*  This batch of routines is expected to be defined (rather better) by
        the Inform library: these minimal forms here are provided to prevent
        tiny non-library-using programs from failing to compile when certain
        legal syntaxes (such as <<Action a b>>;) are used.                   */

    {   "R_Process",
        "a b c; print \"Action <\", a, \" \", b, \" \", c, \">^\";\
         ]"\
    },
    {   "DefArt",
        "obj; print \"the \", obj; ]"
    },
    {   "InDefArt",
        "obj; print \"a \", obj; ]"
    },
    {   "CDefArt",
        "obj; print \"The \", obj; ]"
    },
    {   "PrintShortName",
        "obj; @print_obj obj; ]"
    },
    {   "EnglishNumber",
        "obj; print obj; ]"
    },
    {   "Print__PName",
        "prop p size;\
         prop = prop & $7fff;\
         p = #identifiers_table;\
         size = p-->0;\
         if (prop<0 || prop>=size || p-->prop==0)\
             print \"number \", prop;\
         else print (string) p-->prop;\
         ]"
    },

    /*  The remaining routines make up the run-time half of the object
        orientation system, and need never be present for Inform 5 programs. */

    {
        /*  WV__Pr:  write a value to the property for the given
                     object having the given identifier                      */

        "WV__Pr",
        "obj identifier value x;\
         x = obj..&identifier;\
         if (x==0) { RT__Err(\"write to\", obj, identifier); return; }\
         x-->0 = value;\
         ]"
    },
    {
        /*  RV__Pr:  read a value from the property for the given
                     object having the given identifier                      */

        "RV__Pr",
        "obj identifier x;\
         x = obj..&identifier;\
         if (x==0)\
         {   if (identifier >= 1 && identifier < 64)\
                 return obj.identifier;\
             RT__Err(\"read\", obj, identifier); return; }\
         return x-->0;\
         ]"
    },
    {   /*  CA__Pr:  call, that is, print-or-run-or-read, a property:
                     this exactly implements obj..prop(...).  Note that
                     classes (members of Class) have 5 built-in properties
                     inherited from Class: create, recreate, destroy,
                     remaining and copy.  Implementing these here prevents
                     the need for a full metaclass inheritance scheme.

            Apologies for the poor formatting below, but the string needs to
            be less than 2048 characters long or it won't compile under
            Microsoft Visual C/C++: in fact it is about 1950 chars long      */

        "CA__Pr",
        "obj identifier a b c d e f x s s2;\
if (obj < 1 || obj > #largest_object-255)\
{ switch(Z__Region(obj))\
  { 2: if (identifier == call)\
       { x = obj; jump Make__Call; }\
       jump Call__Error;\
    3: if (identifier == print)\
       { x = obj; jump Make__String; }\
       if (identifier == print_to_array)\
       { @output_stream 3 a;\
         @print_paddr obj;\
         @output_stream -3;\
         return a-->0;\
       }\
       jump Call__Error;\
  }\
  jump Call__Error;\
}\
if (identifier >= 0 && identifier < 64)\
{ x = obj.&identifier;\
  if (x==0) x = obj.identifier; else x = x-->0;\
}\
else\
{ if (identifier >= 64 && identifier < 72)\
  { if (obj in Class) switch(identifier)\
    { create:\
         if (children(obj)<=1) rfalse;\
         x=child(obj);\
         remove x;\
         if (x provides create) x..create();\
         return x;\
      recreate:\
         if (~~(a ofclass obj))\
         { RT__Err(\"recreate\", a, -obj); rfalse; }\
         Copy__Primitive(a, child(obj));\
         if (a provides create) a..create();\
         rfalse;\
      destroy:\
         if (~~(a ofclass obj))\
         { RT__Err(\"destroy\", a, -obj); rfalse; }\
         if (a provides destroy) a..destroy();\
         Copy__Primitive(a, child(obj));\
         move a to obj; rfalse;\
      remaining:\
         return children(obj)-1;\
      copy:\
         if (~~(a ofclass obj))\
         { RT__Err(\"copy\", a, -obj); rfalse; }\
         if (~~(b ofclass obj))\
         { RT__Err(\"copy\", b, -obj); rfalse; }\
         Copy__Primitive(a, b);\
         rfalse;\
    }\
  }\
  x = obj..&identifier;\
  if (x == 0) { .Call__Error;\
    RT__Err(\"send message\", obj, identifier); return; }\
  x = x-->0;\
}\
if (x==$ffff) rfalse;\
switch(Z__Region(x))\
{ 2: .Make__Call; s = self; s2 = sender; sender = self; self = obj;\
#ifdef action;sw__var=action;#endif;\
x = indirect(x, a, b, c, d, e, f);\
self = s; sender = s2; return x;\
  3: .Make__String; print_ret (string) x;\
}\
return x;\
]"
    },
    {
        /*  IB__Pr:  ++(individual property)                                 */

        "IB__Pr",
        "obj identifier x;\
         x = obj..&identifier;\
         if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
         return ++(x-->0);\
         ]"
    },
    {
        /*  IA__Pr:  (individual property)++                                 */

        "IA__Pr",
        "obj identifier x;\
         x = obj..&identifier;\
         if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
         return (x-->0)++;\
         ]"
    },
    {
        /*  DB__Pr:  --(individual property)                                 */

        "DB__Pr",
        "obj identifier x;\
         x = obj..&identifier;\
         if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
         return --(x-->0);\
         ]"
    },
    {
        /*  DA__Pr:  (individual property)--                                 */

        "DA__Pr",
        "obj identifier x;\
         x = obj..&identifier;\
         if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
         return (x-->0)--;\
         ]"
    },
    {
        /*  RA__Pr:  read the address of a property value for a given object,
                     returning 0 if it doesn't provide this individual
                     property                                                */

        "RA__Pr",
        "obj identifier i otherid cla;\
         if (identifier<64 && identifier>0) return obj.&identifier;\
         if (obj.&3 == 0) rfalse;\
         if (identifier & $8000 ~= 0)\
         {   cla = #classes_table-->(identifier & $1ff);\
             if (cla.&3 == 0) rfalse;\
             if (~~(obj ofclass cla)) rfalse;\
             identifier = (identifier & $7e00) / $200;\
             i = cla.3;\
             while (identifier>0)\
             {   identifier--;\
                 i = i + i->2 + 3;\
             }\
             return i+3;\
         }\
         if (obj in 1)\
         {   if (identifier<64 || identifier>=72) rfalse;\
         }\
         if (self == obj)\
             otherid = identifier | $8000;\
         i = obj.3;\
         while (i-->0 ~= 0)\
         {   if (i-->0 == identifier or otherid)\
                 return i+3;\
             i = i + i->2 + 3;\
         }\
         rfalse;\
         ]"
    },
    {
        /*  RL__Pr:  read the property length of an individual property value,
                     returning 0 if it isn't provided by the given object    */

        "RL__Pr",
        "obj identifier x;\
         if (identifier<64 && identifier>0) return obj.#identifier;\
         x = obj..&identifier;\
         if (x==0) rfalse;\
         return (x-1)->0;\
         ]"
    },
    {
        /*  RA__Sc:  implement the "superclass" (::) operator,
                     returning an identifier                                 */

        "RA__Sc",
        "cla identifier otherid i j k;\
         if (cla notin 1 && cla ~= 1)\
         {   RT__Err(\"be a '::' superclass\", cla, -1); rfalse; }\
         if (self ofclass cla) otherid = identifier | $8000;\
         for (j=0: #classes_table-->j ~= 0: j++)\
         {   if (cla==#classes_table-->j)\
             {   if (cla.&3 == 0) break;\
                 i = cla.3;\
                 while (i-->0 ~= 0)\
                 {   if (i-->0 == identifier or otherid)\
                         return $8000 + k*$200 + j;\
                     i = i + i->2 + 3;\
                     k++;\
                 }\
                 break;\
             }\
         }\
         RT__Err(\"make use of\", cla, identifier);\
         rfalse;\
         ]"
    },
    {
        /*  OP__Pr:  test whether or not given object provides individual
                     property with the given identifier code                 */

        "OP__Pr",
        "obj identifier;\
         if (obj<1 || obj > (#largest_object-255))\
         {   if (identifier ~= print or print_to_array or call) rfalse;\
             switch(Z__Region(obj))\
             {   2: if (identifier == call) rtrue;\
                 3: if (identifier == print or print_to_array) rtrue;\
             }\
             rfalse;\
         }\
         if (identifier<64)\
         {   if (obj.&identifier ~= 0) rtrue;\
             rfalse;\
         }\
         if (obj..&identifier ~= 0) rtrue;\
         if (identifier<72 && obj in 1) rtrue;\
         rfalse;\
         ]"
    },
    {
        /*  OC__Cl:  test whether or not given object is of the given class  */

        "OC__Cl",
        "obj cla j a n;\
         if (obj<1 || obj > (#largest_object-255))\
         {   if (cla ~= 3 or 4) rfalse;\
             if (Z__Region(obj) == cla-1) rtrue;\
             rfalse;\
         }\
         switch(cla)\
         {   1: if (obj<=4) rtrue;\
                if (obj in 1) rtrue;\
                rfalse;\
             2: if (obj<=4) rfalse;\
                if (obj in 1) rfalse;\
                rtrue;\
             3, 4: rfalse;\
         }\
         if (cla notin 1) { RT__Err(\"apply 'ofclass' for\", cla, -1);rfalse;}\
         a = obj.&2;\
         if (a==0) rfalse;\
         n = obj.#2;\
         for (j=0: j<n/2: j++)\
         {   if (a-->j == cla) rtrue;\
         }\
         rfalse;\
         ]"
    },
    {   /*  Copy__Primitive:  routine to "deep copy" objects                 */

        "Copy__Primitive",
        "o1 o2 a1 a2 n m l size identifier;\
         for (n=0:n<48:n++)\
         {   if (o2 has n) give o1 n;\
             else give o1 ~n;\
         }\
         for (n=1:n<64:n++)\
         {   a1 = o1.&n; a2 = o2.&n; size = o1.#n;\
             if (a1~=0 && a2~=0 && size==o2.#n)\
             {   for (m=0:m<size:m++) a1->m=a2->m;\
             }\
         }\
         if (o1.&3 == 0 || o2.&3 == 0) return;\
         for (n=o2.3: n-->0 ~= 0: n = n + size + 3)\
         {   identifier = n-->0;\
             size = n->2;\
             for (m=o1.3: m-->0 ~= 0: m = m + m->2 + 3)\
                 if ((identifier & $7fff == (m-->0) & $7fff) && size==m->2)\
                     for (l=3: l<size+3: l++) m->l = n->l;\
         }\
         ]"
    },
    {   /*  RT__Err:  for run-time errors occurring in the above: e.g.,
                      an attempt to write to a non-existent individual
                      property                                               */

        "RT__Err",
        "crime obj id size p;\
         print \"^** Run-time error: \";\
         if (obj in Class) print \"Class \";\
         @print_obj obj;\
         print \" (object number \", obj, \") \";\
         if (id<0)\
             print \"is not of class \", (name) -id;\
         else\
         {   print \" has no property \", (property) id;\
             p = #identifiers_table;\
             size = p-->0;\
             if (id<0 || id>=size)\
                 print \" (and nor has any other object)\";\
         }\
         print \" to \", (string) crime, \" **^\";\
         ]"
    },
    {   /*  Z__Region:  Determines whether a value is:
                        1  an object number
                        2  a code address
                        3  a string address
                        0  none of the above                                 */

        "Z__Region",
        "addr;\
         if (addr==0) rfalse;\
         if (addr>=1 && addr<=(#largest_object-255)) rtrue;\
         if (Unsigned__Compare(addr, #strings_offset)>=0) return 3;\
         if (Unsigned__Compare(addr, #code_offset)>=0) return 2;\
         rfalse;\
         ]"
    },
    {   /*  Unsigned__Compare:  returns 1 if x>y, 0 if x=y, -1 if x<y        */

        "Unsigned__Compare",
        "x y u v;\
         if (x==y) return 0;\
         if (x<0 && y>=0) return 1;\
         if (x>=0 && y<0) return -1;\
         u = x&$7fff; v= y&$7fff;\
         if (u>v) return 1;\
         return -1;\
         ]"
    },
    {   /*  Meta__class:  returns the metaclass of an object                 */

        "Meta__class",
        "obj;\
         switch(Z__Region(obj))\
         {   2: return Routine;\
             3: return String;\
             1: if (obj in 1 || obj <= 4) return Class;\
                return Object;\
         }\
         rfalse;\
         ]"
    }
};

extern assembly_operand veneer_routine(int code)
{   assembly_operand AO;

    AO.type = LONG_CONSTANT_OT;
    AO.marker = VROUTINE_MV;
    AO.value = code;
    veneer_routine_needs_compilation[code] = TRUE;

    if (code == CA__Pr_VR)
    {   veneer_routine_needs_compilation[Copy__Primitive_VR] = TRUE;
        veneer_routine_needs_compilation[Unsigned__Compare_VR] = TRUE;
        veneer_routine_needs_compilation[Z__Region_VR] = TRUE;
    }

    if ((code == OC__Cl_VR) || (code == OP__Pr_VR) || (code == Metaclass_VR))
    {   veneer_routine_needs_compilation[Unsigned__Compare_VR] = TRUE;
        veneer_routine_needs_compilation[Z__Region_VR] = TRUE;
    }

    if (code >= WV__Pr_VR)
        veneer_routine_needs_compilation[RT__Err_VR] = TRUE;

    if (code == RT__Err_VR)
        veneer_routine_needs_compilation[Print__Pname_VR] = TRUE;

    return(AO);
}

extern void compile_veneer(void)
{   int i, j;

    if (module_switch) return;

    /*  Called at the end of the pass to insert as much of the veneer as is
        needed and not elsewhere compiled.  */

    for (i=0; i<VENEER_ROUTINES; i++)
    {   if (veneer_routine_needs_compilation[i])
        {   j = symbol_index(VRs[i].name, -1);
            if (sflags[j] & UNKNOWN_SFLAG)
            {   veneer_mode = TRUE;
                assign_symbol(j,
                    parse_routine(VRs[i].source_code, FALSE, VRs[i].name),
                    ROUTINE_T);
                veneer_mode = FALSE;
            }
            else
            {   if (stypes[j] != ROUTINE_T)
                error_named("The following name is reserved by Inform for its \
own use as a routine name; you can use it as a routine name yourself (to \
override the standard definition) but cannot use it for anything else:",
                    VRs[i].name);
                else
                    sflags[j] |= USED_SFLAG;
            }
            veneer_routine_address[i] = svals[j];
        }
    }
}

/* ========================================================================= */
/*   Data structure management routines                                      */
/* ------------------------------------------------------------------------- */

extern void init_veneer_vars(void)
{
}

extern void veneer_begin_pass(void)
{   int i;
    veneer_mode = FALSE;
    for (i=0; i<VENEER_ROUTINES; i++)
    {   veneer_routine_needs_compilation[i] = FALSE;
        veneer_routine_address[i] = 0;
    }
}

extern void veneer_allocate_arrays(void)
{
}

extern void veneer_free_arrays(void)
{
}

/* ========================================================================= */
