1 files changed, 1308 insertions, 0 deletions

diff --git a/libraries/embryo/src/bin/embryo_cc_sc4.c b/libraries/embryo/src/bin/embryo_cc_sc4.c
new file mode 100644
index 0000000..0dedbfb
--- /dev/null
+++ b/libraries/embryo/src/bin/embryo_cc_sc4.c
@@ -0,0 +1,1308 @@
+/*  Small compiler - code generation (unoptimized "assembler" code)
+ *
+ *  Copyright (c) ITB CompuPhase, 1997-2003
+ *
+ *  This software is provided "as-is", without any express or implied warranty.
+ *  In no event will the authors be held liable for any damages arising from
+ *  the use of this software.
+ *
+ *  Permission is granted to anyone to use this software for any purpose,
+ *  including commercial applications, and to alter it and redistribute it
+ *  freely, subject to the following restrictions:
+ *
+ *  1.  The origin of this software must not be misrepresented; you must not
+ *      claim that you wrote the original software. If you use this software in
+ *      a product, an acknowledgment in the product documentation would be
+ *      appreciated but is not required.
+ *  2.  Altered source versions must be plainly marked as such, and must not be
+ *      misrepresented as being the original software.
+ *  3.  This notice may not be removed or altered from any source distribution.
+ *
+ *  Version: $Id: embryo_cc_sc4.c 52451 2010-09-19 03:00:12Z raster $
+ */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+#include <ctype.h>
+#include <stdio.h>
+#include <limits.h>             /* for PATH_MAX */
+#include <string.h>
+
+#include "embryo_cc_sc.h"
+
+/* When a subroutine returns to address 0, the AMX must halt. In earlier
+ * releases, the RET and RETN opcodes checked for the special case 0 address.
+ * Today, the compiler simply generates a HALT instruction at address 0. So
+ * a subroutine can savely return to 0, and then encounter a HALT.
+ */
+void
+writeleader(void)
+{
+   assert(code_idx == 0);
+   stgwrite(";program exit point\n");
+   stgwrite("\thalt 0\n");
+   /* calculate code length */
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/*  writetrailer
+ *  Not much left of this once important function.
+ *
+ *  Global references: sc_stksize       (referred to only)
+ *                     sc_dataalign     (referred to only)
+ *                     code_idx         (altered)
+ *                     glb_declared     (altered)
+ */
+void
+writetrailer(void)
+{
+   assert(sc_dataalign % opcodes(1) == 0);      /* alignment must be a multiple of
+                                                 * the opcode size */
+   assert(sc_dataalign != 0);
+
+   /* pad code to align data segment */
+   if ((code_idx % sc_dataalign) != 0)
+     {
+        begcseg();
+        while ((code_idx % sc_dataalign) != 0)
+           nooperation();
+     }                          /* if */
+
+   /* pad data segment to align the stack and the heap */
+   assert(litidx == 0);         /* literal queue should have been emptied */
+   assert(sc_dataalign % sizeof(cell) == 0);
+   if (((glb_declared * sizeof(cell)) % sc_dataalign) != 0)
+     {
+        begdseg();
+        defstorage();
+        while (((glb_declared * sizeof(cell)) % sc_dataalign) != 0)
+          {
+             stgwrite("0 ");
+             glb_declared++;
+          }                     /* while */
+     }                          /* if */
+
+   stgwrite("\nSTKSIZE ");      /* write stack size (align stack top) */
+   outval(sc_stksize - (sc_stksize % sc_dataalign), TRUE);
+}
+
+/*
+ *  Start (or restart) the CODE segment.
+ *
+ *  In fact, the code and data segment specifiers are purely informational;
+ *  the "DUMP" instruction itself already specifies that the following values
+ *  should go to the data segment. All otherinstructions go to the code
+ *  segment.
+ *
+ *  Global references: curseg
+ */
+void
+begcseg(void)
+{
+   if (curseg != sIN_CSEG)
+     {
+        stgwrite("\n");
+        stgwrite("CODE\t; ");
+        outval(code_idx, TRUE);
+        curseg = sIN_CSEG;
+     }                          /* endif */
+}
+
+/*
+ *  Start (or restart) the DATA segment.
+ *
+ *  Global references: curseg
+ */
+void
+begdseg(void)
+{
+   if (curseg != sIN_DSEG)
+     {
+        stgwrite("\n");
+        stgwrite("DATA\t; ");
+        outval(glb_declared - litidx, TRUE);
+        curseg = sIN_DSEG;
+     }                          /* if */
+}
+
+void
+setactivefile(int fnumber)
+{
+   stgwrite("curfile ");
+   outval(fnumber, TRUE);
+}
+
+cell
+nameincells(char *name)
+{
+   cell                clen =
+      (strlen(name) + sizeof(cell)) & ~(sizeof(cell) - 1);
+   return clen;
+}
+
+void
+setfile(char *name, int fileno)
+{
+   if ((sc_debug & sSYMBOLIC) != 0)
+     {
+        begcseg();
+        stgwrite("file ");
+        outval(fileno, FALSE);
+        stgwrite(" ");
+        stgwrite(name);
+        stgwrite("\n");
+        /* calculate code length */
+        code_idx += opcodes(1) + opargs(2) + nameincells(name);
+     }                          /* if */
+}
+
+void
+setline(int line, int fileno)
+{
+   if ((sc_debug & (sSYMBOLIC | sCHKBOUNDS)) != 0)
+     {
+        stgwrite("line ");
+        outval(line, FALSE);
+        stgwrite(" ");
+        outval(fileno, FALSE);
+        stgwrite("\t; ");
+        outval(code_idx, TRUE);
+        code_idx += opcodes(1) + opargs(2);
+     }                          /* if */
+}
+
+/*  setlabel
+ *
+ *  Post a code label (specified as a number), on a new line.
+ */
+void
+setlabel(int number)
+{
+   assert(number >= 0);
+   stgwrite("l.");
+   stgwrite((char *)itoh(number));
+   /* To assist verification of the assembled code, put the address of the
+    * label as a comment. However, labels that occur inside an expression
+    * may move (through optimization or through re-ordering). So write the
+    * address only if it is known to accurate.
+    */
+   if (!staging)
+     {
+        stgwrite("\t\t; ");
+        outval(code_idx, FALSE);
+     }                          /* if */
+   stgwrite("\n");
+}
+
+/* Write a token that signifies the end of an expression, or the end of a
+ * function parameter. This allows several simple optimizations by the peephole
+ * optimizer.
+ */
+void
+endexpr(int fullexpr)
+{
+   if (fullexpr)
+      stgwrite("\t;$exp\n");
+   else
+      stgwrite("\t;$par\n");
+}
+
+/*  startfunc   - declare a CODE entry point (function start)
+ *
+ *  Global references: funcstatus  (referred to only)
+ */
+void
+startfunc(char *fname __UNUSED__)
+{
+   stgwrite("\tproc");
+   stgwrite("\n");
+   code_idx += opcodes(1);
+}
+
+/*  endfunc
+ *
+ *  Declare a CODE ending point (function end)
+ */
+void
+endfunc(void)
+{
+   stgwrite("\n");              /* skip a line */
+}
+
+/*  alignframe
+ *
+ *  Aligns the frame (and the stack) of the current function to a multiple
+ *  of the specified byte count. Two caveats: the alignment ("numbytes") should
+ *  be a power of 2, and this alignment must be done right after the frame
+ *  is set up (before the first variable is declared)
+ */
+void
+alignframe(int numbytes)
+{
+#if !defined NDEBUG
+   /* "numbytes" should be a power of 2 for this code to work */
+   int                 i, count = 0;
+
+   for (i = 0; i < (int)(sizeof(numbytes) * 8); i++)
+      if (numbytes & (1 << i))
+         count++;
+   assert(count == 1);
+#endif
+
+   stgwrite("\tlctrl 4\n");     /* get STK in PRI */
+   stgwrite("\tconst.alt ");    /* get ~(numbytes-1) in ALT */
+   outval(~(numbytes - 1), TRUE);
+   stgwrite("\tand\n");         /* PRI = STK "and" ~(numbytes-1) */
+   stgwrite("\tsctrl 4\n");     /* set the new value of STK ... */
+   stgwrite("\tsctrl 5\n");     /* ... and FRM */
+   code_idx += opcodes(5) + opargs(4);
+}
+
+/*  Define a variable or function
+ */
+void
+defsymbol(char *name, int ident, int vclass, cell offset, int tag)
+{
+   if ((sc_debug & sSYMBOLIC) != 0)
+     {
+        begcseg();              /* symbol definition in code segment */
+        stgwrite("symbol ");
+
+        stgwrite(name);
+        stgwrite(" ");
+
+        outval(offset, FALSE);
+        stgwrite(" ");
+
+        outval(vclass, FALSE);
+        stgwrite(" ");
+
+        outval(ident, TRUE);
+
+        code_idx += opcodes(1) + opargs(3) + nameincells(name); /* class and ident encoded in "flags" */
+
+        /* also write the optional tag */
+        if (tag != 0)
+          {
+             assert((tag & TAGMASK) != 0);
+             stgwrite("symtag ");
+             outval(tag & TAGMASK, TRUE);
+             code_idx += opcodes(1) + opargs(1);
+          }                     /* if */
+     }                          /* if */
+}
+
+void
+symbolrange(int level, cell size)
+{
+   if ((sc_debug & sSYMBOLIC) != 0)
+     {
+        begcseg();              /* symbol definition in code segment */
+        stgwrite("srange ");
+        outval(level, FALSE);
+        stgwrite(" ");
+        outval(size, TRUE);
+        code_idx += opcodes(1) + opargs(2);
+     }                          /* if */
+}
+
+/*  rvalue
+ *
+ *  Generate code to get the value of a symbol into "primary".
+ */
+void
+rvalue(value * lval)
+{
+   symbol             *sym;
+
+   sym = lval->sym;
+   if (lval->ident == iARRAYCELL)
+     {
+        /* indirect fetch, address already in PRI */
+        stgwrite("\tload.i\n");
+        code_idx += opcodes(1);
+     }
+   else if (lval->ident == iARRAYCHAR)
+     {
+        /* indirect fetch of a character from a pack, address already in PRI */
+        stgwrite("\tlodb.i ");
+        outval(charbits / 8, TRUE);     /* read one or two bytes */
+        code_idx += opcodes(1) + opargs(1);
+     }
+   else if (lval->ident == iREFERENCE)
+     {
+        /* indirect fetch, but address not yet in PRI */
+        assert(sym != NULL);
+        assert(sym->vclass == sLOCAL);  /* global references don't exist in Small */
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tlref.s.pri ");
+        else
+           stgwrite("\tlref.pri ");
+        outval(sym->addr, TRUE);
+        markusage(sym, uREAD);
+        code_idx += opcodes(1) + opargs(1);
+     }
+   else
+     {
+        /* direct or stack relative fetch */
+        assert(sym != NULL);
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tload.s.pri ");
+        else
+           stgwrite("\tload.pri ");
+        outval(sym->addr, TRUE);
+        markusage(sym, uREAD);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/*
+ *  Get the address of a symbol into the primary register (used for arrays,
+ *  and for passing arguments by reference).
+ */
+void
+address(symbol * sym)
+{
+   assert(sym != NULL);
+   /* the symbol can be a local array, a global array, or an array
+    * that is passed by reference.
+    */
+   if (sym->ident == iREFARRAY || sym->ident == iREFERENCE)
+     {
+        /* reference to a variable or to an array; currently this is
+         * always a local variable */
+        stgwrite("\tload.s.pri ");
+     }
+   else
+     {
+        /* a local array or local variable */
+        if (sym->vclass == sLOCAL)
+           stgwrite("\taddr.pri ");
+        else
+           stgwrite("\tconst.pri ");
+     }                          /* if */
+   outval(sym->addr, TRUE);
+   markusage(sym, uREAD);
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/*  store
+ *
+ *  Saves the contents of "primary" into a memory cell, either directly
+ *  or indirectly (at the address given in the alternate register).
+ */
+void
+store(value * lval)
+{
+   symbol             *sym;
+
+   sym = lval->sym;
+   if (lval->ident == iARRAYCELL)
+     {
+        /* store at address in ALT */
+        stgwrite("\tstor.i\n");
+        code_idx += opcodes(1);
+     }
+   else if (lval->ident == iARRAYCHAR)
+     {
+        /* store at address in ALT */
+        stgwrite("\tstrb.i ");
+        outval(charbits / 8, TRUE);     /* write one or two bytes */
+        code_idx += opcodes(1) + opargs(1);
+     }
+   else if (lval->ident == iREFERENCE)
+     {
+        assert(sym != NULL);
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tsref.s.pri ");
+        else
+           stgwrite("\tsref.pri ");
+        outval(sym->addr, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }
+   else
+     {
+        assert(sym != NULL);
+        markusage(sym, uWRITTEN);
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tstor.s.pri ");
+        else
+           stgwrite("\tstor.pri ");
+        outval(sym->addr, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/* source must in PRI, destination address in ALT. The "size"
+ * parameter is in bytes, not cells.
+ */
+void
+memcopy(cell size)
+{
+   stgwrite("\tmovs ");
+   outval(size, TRUE);
+
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/* Address of the source must already have been loaded in PRI
+ * "size" is the size in bytes (not cells).
+ */
+void
+copyarray(symbol * sym, cell size)
+{
+   assert(sym != NULL);
+   /* the symbol can be a local array, a global array, or an array
+    * that is passed by reference.
+    */
+   if (sym->ident == iREFARRAY)
+     {
+        /* reference to an array; currently this is always a local variable */
+        assert(sym->vclass == sLOCAL);  /* symbol must be stack relative */
+        stgwrite("\tload.s.alt ");
+     }
+   else
+     {
+        /* a local or global array */
+        if (sym->vclass == sLOCAL)
+           stgwrite("\taddr.alt ");
+        else
+           stgwrite("\tconst.alt ");
+     }                          /* if */
+   outval(sym->addr, TRUE);
+   markusage(sym, uWRITTEN);
+
+   code_idx += opcodes(1) + opargs(1);
+   memcopy(size);
+}
+
+void
+fillarray(symbol * sym, cell size, cell val)
+{
+   const1(val);         /* load val in PRI */
+
+   assert(sym != NULL);
+   /* the symbol can be a local array, a global array, or an array
+    * that is passed by reference.
+    */
+   if (sym->ident == iREFARRAY)
+     {
+        /* reference to an array; currently this is always a local variable */
+        assert(sym->vclass == sLOCAL);  /* symbol must be stack relative */
+        stgwrite("\tload.s.alt ");
+     }
+   else
+     {
+        /* a local or global array */
+        if (sym->vclass == sLOCAL)
+           stgwrite("\taddr.alt ");
+        else
+           stgwrite("\tconst.alt ");
+     }                          /* if */
+   outval(sym->addr, TRUE);
+   markusage(sym, uWRITTEN);
+
+   stgwrite("\tfill ");
+   outval(size, TRUE);
+
+   code_idx += opcodes(2) + opargs(2);
+}
+
+/*
+ *  Instruction to get an immediate value into the primary register
+ */
+void
+const1(cell val)
+{
+   if (val == 0)
+     {
+        stgwrite("\tzero.pri\n");
+        code_idx += opcodes(1);
+     }
+   else
+     {
+        stgwrite("\tconst.pri ");
+        outval(val, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/*
+ *  Instruction to get an immediate value into the secondary register
+ */
+void
+const2(cell val)
+{
+   if (val == 0)
+     {
+        stgwrite("\tzero.alt\n");
+        code_idx += opcodes(1);
+     }
+   else
+     {
+        stgwrite("\tconst.alt ");
+        outval(val, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/* Copy value in secondary register to the primary register */
+void
+moveto1(void)
+{
+   stgwrite("\tmove.pri\n");
+   code_idx += opcodes(1) + opargs(0);
+}
+
+/*
+ *  Push primary register onto the stack
+ */
+void
+push1(void)
+{
+   stgwrite("\tpush.pri\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  Push alternate register onto the stack
+ */
+void
+push2(void)
+{
+   stgwrite("\tpush.alt\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  Push a constant value onto the stack
+ */
+void
+pushval(cell val)
+{
+   stgwrite("\tpush.c ");
+   outval(val, TRUE);
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/*
+ *  pop stack to the primary register
+ */
+void
+pop1(void)
+{
+   stgwrite("\tpop.pri\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  pop stack to the secondary register
+ */
+void
+pop2(void)
+{
+   stgwrite("\tpop.alt\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  swap the top-of-stack with the value in primary register
+ */
+void
+swap1(void)
+{
+   stgwrite("\tswap.pri\n");
+   code_idx += opcodes(1);
+}
+
+/* Switch statements
+ * The "switch" statement generates a "case" table using the "CASE" opcode.
+ * The case table contains a list of records, each record holds a comparison
+ * value and a label to branch to on a match. The very first record is an
+ * exception: it holds the size of the table (excluding the first record) and
+ * the label to branch to when none of the values in the case table match.
+ * The case table is sorted on the comparison value. This allows more advanced
+ * abstract machines to sift the case table with a binary search.
+ */
+void
+ffswitch(int label)
+{
+   stgwrite("\tswitch ");
+   outval(label, TRUE);         /* the label is the address of the case table */
+   code_idx += opcodes(1) + opargs(1);
+}
+
+void
+ffcase(cell val, char *labelname, int newtable)
+{
+   if (newtable)
+     {
+        stgwrite("\tcasetbl\n");
+        code_idx += opcodes(1);
+     }                          /* if */
+   stgwrite("\tcase ");
+   outval(val, FALSE);
+   stgwrite(" ");
+   stgwrite(labelname);
+   stgwrite("\n");
+   code_idx += opcodes(0) + opargs(2);
+}
+
+/*
+ *  Call specified function
+ */
+void
+ffcall(symbol * sym, int numargs)
+{
+   assert(sym != NULL);
+   assert(sym->ident == iFUNCTN);
+   if ((sym->usage & uNATIVE) != 0)
+     {
+        /* reserve a SYSREQ id if called for the first time */
+        if (sc_status == statWRITE && (sym->usage & uREAD) == 0
+            && sym->addr >= 0)
+           sym->addr = ntv_funcid++;
+        stgwrite("\tsysreq.c ");
+        outval(sym->addr, FALSE);
+        stgwrite("\n\tstack ");
+        outval((numargs + 1) * sizeof(cell), TRUE);
+        code_idx += opcodes(2) + opargs(2);
+     }
+   else
+     {
+        /* normal function */
+        stgwrite("\tcall ");
+        stgwrite(sym->name);
+        stgwrite("\n");
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/*  Return from function
+ *
+ *  Global references: funcstatus  (referred to only)
+ */
+void
+ffret(void)
+{
+   stgwrite("\tretn\n");
+   code_idx += opcodes(1);
+}
+
+void
+ffabort(int reason)
+{
+   stgwrite("\thalt ");
+   outval(reason, TRUE);
+   code_idx += opcodes(1) + opargs(1);
+}
+
+void
+ffbounds(cell size)
+{
+   if ((sc_debug & sCHKBOUNDS) != 0)
+     {
+        stgwrite("\tbounds ");
+        outval(size, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/*
+ *  Jump to local label number (the number is converted to a name)
+ */
+void
+jumplabel(int number)
+{
+   stgwrite("\tjump ");
+   outval(number, TRUE);
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/*
+ *   Define storage (global and static variables)
+ */
+void
+defstorage(void)
+{
+   stgwrite("dump ");
+}
+
+/*
+ *  Inclrement/decrement stack pointer. Note that this routine does
+ *  nothing if the delta is zero.
+ */
+void
+modstk(int delta)
+{
+   if (delta)
+     {
+        stgwrite("\tstack ");
+        outval(delta, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/* set the stack to a hard offset from the frame */
+void
+setstk(cell val)
+{
+   stgwrite("\tlctrl 5\n");     /* get FRM */
+   assert(val <= 0);            /* STK should always become <= FRM */
+   if (val < 0)
+     {
+        stgwrite("\tadd.c ");
+        outval(val, TRUE);      /* add (negative) offset */
+        code_idx += opcodes(1) + opargs(1);
+        // ??? write zeros in the space between STK and the val in PRI (the new stk)
+        //     get val of STK in ALT
+        //     zero PRI
+        //     need new FILL opcode that takes a variable size
+     }                          /* if */
+   stgwrite("\tsctrl 4\n");     /* store in STK */
+   code_idx += opcodes(2) + opargs(2);
+}
+
+void
+modheap(int delta)
+{
+   if (delta)
+     {
+        stgwrite("\theap ");
+        outval(delta, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+void
+setheap_pri(void)
+{
+   stgwrite("\theap ");         /* ALT = HEA++ */
+   outval(sizeof(cell), TRUE);
+   stgwrite("\tstor.i\n");      /* store PRI (default value) at address ALT */
+   stgwrite("\tmove.pri\n");    /* move ALT to PRI: PRI contains the address */
+   code_idx += opcodes(3) + opargs(1);
+}
+
+void
+setheap(cell val)
+{
+   stgwrite("\tconst.pri ");    /* load default val in PRI */
+   outval(val, TRUE);
+   code_idx += opcodes(1) + opargs(1);
+   setheap_pri();
+}
+
+/*
+ *  Convert a cell number to a "byte" address; i.e. double or quadruple
+ *  the primary register.
+ */
+void
+cell2addr(void)
+{
+#if defined(BIT16)
+   stgwrite("\tshl.c.pri 1\n");
+#else
+   stgwrite("\tshl.c.pri 2\n");
+#endif
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/*
+ *  Double or quadruple the alternate register.
+ */
+void
+cell2addr_alt(void)
+{
+#if defined(BIT16)
+   stgwrite("\tshl.c.alt 1\n");
+#else
+   stgwrite("\tshl.c.alt 2\n");
+#endif
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/*
+ *  Convert "distance of addresses" to "number of cells" in between.
+ *  Or convert a number of packed characters to the number of cells (with
+ *  truncation).
+ */
+void
+addr2cell(void)
+{
+#if defined(BIT16)
+   stgwrite("\tshr.c.pri 1\n");
+#else
+   stgwrite("\tshr.c.pri 2\n");
+#endif
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/* Convert from character index to byte address. This routine does
+ * nothing if a character has the size of a byte.
+ */
+void
+char2addr(void)
+{
+   if (charbits == 16)
+     {
+        stgwrite("\tshl.c.pri 1\n");
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/* Align PRI (which should hold a character index) to an address.
+ * The first character in a "pack" occupies the highest bits of
+ * the cell. This is at the lower memory address on Big Endian
+ * computers and on the higher address on Little Endian computers.
+ * The ALIGN.pri/alt instructions must solve this machine dependence;
+ * that is, on Big Endian computers, ALIGN.pri/alt shuold do nothing
+ * and on Little Endian computers they should toggle the address.
+ */
+void
+charalign(void)
+{
+   stgwrite("\talign.pri ");
+   outval(charbits / 8, TRUE);
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/*
+ *  Add a constant to the primary register.
+ */
+void
+addconst(cell val)
+{
+   if (val != 0)
+     {
+        stgwrite("\tadd.c ");
+        outval(val, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/*
+ *  signed multiply of primary and secundairy registers (result in primary)
+ */
+void
+os_mult(void)
+{
+   stgwrite("\tsmul\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  signed divide of alternate register by primary register (quotient in
+ *  primary; remainder in alternate)
+ */
+void
+os_div(void)
+{
+   stgwrite("\tsdiv.alt\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  modulus of (alternate % primary), result in primary (signed)
+ */
+void
+os_mod(void)
+{
+   stgwrite("\tsdiv.alt\n");
+   stgwrite("\tmove.pri\n");    /* move ALT to PRI */
+   code_idx += opcodes(2);
+}
+
+/*
+ *  Add primary and alternate registers (result in primary).
+ */
+void
+ob_add(void)
+{
+   stgwrite("\tadd\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  subtract primary register from alternate register (result in primary)
+ */
+void
+ob_sub(void)
+{
+   stgwrite("\tsub.alt\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  arithmic shift left alternate register the number of bits
+ *  given in the primary register (result in primary).
+ *  There is no need for a "logical shift left" routine, since
+ *  logical shift left is identical to arithmic shift left.
+ */
+void
+ob_sal(void)
+{
+   stgwrite("\txchg\n");
+   stgwrite("\tshl\n");
+   code_idx += opcodes(2);
+}
+
+/*
+ *  arithmic shift right alternate register the number of bits
+ *  given in the primary register (result in primary).
+ */
+void
+os_sar(void)
+{
+   stgwrite("\txchg\n");
+   stgwrite("\tsshr\n");
+   code_idx += opcodes(2);
+}
+
+/*
+ *  logical (unsigned) shift right of the alternate register by the
+ *  number of bits given in the primary register (result in primary).
+ */
+void
+ou_sar(void)
+{
+   stgwrite("\txchg\n");
+   stgwrite("\tshr\n");
+   code_idx += opcodes(2);
+}
+
+/*
+ *  inclusive "or" of primary and secondary registers (result in primary)
+ */
+void
+ob_or(void)
+{
+   stgwrite("\tor\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  "exclusive or" of primary and alternate registers (result in primary)
+ */
+void
+ob_xor(void)
+{
+   stgwrite("\txor\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  "and" of primary and secundairy registers (result in primary)
+ */
+void
+ob_and(void)
+{
+   stgwrite("\tand\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  test ALT==PRI; result in primary register (1 or 0).
+ */
+void
+ob_eq(void)
+{
+   stgwrite("\teq\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  test ALT!=PRI
+ */
+void
+ob_ne(void)
+{
+   stgwrite("\tneq\n");
+   code_idx += opcodes(1);
+}
+
+/* The abstract machine defines the relational instructions so that PRI is
+ * on the left side and ALT on the right side of the operator. For example,
+ * SLESS sets PRI to either 1 or 0 depending on whether the expression
+ * "PRI < ALT" is true.
+ *
+ * The compiler generates comparisons with ALT on the left side of the
+ * relational operator and PRI on the right side. The XCHG instruction
+ * prefixing the relational operators resets this. We leave it to the
+ * peephole optimizer to choose more compact instructions where possible.
+ */
+
+/* Relational operator prefix for chained relational expressions. The
+ * "suffix" code restores the stack.
+ * For chained relational operators, the goal is to keep the comparison
+ * result "so far" in PRI and the value of the most recent operand in
+ * ALT, ready for a next comparison.
+ * The "prefix" instruction pushed the comparison result (PRI) onto the
+ * stack and moves the value of ALT into PRI. If there is a next comparison,
+ * PRI can now serve as the "left" operand of the relational operator.
+ */
+void
+relop_prefix(void)
+{
+   stgwrite("\tpush.pri\n");
+   stgwrite("\tmove.pri\n");
+   code_idx += opcodes(2);
+}
+
+void
+relop_suffix(void)
+{
+   stgwrite("\tswap.alt\n");
+   stgwrite("\tand\n");
+   stgwrite("\tpop.alt\n");
+   code_idx += opcodes(3);
+}
+
+/*
+ *  test ALT<PRI (signed)
+ */
+void
+os_lt(void)
+{
+   stgwrite("\txchg\n");
+   stgwrite("\tsless\n");
+   code_idx += opcodes(2);
+}
+
+/*
+ *  test ALT<=PRI (signed)
+ */
+void
+os_le(void)
+{
+   stgwrite("\txchg\n");
+   stgwrite("\tsleq\n");
+   code_idx += opcodes(2);
+}
+
+/*
+ *  test ALT>PRI (signed)
+ */
+void
+os_gt(void)
+{
+   stgwrite("\txchg\n");
+   stgwrite("\tsgrtr\n");
+   code_idx += opcodes(2);
+}
+
+/*
+ *  test ALT>=PRI (signed)
+ */
+void
+os_ge(void)
+{
+   stgwrite("\txchg\n");
+   stgwrite("\tsgeq\n");
+   code_idx += opcodes(2);
+}
+
+/*
+ *  logical negation of primary register
+ */
+void
+lneg(void)
+{
+   stgwrite("\tnot\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  two's complement primary register
+ */
+void
+neg(void)
+{
+   stgwrite("\tneg\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  one's complement of primary register
+ */
+void
+invert(void)
+{
+   stgwrite("\tinvert\n");
+   code_idx += opcodes(1);
+}
+
+/*
+ *  nop
+ */
+void
+nooperation(void)
+{
+   stgwrite("\tnop\n");
+   code_idx += opcodes(1);
+}
+
+/*  increment symbol
+ */
+void
+inc(value * lval)
+{
+   symbol             *sym;
+
+   sym = lval->sym;
+   if (lval->ident == iARRAYCELL)
+     {
+        /* indirect increment, address already in PRI */
+        stgwrite("\tinc.i\n");
+        code_idx += opcodes(1);
+     }
+   else if (lval->ident == iARRAYCHAR)
+     {
+        /* indirect increment of single character, address already in PRI */
+        stgwrite("\tpush.pri\n");
+        stgwrite("\tpush.alt\n");
+        stgwrite("\tmove.alt\n");       /* copy address */
+        stgwrite("\tlodb.i ");  /* read from PRI into PRI */
+        outval(charbits / 8, TRUE);     /* read one or two bytes */
+        stgwrite("\tinc.pri\n");
+        stgwrite("\tstrb.i ");  /* write PRI to ALT */
+        outval(charbits / 8, TRUE);     /* write one or two bytes */
+        stgwrite("\tpop.alt\n");
+        stgwrite("\tpop.pri\n");
+        code_idx += opcodes(8) + opargs(2);
+     }
+   else if (lval->ident == iREFERENCE)
+     {
+        assert(sym != NULL);
+        stgwrite("\tpush.pri\n");
+        /* load dereferenced value */
+        assert(sym->vclass == sLOCAL);  /* global references don't exist in Small */
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tlref.s.pri ");
+        else
+           stgwrite("\tlref.pri ");
+        outval(sym->addr, TRUE);
+        /* increment */
+        stgwrite("\tinc.pri\n");
+        /* store dereferenced value */
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tsref.s.pri ");
+        else
+           stgwrite("\tsref.pri ");
+        outval(sym->addr, TRUE);
+        stgwrite("\tpop.pri\n");
+        code_idx += opcodes(5) + opargs(2);
+     }
+   else
+     {
+        /* local or global variable */
+        assert(sym != NULL);
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tinc.s ");
+        else
+           stgwrite("\tinc ");
+        outval(sym->addr, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/*  decrement symbol
+ *
+ *  in case of an integer pointer, the symbol must be incremented by 2.
+ */
+void
+dec(value * lval)
+{
+   symbol             *sym;
+
+   sym = lval->sym;
+   if (lval->ident == iARRAYCELL)
+     {
+        /* indirect decrement, address already in PRI */
+        stgwrite("\tdec.i\n");
+        code_idx += opcodes(1);
+     }
+   else if (lval->ident == iARRAYCHAR)
+     {
+        /* indirect decrement of single character, address already in PRI */
+        stgwrite("\tpush.pri\n");
+        stgwrite("\tpush.alt\n");
+        stgwrite("\tmove.alt\n");       /* copy address */
+        stgwrite("\tlodb.i ");  /* read from PRI into PRI */
+        outval(charbits / 8, TRUE);     /* read one or two bytes */
+        stgwrite("\tdec.pri\n");
+        stgwrite("\tstrb.i ");  /* write PRI to ALT */
+        outval(charbits / 8, TRUE);     /* write one or two bytes */
+        stgwrite("\tpop.alt\n");
+        stgwrite("\tpop.pri\n");
+        code_idx += opcodes(8) + opargs(2);
+     }
+   else if (lval->ident == iREFERENCE)
+     {
+        assert(sym != NULL);
+        stgwrite("\tpush.pri\n");
+        /* load dereferenced value */
+        assert(sym->vclass == sLOCAL);  /* global references don't exist in Small */
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tlref.s.pri ");
+        else
+           stgwrite("\tlref.pri ");
+        outval(sym->addr, TRUE);
+        /* decrement */
+        stgwrite("\tdec.pri\n");
+        /* store dereferenced value */
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tsref.s.pri ");
+        else
+           stgwrite("\tsref.pri ");
+        outval(sym->addr, TRUE);
+        stgwrite("\tpop.pri\n");
+        code_idx += opcodes(5) + opargs(2);
+     }
+   else
+     {
+        /* local or global variable */
+        assert(sym != NULL);
+        if (sym->vclass == sLOCAL)
+           stgwrite("\tdec.s ");
+        else
+           stgwrite("\tdec ");
+        outval(sym->addr, TRUE);
+        code_idx += opcodes(1) + opargs(1);
+     }                          /* if */
+}
+
+/*
+ *  Jumps to "label" if PRI != 0
+ */
+void
+jmp_ne0(int number)
+{
+   stgwrite("\tjnz ");
+   outval(number, TRUE);
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/*
+ *  Jumps to "label" if PRI == 0
+ */
+void
+jmp_eq0(int number)
+{
+   stgwrite("\tjzer ");
+   outval(number, TRUE);
+   code_idx += opcodes(1) + opargs(1);
+}
+
+/* write a value in hexadecimal; optionally adds a newline */
+void
+outval(cell val, int newline)
+{
+   stgwrite(itoh(val));
+   if (newline)
+      stgwrite("\n");
+}