github.com/Interlisp.maiko
1
0
Fork 0
mirror of https://github.com/Interlisp/maiko.git synced 2026-01-14 23:46:14 +00:00
Code Issues Projects Releases Wiki Activity
Interlisp.maiko/src/eqf.c

316 lines
8.2 KiB
C
Executable File
Raw Blame History

/* $Id: eqf.c,v 1.3 1999/05/31 23:35:28 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved */
static char *id = "$Id: eqf.c,v 1.3 1999/05/31 23:35:28 sybalsky Exp $ Copyright (C) Venue";
/************************************************************************/
/* */
/* */
/* */
/* */
/* */
/************************************************************************/
/************************************************************************/
/* */
/* (C) Copyright 1989-95 Venue. All Rights Reserved. */
/* Manufactured in the United States of America. */
/* */
/* The contents of this file are proprietary information */
/* belonging to Venue, and are provided to you under license. */
/* They may not be further distributed or disclosed to third */
/* parties without the specific permission of Venue. */
/* */
/************************************************************************/
#include "version.h"
#include <stdio.h>
#include "lispemul.h"
#include "lspglob.h"
#include "adr68k.h"
#include "lispmap.h"
#include "lsptypes.h"
#include "medleyfp.h"
#include "my.h"
#include "arith.h"
/************************************************************
op 072 N_OP_eqlop EQL
op 0314 N_OP_clequal CL:EQUAL
op 0360 (inline) EQ
op 0364 N_OP_equal IL:EQUAL
op 0377 N_OP_eqq CL:=
***********************************************************/
/* differences between these operations:
EQ is a strict pointer comparision, equivalent to C's ==
EQL (common lisp) does no conversions before comparision, but will
compare equal FIXPs or equal FLOATPs.
CL:= will do a numeric comparison
and will compare floats. If given integers, it will convert
to floating point first.
IL:EQUAL is a recursive comparison which will compare 1 = 1.0
it work like code with CL:= for the most part
CL:EQUAL is a recursive comparision which uses EQL at the leaves
Interlisp operations IEQP, FEQP have no opcodes, although there
is an unboxed FEQP.
number types include:
SMALLP (immediate with S_POSITIVE or S_NEGATIVE)
FIXP (32 bit boxed value, handled in C. Usually canonical, i.e.,
will be SMALLP. (IPLUS x 0) will always canonicallize.)
FLOATP (32 bit boxed value, handled in C, usually)
RATIO (a/b. Always canonical, i.e., b doesn't divide a evenly)
COMPLEX (a+bi. Not handled in C)
BIGNUM (integer that can't be represented bigger than 32 bits)
*/
#define IF_IMMEDIATE(arg, doit, doitsmall) \
switch(SEGMASK & arg) { \
case ATOM_OFFSET: doit; \
case S_CHARACTER: doit; \
case S_POSITIVE: doitsmall; \
case S_NEGATIVE: doitsmall; \
}
/************************************************************************/
/* */
/* N _ O P _ c l e q u a l */
/* */
/* Common Lisp EQUAL, opcode 0314. */
/* */
/************************************************************************/
int N_OP_clequal(register int arg1, register int arg2)
{
register int type;
if (arg2 == arg1) return(ATOM_T);
IF_IMMEDIATE(arg1, return(NIL), return(NIL));
IF_IMMEDIATE(arg2, return(NIL), return(NIL));
/* CL:EQUAL is true for two strings that have different Interlisp
type numbers; cannot currently handle it here. */
/* can return NIL if one is a number and the other isn't */
if (IsNumber(arg1)) { if(!IsNumber(arg2)) return(NIL); }
else {if (IsNumber(arg2)) {return(NIL);}
else ERROR_EXIT(arg2)}
/* now we know both are numbers */
if ((type = GetTypeNumber(arg1)) != (GetTypeNumber(arg2))) return(NIL);
/* now we know both are the same type. Shouldn't see any SMALLPs */
switch (type)
{
case TYPE_FIXP: if (FIXP_VALUE(arg1) == FIXP_VALUE(arg2))
{return(ATOM_T);}
return(NIL);
case TYPE_FLOATP: if(FLOATP_VALUE(arg1) == FLOATP_VALUE(arg2))
{return(ATOM_T);}
return(NIL);
default: ERROR_EXIT(arg2);
}
}/* end N_OP_clequal */
/************************************************************************/
/* */
/* N _ O P _ e q l o p */
/* */
/* Common Lisp EQL. */
/* */
/************************************************************************/
int N_OP_eqlop(register int arg1, register int arg2)
{
register int type;
if (arg2 == arg1) return(ATOM_T);
IF_IMMEDIATE(arg1, return(NIL), return(NIL));
IF_IMMEDIATE(arg2, return(NIL), return(NIL));
/* EQL is true if EQ or both are numbers, the same type, and EQUAL */
/* can return NIL if one is a number and the other isn't */
if ((type = GetTypeNumber(arg1)) != (GetTypeNumber(arg2))) return(NIL);
/* now we know both are the same type. Shouldn't see any SMALLPs */
switch (type)
{
case TYPE_FIXP: if (FIXP_VALUE(arg1) == FIXP_VALUE(arg2))
{return(ATOM_T);}
return(NIL);
case TYPE_FLOATP: if(FLOATP_VALUE(arg1) == FLOATP_VALUE(arg2))
{return(ATOM_T);}
return(NIL);
default: if(IsNumber(arg1)) {ERROR_EXIT(arg2); }
else return(NIL);
}
} /* end N_OP_eqlop */
/************************************************************************/
/* */
/* N _ O P _ e q u a l */
/* */
/* IL:EQUAL, opcode 0364. */
/* */
/************************************************************************/
N_OP_equal(register int arg1, register int arg2)
{
register int type, type2;
if (arg2 == arg1) return(ATOM_T);
IF_IMMEDIATE(arg1, return(NIL), goto arg1_small);
IF_IMMEDIATE(arg2, return(NIL), goto arg2_small);
goto arg2_small;
arg1_small:
IF_IMMEDIATE(arg2, return(NIL), return(NIL)); /* arg2 atom or both small */
arg2_small:
if (IsNumber(arg1)) { if(!IsNumber(arg2)) return(NIL) ;}
else {if (IsNumber(arg2)) {return(NIL);}
else ERROR_EXIT(arg2)}
/* now we know both are numbers */
type = GetTypeNumber(arg1);
type2 = GetTypeNumber(arg2);
if (type == type2)
{
switch (GetTypeNumber(arg1))
{
case TYPE_SMALLP: return(NIL);
case TYPE_FIXP: if(FIXP_VALUE(arg1)==FIXP_VALUE(arg2))
{return(ATOM_T);}
return(NIL);
case TYPE_FLOATP: if(FLOATP_VALUE(arg1)==FLOATP_VALUE(arg2))
{return(ATOM_T);}
return(NIL);
default: ERROR_EXIT(arg2);
}
}
if ((type == TYPE_FLOATP) || (type2 == TYPE_FLOATP))
{
register float f1, f2;
N_MakeFloat(arg1, f1, arg2);
N_MakeFloat(arg2, f2, arg2);
if ((f1 + 0.0) == (f2 + 0.0)) return(ATOM_T);
else return(NIL);
}
else return(NIL); /* neither is float, types are different */
} /* end N_OP_equal */
/************************************************************************/
/* */
/* N _ O P _ e q q */
/* */
/* Common Lisp =, opcode 0377. Numeric compare, will convert */
/* among representations as needed. */
/* */
/************************************************************************/
N_OP_eqq(register int arg1, register int arg2) /* CL:= opcode 0377 */
{
register int type1, type2;
register float f1, f2;
if (!((type1 = GetTypeEntry(arg1)) & TT_NUMBERP)) ERROR_EXIT(arg2);
if (arg2 == arg1) return(ATOM_T);
if (!((type2 = GetTypeEntry(arg2)) & TT_NUMBERP)) ERROR_EXIT(arg2);
type1 &= 0x7ff;
type2 &= 0x7ff;
switch ( type1 )
{
case TYPE_SMALLP :
switch ( type2 )
{
case TYPE_SMALLP : return(NIL);
case TYPE_FIXP : return(NIL);
case TYPE_FLOATP : goto checkfloats;
default : ERROR_EXIT(arg2);
}
case TYPE_FIXP :
switch ( type2 )
{
case TYPE_SMALLP : return(NIL);
case TYPE_FIXP :
if (FIXP_VALUE(arg1) == FIXP_VALUE(arg2))
return(ATOM_T);
else return(NIL);
case TYPE_FLOATP : goto checkfloats;
default : ERROR_EXIT(arg2);
}
case TYPE_FLOATP :
switch ( type2 )
{
case TYPE_SMALLP : goto checkfloats;
case TYPE_FIXP : goto checkfloats;
case TYPE_FLOATP : goto checkfloats;
default : ERROR_EXIT(arg2);
}
default : ERROR_EXIT(arg2);
}
checkfloats:
N_MakeFloat(arg1, f1, arg2);
N_MakeFloat(arg2, f2, arg2);
if (f1 == f2) return(ATOM_T);
if ((f1 == -0.0) && (f2 == 0.0)) return(ATOM_T);
if ((f1 == 0.0) && (f2 == -0.0)) return(ATOM_T);
return(NIL);
} /* end N_OP_eqq() */
Reference in New Issue View Git Blame Copy Permalink