mirror of
https://github.com/Interlisp/maiko.git
synced 2026-01-14 15:36:34 +00:00
122 lines
3.1 KiB
C
122 lines
3.1 KiB
C
/* $Id: shift.c,v 1.3 1999/05/31 23:35:42 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved */
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* (C) Copyright 1989-95 Venue. All Rights Reserved. */
|
|
/* Manufactured in the United States of America. */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
#include "version.h"
|
|
|
|
#include "arith.h" // for N_GETNUMBER, N_ARITH_SWITCH
|
|
#include "emlglob.h"
|
|
#include "lispemul.h" // for state, ERROR_EXIT, LispPTR
|
|
#include "lspglob.h"
|
|
#include "lsptypes.h"
|
|
#include "shiftdefs.h" // for N_OP_llsh1, N_OP_llsh8, N_OP_lrsh1, N_OP_lrsh8
|
|
|
|
/*
|
|
* XXX: it feels as though something is not clean here, looks like the
|
|
* "int a" arguments are really LispPTR types, though perhaps it doesn't
|
|
* matter. NBriggs, May 2017 -- Yes. Replaced. NBriggs, Aug 2022
|
|
*/
|
|
|
|
/************************************************************
|
|
N_OP_llsh1
|
|
entry LLSH1 OPCODE[0340]
|
|
return(a << 1)
|
|
************************************************************/
|
|
LispPTR N_OP_llsh1(LispPTR a) {
|
|
int arg1;
|
|
|
|
N_GETNUMBER(a, arg1, du_ufn);
|
|
arg1 <<= 1;
|
|
N_ARITH_SWITCH(arg1);
|
|
|
|
du_ufn:
|
|
ERROR_EXIT(a);
|
|
}
|
|
|
|
/************************************************************
|
|
N_OP_llsh8
|
|
entry LLSH8 OPCODE[0341]
|
|
return(a << 8)
|
|
************************************************************/
|
|
LispPTR N_OP_llsh8(LispPTR a) {
|
|
int arg1;
|
|
|
|
N_GETNUMBER(a, arg1, du_ufn);
|
|
arg1 <<= 8;
|
|
N_ARITH_SWITCH(arg1);
|
|
|
|
du_ufn:
|
|
ERROR_EXIT(a);
|
|
}
|
|
|
|
/************************************************************
|
|
N_OP_lrsh1
|
|
entry LRSH1 OPCODE[0342]
|
|
return(a >> 1)
|
|
************************************************************/
|
|
LispPTR N_OP_lrsh1(LispPTR a) {
|
|
int arg1;
|
|
|
|
N_GETNUMBER(a, arg1, du_ufn);
|
|
arg1 = (unsigned)arg1 >> 1;
|
|
N_ARITH_SWITCH(arg1);
|
|
|
|
du_ufn:
|
|
ERROR_EXIT(a);
|
|
|
|
}
|
|
|
|
/************************************************************
|
|
N_OP_lrsh8
|
|
entry LRSH8 OPCODE[0343]
|
|
return(a >> 8)
|
|
************************************************************/
|
|
LispPTR N_OP_lrsh8(LispPTR a) {
|
|
int arg1;
|
|
|
|
N_GETNUMBER(a, arg1, du_ufn);
|
|
arg1 = (unsigned)arg1 >> 8;
|
|
N_ARITH_SWITCH(arg1);
|
|
|
|
du_ufn:
|
|
ERROR_EXIT(a);
|
|
}
|
|
|
|
/************************************************************
|
|
N_OP_lsh
|
|
entry LSH OPCODE[0347]
|
|
return(a <?> b)
|
|
************************************************************/
|
|
LispPTR N_OP_lsh(LispPTR a, LispPTR b) {
|
|
int arg, arg2;
|
|
int size;
|
|
/*DLword *wordp;*/
|
|
|
|
N_GETNUMBER(b, size, do_ufn);
|
|
N_GETNUMBER(a, arg2, do_ufn);
|
|
|
|
if (size > 0) {
|
|
if (size > 31) goto do_ufn;
|
|
arg = arg2 << size;
|
|
if ((arg >> size) != arg2) goto do_ufn;
|
|
} else if (size < 0) {
|
|
if (size < -31) goto do_ufn;
|
|
arg = arg2 >> -size;
|
|
/*** Commented out JDS 1/27/89: This punts if you shifted ***/
|
|
/*** ANY 1 bits off the right edge. You CAN'T overflow ***/
|
|
/*** in this direction!! ***/
|
|
/* if ((arg << -size) != arg2) goto do_ufn; */
|
|
} else
|
|
return (a);
|
|
|
|
N_ARITH_SWITCH(arg);
|
|
|
|
do_ufn:
|
|
ERROR_EXIT(b);
|
|
}
|