diff keiko/keiko.iset @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/keiko.iset	Thu Oct 05 08:04:15 2017 +0100
@@ -0,0 +1,715 @@
+#
+# keiko.iset
+# 
+# This file is part of the Oxford Oberon-2 compiler
+# Copyright (c) 2006--2016 J. M. Spivey
+# All rights reserved
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are met:
+#
+# 1. Redistributions of source code must retain the above copyright notice,
+#    this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright notice,
+#    this list of conditions and the following disclaimer in the documentation
+#    and/or other materials provided with the distribution.
+# 3. The name of the author may not be used to endorse or promote products
+#    derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+# OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+# ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+#
+
+defs {
+#define local(n)        ((uchar *) bp + (n))
+#define parent(a, t)    indir(pointer(bp[SL]) + a, t)
+#define indir(p, t)     (* (t *) (p))
+#define subs(p, n, t)   ((t *) (p))[n]
+#define const(n)        cp[CP_CONST+n]
+#define jump(lab)       pc = pc0 + lab
+}
+
+
+# CONSTANTS
+
+inst PUSH {[-1,6,1] 1 2} V.i {$a}
+inst LDKW {1 2}         V.i {const($a).i}
+inst LDKF {1 2}         V.f {const($a).f}
+
+
+# ADDRESSING OPERATORS
+
+# Push address of local
+# LOCAL n :: --> bp+n
+inst LOCAL {1 2}        V.x {local($a)}
+
+# Compute indexed address
+# INDEXs :: a, b --> a + s * b
+inst OFFSET 0           B.x {pointer($1) + $2.i}
+inst INDEXS 0           B.x {pointer($1) + ($2.i<<1)}
+inst INDEXW 0           B.x {pointer($1) + ($2.i<<2)}
+inst INDEXD 0           B.x {pointer($1) + ($2.i<<3)}
+
+
+# LOADS AND STORES
+
+# Load/store from address
+# LOADs :: a --> mem_s[a]
+# STOREs :: a, b --> []; mem_s[b] := a
+inst LOADW 0            M.i {indir(pointer($1), int)}
+inst LOADS 0            M.i {indir(pointer($1), short)}
+inst LOADC 0            M.i {indir(pointer($1), uchar)}
+inst LOADF 0            M.f {indir(pointer($1), float)}
+inst STOREW 0           S2  {indir(pointer($2), int) = $1.i;}
+inst STORES 0           S2  {indir(pointer($2), short) = $1.i;}
+inst STOREC 0           S2  {indir(pointer($2), uchar) = $1.i;}
+inst STOREF 0           S2  {indir(pointer($2), float) = $1.f;}
+
+# Load/store local
+# LDLs n :: --> mem_s[bp+n]
+# STLs n :: a --> []; mem_s[bp+n] := a
+inst LDLW {[-24,-4,4] [12,32,4] 1 2} \
+                        V.i {indir(local($a), int)}
+inst LDLS {1 2}         V.i {indir(local($a), short)}
+inst LDLC {1 2}         V.i {indir(local($a), uchar)}
+inst LDLF {1 2}         V.f {indir(local($a), float)}
+inst STLW {[-24,-4,4] [12,32,4] 1 2} \
+                        S1  {indir(local($a), int) = $1.i;}
+inst STLS {1 2}         S1  {indir(local($a), short) = $1.i;}
+inst STLC {1 2}         S1  {indir(local($a), uchar) = $1.i;}
+inst STLF {1 2}         S1  {indir(local($a), float) = $1.f;}
+
+# Load/store global
+# LDGs n :: --> mem_s[const(n)]
+# STGs n :: a --> []; mem_s[const(n)] := a
+inst LDGW {K L}         V.i {indir(pointer(const($a)), int)}
+inst LDGS {K L}         V.i {indir(pointer(const($a)), short)}
+inst LDGC {K L}         V.i {indir(pointer(const($a)), uchar)}
+inst LDGF {K L}         V.f {indir(pointer(const($a)), float)}
+inst STGW {K L}         S1  {indir(pointer(const($a)), int) = $1.i;}
+inst STGS {K L}         S1  {indir(pointer(const($a)), short) = $1.i;}
+inst STGC {K L}         S1  {indir(pointer(const($a)), uchar) = $1.i;}
+inst STGF {K L}         S1  {indir(pointer(const($a)), float) = $1.f;}
+
+# Indexed load/store
+# LDNs n :: a -> mem_s[a+n]
+# STNs n :: a, b -> []; mem_s[b+n] := a
+inst LDNW {[-16,40,4] 1 2} M.i {indir(pointer($1) + $a, int)}
+inst STNW {[-16,20,4] 1 2} S2  {indir(pointer($2) + $a, int) = $1.i;}
+
+# Double indexed load/store
+# LDIs :: a, b --> mem_s[a+s*b]
+# STIs :: a, b, c --> []; mem_s[b+s*c] := a
+inst LDIW 0             B.i {subs(pointer($1), $2.i, int)}
+inst LDIF 0             B.f {subs(pointer($1), $2.i, float)}
+inst LDIS 0             B.i {subs(pointer($1), $2.i, short)}
+inst LDIC 0             B.i {subs(pointer($1), $2.i, uchar)}
+inst STIW 0             S3  {subs(pointer($2), $3.i, int) = $1.i;}
+inst STIF 0             S3  {subs(pointer($2), $3.i, float) = $1.f;}
+inst STIS 0             S3  {subs(pointer($2), $3.i, short) = $1.i;}
+inst STIC 0             S3  {subs(pointer($2), $3.i, uchar) = $1.i;}
+
+inst LDID 0             B.dpi \
+    {getdbl((value *) &subs(pointer($1), $2.i, double))}
+inst STID 0             S3dpi \
+    {putdbl((value *) &subs(pointer($2), $3.i, double), $1.d);}
+
+inst LDIQ 0             B.qpi \
+    {getlong((value *) &subs(pointer($1), $2.i, longint))}
+inst STIQ 0             S3qpi \
+    {putlong((value *) &subs(pointer($2), $3.i, longint), $1.q);}
+
+# If the argument of any of the above instructions is so large that it
+# does not fit in two bytes, then it's the job of the compiler to find
+# an equivalent sequence using LDKW that achieves the same effect:
+# for example, LDLW n --> LDKW [n] / LOADW
+
+# Loads and stores for doubles
+inst LOADD 0            M.dp  {getdbl(valptr($1))}
+inst STORED 0           S2dp  {putdbl(valptr($2), $1.d);}
+inst LDKD {1 2}         V.d   {getdbl(&const($a))}
+
+inst LOADQ 0            M.qp  {getlong(valptr($1))}
+inst STOREQ 0           S2qp  {putlong(valptr($2), $1.q);}
+inst LDKQ {1 2}         V.q   {getlong(&const($a))}
+
+equiv LDLD 1            {LOCAL $a, LOADD}
+equiv STLD 1            {LOCAL $a, STORED}
+equiv LDGD K            {LDKW $a, LOADD}
+equiv STGD K            {LDKW $a, STORED}
+
+equiv LDLQ 1            {LOCAL $a, LOADQ}
+equiv STLQ 1            {LOCAL $a, STOREQ}
+equiv LDGQ K            {LDKW $a, LOADQ}
+equiv STGQ K            {LDKW $a, STOREQ}
+
+# ASSORTED INSTRUCTIONS
+
+defs {
+#define dup(n, sp)      sp--; sp[0] = sp[n+1]
+#define swap(sp)        sp[-1] = sp[1]; sp[1] = sp[0]; sp[0] = sp[-1]
+}
+inst INCL 1             S0 {indir(local($a), int)++;}
+inst DECL 1             S0 {indir(local($a), int)--;}
+inst DUP {[0,2,1]}      S0 {dup($a, $s);}
+inst SWAP 0             S0 {swap($s);}
+inst POP 1              S0 {sp += $a;}
+
+equiv INCL 2            {LDLW $a, INC, STLW $a}
+equiv DECL 2            {LDLW $a, DEC, STLW $a}
+
+
+# INTEGER OPERATORS
+
+defs {
+#define ror(a, b) ((((unsigned) a) >> b) | (((unsigned) a) << (32-b)))
+}
+inst PLUS 0             B.i {$1.i + $2.i}
+inst MINUS 0            B.i {$1.i - $2.i}
+inst TIMES 0            B.i {$1.i * $2.i}
+inst UMINUS 0           M.i {- $1.i}
+inst AND 0              B.i {$1.i && $2.i}
+inst OR 0               B.i {$1.i || $2.i}
+inst NOT 0              M.i {! $1.i}
+inst INC 0              M.i {$1.i + 1}
+inst DEC 0              M.i {$1.i - 1}
+inst BITAND 0           B.i {$1.i & $2.i}
+inst BITOR 0            B.i {$1.i | $2.i}
+inst BITXOR 0           B.i {$1.i ^ $2.i}
+inst BITNOT 0           M.i {~ $1.i}
+inst LSL 0              B.i {$1.i << $2.i}
+inst LSR 0              B.i {((unsigned) $1.i) >> $2.i}
+inst ASR 0              B.i {$1.i >> $2.i}
+inst ROR 0              B.i {ror($1.i, $2.i)}
+
+defs {
+/* The DIV and MOD instructions must give the correct results, even if 
+   C is wrong.  Correct means that b * (a DIV b) + a MOD b = a, and 
+   (-a) DIV (-b) = a DIV b, and if b > 0 then 0 <= a MOD b < b. */
+
+static inline divop_decl(int)
+static inline divop_decl(longint)
+}
+
+inst DIV 0              B.i {int_divop($1.i, $2.i, 1)}
+inst MOD 0              B.i {int_divop($1.i, $2.i, 0)}
+
+inst EQ 0               B.i {$1.i == $2.i}
+inst LT 0               B.i {$1.i < $2.i}
+inst GT 0               B.i {$1.i > $2.i}
+inst LEQ 0              B.i {$1.i <= $2.i}
+inst GEQ 0              B.i {$1.i >= $2.i}
+inst NEQ 0              B.i {$1.i != $2.i}
+
+inst JEQ {S R}          S2 {if ($1.i == $2.i) jump($a);}
+inst JLT {S R}          S2 {if ($1.i < $2.i) jump($a);}
+inst JGT {S R}          S2 {if ($1.i > $2.i) jump($a);}
+inst JLEQ {S R}         S2 {if ($1.i <= $2.i) jump($a);}
+inst JGEQ {S R}         S2 {if ($1.i >= $2.i) jump($a);}
+inst JNEQ {S R}         S2 {if ($1.i != $2.i) jump($a);}
+
+inst JLTZ S             S1 {if ($1.i < 0) jump($a);}
+inst JGTZ S             S1 {if ($1.i > 0) jump($a);}
+inst JLEQZ S            S1 {if ($1.i <= 0) jump($a);}
+inst JGEQZ S            S1 {if ($1.i >= 0) jump($a);}
+
+equiv JLTZ R            {PUSH 0, JLT $a}
+equiv JGTZ R            {PUSH 0, JGT $a}
+equiv JLEQZ R           {PUSH 0, JLEQ $a}
+equiv JGEQZ R           {PUSH 0, JGEQ $a}
+
+inst JNEQZ {S R}        S1 {if ($1.i != 0) jump($a);}
+inst JEQZ {S R}         S1 {if ($1.i == 0) jump($a);}
+inst JUMP {S R}         S0 {jump($a);}
+
+# LONGINT OPERATORS
+
+inst QPLUS 0            B.q {$1.q + $2.q}
+inst QMINUS 0           B.q {$1.q - $2.q}
+inst QTIMES 0           B.q {$1.q * $2.q}
+inst QUMINUS 0          M.q {- $1.q}
+inst QDIV 0             B.q {longint_divop($1.q, $2.q, 1)}
+inst QMOD 0             B.q {longint_divop($1.q, $2.q, 0)}
+
+equiv QINC 0            {PUSH 1, CONVNQ, QPLUS}
+equiv QDEC 0            {PUSH 1, CONVNQ, QMINUS}
+
+
+# CASE STATEMENTS
+
+defs {
+#define jcase(x, n) \
+     if ((unsigned) x < (unsigned) n) { pc0 = pc + 2*x; jump(get2(pc0)); } \
+     else pc += 2*n
+}
+inst JCASE 1            S1  {jcase($1.i, $a);}
+zinst CASEL R
+
+inst JRANGE {S R}       S3  {if ($1.i >= $2.i && $1.i <= $3.i) jump($a);}
+
+# The "T2" means take two arguments, but leave one of them on the stack
+inst TESTGEQ {S R}      T2  {if ($1.i >= $2.i) jump($a);}
+
+
+# FLOATING-POINT OPERATORS
+
+inst FPLUS 0            B.f {$1.f + $2.f}
+inst FMINUS 0           B.f {$1.f - $2.f}
+inst FTIMES 0           B.f {$1.f * $2.f}
+inst FDIV 0             B.f {$1.f / $2.f}
+inst FUMINUS 0          M.f {- $1.f}
+
+defs {
+static inline int fcmpl(double a, double b) {
+     return (a > b ? 1 : a == b ? 0 : -1);
+}
+
+static inline int fcmpg(double a, double b) {
+     return (a < b ? -1 : a == b ? 0 : 1);
+}
+
+static inline int lcmp(longint a, longint b) {
+     return (a < b ? -1 : a > b ? 1 : 0);
+}
+}
+
+inst FCMPL 0            B.i {fcmpl($1.f, $2.f)}
+inst FCMPG 0            B.i {fcmpg($1.f, $2.f)}
+
+equiv FEQ 0             {FCMPL, PUSH 0, EQ}
+equiv FNEQ 0            {FCMPL, PUSH 0, NEQ}
+equiv FLT 0             {FCMPG, PUSH 0, LT}
+equiv FGT 0             {FCMPL, PUSH 0, GT}
+equiv FLEQ 0            {FCMPG, PUSH 0, LEQ}
+equiv FGEQ 0            {FCMPL, PUSH 0, GEQ}
+
+# The floating-point conditional jumps are just shorthand for a
+# comparison and an integer jump.  This saves valuable opcodes for more
+# important functions.
+equiv FJEQ R            {FCMPL, JEQZ $a}
+equiv FJNEQ R           {FCMPL, JNEQZ $a}
+equiv FJLT R            {FCMPG, JLTZ $a}
+equiv FJGT R            {FCMPL, JGTZ $a}
+equiv FJLEQ R           {FCMPG, JLEQZ $a}
+equiv FJGEQ R           {FCMPL, JGEQZ $a}
+equiv FJNLT R           {FCMPG, JGEQZ $a}
+equiv FJNGT R           {FCMPL, JLEQZ $a}
+equiv FJNLEQ R          {FCMPG, JGTZ $a}
+equiv FJNGEQ R          {FCMPL, JLTZ $a}
+
+# DOUBLE-PRECISION OPERATORS
+
+defs {
+#ifdef UNALIGNED_MEM
+#define getdbl get_double
+#define putdbl put_double
+#define getlong get_long
+#define putlong put_long
+#else
+static inline double getdbl(value *v) {
+     dblbuf dd;
+     dd.n.lo = v[0].i;
+     dd.n.hi = v[1].i;
+     return dd.d;
+}
+
+static inline void putdbl(value *v, double x) {
+     dblbuf dd;
+     dd.d = x;
+     v[0].i = dd.n.lo;
+     v[1].i = dd.n.hi;
+}
+
+static inline longint getlong(value *v) {
+     dblbuf dd;
+     dd.n.lo = v[0].i;
+     dd.n.hi = v[1].i;
+     return dd.q;
+}
+
+static inline void putlong(value *v, longint x) {
+     dblbuf dd;
+     dd.q = x;
+     v[0].i = dd.n.lo;
+     v[1].i = dd.n.hi;
+}
+#endif
+}
+
+inst DPLUS 0            B.d {$1.d + $2.d}
+inst DMINUS 0           B.d {$1.d - $2.d}
+inst DTIMES 0           B.d {$1.d * $2.d}
+inst DDIV 0             B.d {$1.d / $2.d}
+inst DUMINUS 0          M.d {- $1.d}
+
+inst DCMPL 0            B.idd {fcmpl($1.d, $2.d)}
+inst DCMPG 0            B.idd {fcmpg($1.d, $2.d)}
+
+equiv DEQ 0             {DCMPL, PUSH 0, EQ}
+equiv DNEQ 0            {DCMPL, PUSH 0, NE}
+equiv DLT 0             {DCMPG, PUSH 0, LT}
+equiv DGT 0             {DCMPL, PUSH 0, GT}
+equiv DLEQ 0            {DCMPG, PUSH 0, LE}
+equiv DGEQ 0            {DCMPL, PUSH 0, GE}
+
+equiv DJEQ R            {DCMPL, JEQZ $a}
+equiv DJNEQ R           {DCMPL, JNEQZ $a}
+equiv DJLT R            {DCMPG, JLTZ $a}
+equiv DJGT R            {DCMPL, JGTZ $a}
+equiv DJLEQ R           {DCMPG, JLEQZ $a}
+equiv DJGEQ R           {DCMPL, JGEQZ $a}
+equiv DJNLT R           {DCMPG, JGEQZ $a}
+equiv DJNGT R           {DCMPL, JLEQZ $a}
+equiv DJNLEQ R          {DCMPG, JGTZ $a}
+equiv DJNGEQ R          {DCMPL, JLTZ $a}
+
+inst QCMP 0             B.iqq {lcmp($1.q, $2.q)}
+
+equiv QEQ 0             {QCMP, PUSH 0, EQ}
+equiv QLT 0             {QCMP, PUSH 0, LT}
+equiv QGT 0             {QCMP, PUSH 0, GT}
+equiv QLEQ 0            {QCMP, PUSH 0, LEQ}
+equiv QGEQ 0            {QCMP, PUSH 0, GEQ}
+equiv QNEQ 0            {QCMP, PUSH 0, NEQ}
+
+equiv QJEQ R            {QCMP, JEQZ $a}
+equiv QJLT R            {QCMP, JLTZ $a}
+equiv QJGT R            {QCMP, JGTZ $a}
+equiv QJLEQ R           {QCMP, JLEQZ $a}
+equiv QJGEQ R           {QCMP, JGEQZ $a}
+equiv QJNEQ R           {QCMP, JNEQZ $a}
+
+
+# CONVERSIONS
+
+inst CONVNF 0           M.f  {flo_conv($1.i)}
+inst CONVND 0           M.di {flo_conv($1.i)}
+inst CONVFN 0           M.i  {(int) $1.f}
+inst CONVDN 0           M.id {(int) $1.d}
+inst CONVFD 0           M.df {$1.f}
+inst CONVDF 0           M.fd {(float) $1.d}
+inst CONVNC 0           M.i  {$1.i & 0xff}
+inst CONVNS 0           M.i  {(short) $1.i}
+inst CONVNQ 0           M.qi {$1.i}
+inst CONVQN 0           M.iq {(int) $1.q}
+inst CONVQD 0           M.dq {flo_convq($1.q)}
+
+
+# RUN-TIME CHECKS
+
+# The operand of these checks is the line number to show in the error
+# message.  God forbid people should make source files containing
+# more than 65536 lines
+
+defs {
+static inline int boundcheck(unsigned i, unsigned n, int line,               
+                             value *bp, uchar *pc) {         
+     if (i >= n) runtime_error(E_BOUND, line, bp, pc);
+     return i;                                               
+}
+
+#define checkdef(name, type, arg, extra, test, msg)                     \
+     static inline type name(type arg extra, int line,                  \
+                             value *bp, uchar *pc) {                    \
+          if (test) runtime_error(msg, line, bp, pc);                   \
+          return arg;                                                   \
+     }
+
+checkdef(nullcheck, uchar *, p,, p == NULL, E_NULL)
+checkdef(zerocheck, int, n,, n == 0, E_DIV)
+checkdef(fzerocheck, double, x,, x == 0.0, E_FDIV)
+checkdef(lzerocheck, longint, n,, n == 0, E_DIV)
+checkdef(globcheck, value *, p,, p != NULL, E_GLOB)
+
+#define czech(chk, a, n) chk(a, n, bp, pc0)
+#define czech2(chk, a, b, n) chk(a, b, n, bp, pc0)
+#define error(msg, n) runtime_error(msg, n, bp, pc0);
+}
+
+inst BOUND 2            B.i {czech2(boundcheck, $1.i, $2.i, $a)}
+inst NCHECK 2           M.x {czech(nullcheck, pointer($1), $a)}
+inst GCHECK 2           S1  {czech(globcheck, valptr($1), $a);}
+inst ZCHECK 2           M.i {czech(zerocheck, $1.i, $a)}
+inst FZCHECK 2          M.f {czech(fzerocheck, $1.f, $a)}
+inst DZCHECK 2          M.d {czech(fzerocheck, $1.d, $a)}
+inst QZCHECK 2          M.q {czech(lzerocheck, $1.q, $a)}
+inst ERROR 12           S0  {error($a, $b);}
+equiv EASSERT 2         {RESULTW, ERROR E_ASSERT $a}
+
+
+# MORE BITS AND PIECES
+
+# ALIGNs instructions are used on big-endian machines like the SPARC
+# to ensure that CHAR and SHORT parameters appear at the right address.
+defs {
+#ifdef WORDS_BIGENDIAN
+#define alignx(a, n)    (a <<= (32-n))
+#else
+#define alignx(a, n)    a
+#endif
+}
+inst ALIGNC 0           M.i {alignx($1.i, 8)}
+inst ALIGNS 0           M.i {alignx($1.i, 16)}
+
+defs {
+#ifdef PROFILE
+#define prof_charge(n)  ticks += n
+#else
+#define prof_charge(n)
+#endif
+}
+
+# FIXCOPY copies a fixed number of bytes; it is used for structure
+# assignment and also for value parameters of (fixed) array or record type. */
+defs {
+#define fixcopy(a, b, n) prof_charge(n/4); memcpy(a, b, n)
+}
+inst FIXCOPY 0          S3 {fixcopy(pointer($1), pointer($2), $3.i);}
+
+# FLEXCOPY expects to find on the stack the address of a flex array parameter 
+# and a size in bytes; it copies the parameter to dynamic local space, 
+# then overwrites the parameter with the new address.
+defs {
+#define flexcopy(d0, size0)                                             \
+     { value *d = (value *) d0; int size = size0;                       \
+       int sizew = (size+3)/4; prof_charge(sizew);                      \
+       sp -= sizew;                                                     \
+       if ((uchar *) sp < stack + SLIMIT)                               \
+            error(E_STACK, 0);                                          \
+       memcpy(sp, pointer(d[0]), size);                                 \
+       d[0].a = address(sp);}
+}
+inst FLEXCOPY 0         S2 {flexcopy(pointer($1), $2.i);}
+
+# In the interpreter, the CALLW and CALLD instructions are implemented as 
+# two operations, an ordinary CALL followed by a SLIDE; the return address 
+# of the called routine points to the SLIDE instruction, which is 
+# responsible for copying the result.
+equiv CALL 1            {JPROC, SLIDE $a}
+equiv CALLW 1           {JPROC, SLIDEW $a}
+equiv CALLQ 1           {JPROC, SLIDEQ $a}
+equiv CALLF 1           {JPROC, SLIDEF $a}
+equiv CALLD 1           {JPROC, SLIDED $a}
+
+inst LINK 0             S1 {statlink = valptr($1);}
+inst SAVELINK 0         S0 {bp[SL].a = address(statlink);}
+
+defs {
+#define frame()                                                         \
+     bp = sp;                                                           \
+     sp = (value *) ((uchar *) bp - cp[CP_FRAME].i);                    \
+     if ((uchar *) sp < stack + SLIMIT) error(E_STACK, 0);              \
+     memset(sp, 0, cp[CP_FRAME].i);
+
+#ifdef OBXDEB
+#define cond_break() \
+     if (one_shot && *pc != K_LNUM_2 && *pc != K_BREAK_2) \
+         debug_break(cp, bp, pc, "stop")
+#else
+#define cond_break()
+#endif
+}
+
+inst JPROC 0 S0 {
+     value *p = valptr(sp[0]);
+     sp -= HEAD-1; sp[BP].a = address(bp); sp[PC].a = address(pc);
+     if (! interpreted(p)) {
+#ifdef PROFILE
+          /* Calling a native-code routine */
+          prof_enter(p, ticks, PROF_PRIM);
+          ticks = 0;
+#endif
+#ifdef OBXDEB
+          prim_bp = sp;
+#endif
+          primcall(p, sp);
+#ifdef OBXDEB
+          prim_bp = NULL;
+#endif
+     } else {
+#ifdef PROFILE
+          prof_enter(p, ticks, PROF_CALL);
+#endif
+          cp = p; pc = pointer(cp[CP_CODE]);
+          do_find_proc;
+          frame();
+     }
+}
+
+defs {
+#define slide(nargs) sp += HEAD + nargs; cond_break();
+}
+
+inst SLIDE 1            S0 {slide($a);}
+inst SLIDEW 1           S0 {slide($a); sp--; sp[0].i = ob_res.i;}
+inst SLIDED 1           S0 {slide($a); sp -= 2; 
+                                putdbl(&sp[0], getdbl(&ob_res));}
+inst SLIDEF 1           S0 {slide($a); sp--; sp[0].f = ob_res.f;}
+inst SLIDEQ 1           S0 {slide($a); sp -= 2;
+                                putlong(&sp[0], getlong(&ob_res));}
+
+equiv RETURNW 0         {RESULTW, RETURN}
+equiv RETURNF 0         {RESULTF, RETURN}
+equiv RETURND 0         {RESULTD, RETURN}
+equiv RETURNQ 0         {RESULTQ, RETURN}
+
+inst RESULTW 0          S1 {ob_res = $1;}
+inst RESULTD 0          S1d {putdbl(&ob_res, $1.d);}
+inst RESULTF 0          S1 {ob_res.f = $1.f;}
+inst RESULTQ 0          S1q {putlong(&ob_res, $1.q);}
+
+inst RETURN 0 S0 {
+     if (bp == base) {
+          level--;
+#ifdef PROFILE
+          prof_exit(NULL, ticks);
+#endif
+          return;
+     }
+
+     sp = bp; pc = pointer(sp[PC]); bp = valptr(sp[BP]); cp = valptr(bp[CP]);
+     do_find_proc;
+#ifdef PROFILE
+     prof_exit(cp, ticks);
+     ticks = 0;
+#endif
+     cond_break();
+}
+
+inst LNUM 2 S0 {
+#ifdef PROFILE
+     if (lflag) { 
+          static module m = NULL; /* Cache most recent module */
+          ticks--;
+          if (m == NULL || cp < (value *) m->m_addr 
+                || cp >= (value *) (m->m_addr + m->m_length)) {
+               m = find_module(cp);
+          }
+          m->m_lcount[$a-1]++; 
+     }
+#endif
+#ifdef OBXDEB
+     if (intflag)
+          debug_break(cp, bp, pc0, "interrupt");
+     else if (one_shot) 
+          debug_break(cp, bp, pc0, "line");
+#endif
+}
+
+inst BREAK 2 S0 {
+#ifdef OBXDEB
+     debug_break(cp, bp, pc0, "break");
+#endif
+}
+
+if {[info exists SPECIALS]} {
+
+# SPECIALS FOR COMPILERS COURSE
+
+defs {
+#define casejump(x, n0)                                 \
+     {                                                  \
+          int n = n0;                                   \
+          pc0 = pc; pc += 4*n;                          \
+          while (n > 0) {                               \
+               if (x == get2(pc0)) {                    \
+                    jump(get2(pc0+2));                  \
+                    break;                              \
+               }                                        \
+               pc0 += 4; n--;                           \
+          }                                             \
+     }
+}
+
+inst CASEJUMP 1         S1  {casejump($1.i, $a);}
+zinst CASEARM 2R
+
+inst PACK 0             B.i {pack(valptr($2), pointer($1))}
+inst UNPACK 0           S0 {sp--; sp[0].a = address(getcode(sp[1].i)); 
+                                   sp[1].a = address(getenvt(sp[1].i));}
+}
+
+zinst REG 0
+zinst ADDR 0
+zinst STACKW 0
+zinst STACKQ 0
+zinst CON 0
+
+
+# DIRECTIVES
+
+dir CONST ?
+dir FCONST ?
+dir DCONST ?
+dir QCONST ?
+dir GLOBAL ?
+dir LABEL ?
+dir PROC ????
+dir END 0
+dir PRIMDEF ???
+dir DEFINE ?
+dir STRING ?
+dir GLOVAR ??
+dir WORD ?
+dir MODULE ???
+dir ENDHDR 0
+dir IMPORT ??
+dir STKMAP ?
+dir LINE ?
+
+if {[info exists SPECIALS]} {
+   dir PCALL ?
+   dir PCALLW ?
+}
+
+
+# EXPANSIONS USED BY THE JIT TRANSLATOR
+
+expand LDLW 1           {LOCAL $a, LOADW}
+expand LDLS 1           {LOCAL $a, LOADS}
+expand LDLC 1           {LOCAL $a, LOADC}
+expand LDLF 1           {LOCAL $a, LOADF}
+expand LDLD 1           {LOCAL $a, LOADD}
+expand STLW 1           {LOCAL $a, STOREW}
+expand STLS 1           {LOCAL $a, STORES}
+expand STLC 1           {LOCAL $a, STOREC}
+expand STLF 1           {LOCAL $a, STOREF}
+expand STLD 1           {LOCAL $a, STORED}
+
+expand LDGW 1           {LDKW $a, LOADW}
+expand LDGS 1           {LDKW $a, LOADS}
+expand LDGC 1           {LDKW $a, LOADC}
+expand LDGF 1           {LDKW $a, LOADF}
+expand LDGD 1           {LDKW $a, LOADD}
+expand STGW 1           {LDKW $a, STOREW}
+expand STGS 1           {LDKW $a, STORES}
+expand STGC 1           {LDKW $a, STOREC}
+expand STGF 1           {LDKW $a, STOREF}
+expand STGD 1           {LDKW $a, STORED}
+
+expand LDNW 1           {PUSH $a, OFFSET, LOADW}
+expand STNW 1           {PUSH $a, OFFSET, STOREW}
+
+expand INC 0            {PUSH 1, PLUS}
+expand DEC 0            {PUSH 1, MINUS}
+
+expand INCL 1           {LDLW $a, INC, STLW $a}
+expand DECL 1           {LDLW $a, DEC, STLW $a}
+
+expand JEQZ S           {PUSH 0, JEQ $a}
+expand JLTZ S           {PUSH 0, JLT $a}
+expand JGTZ S           {PUSH 0, JGT $a}
+expand JLEQZ S          {PUSH 0, JLEQ $a}
+expand JGEQZ S          {PUSH 0, JGEQ $a}
+expand JNEQZ S          {PUSH 0, JNEQ $a}
+
+expand LDIQ 0           {INDEXD, LOADQ}
+expand STIQ 0           {INDEXD, STOREQ}