view keiko/keiko.iset @ 1:b5139af1a420 tip basis

Fixed permissions on compile scripts
author Mike Spivey <mike@cs.ox.ac.uk>
date Fri, 13 Oct 2017 17:27:58 +0100
parents bfdcc3820b32
children
line wrap: on
line source
#
# 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}