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

293 lines
8.0 KiB
C
Raw Blame History

/* $Id: eqf.c,v 1.3 1999/05/31 23:35:28 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 <stdio.h>
#include "lispemul.h"
#include "lspglob.h"
#include "adr68k.h"
#include "lispmap.h"
#include "lsptypes.h"
#include "medleyfp.h"
#include "mkcelldefs.h"
#include "arith.h"
#include "my.h"
#include "eqfdefs.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 comparison, equivalent to C's ==
EQL (common lisp) does no conversions before comparison, 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 comparison 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. */
/* */
/************************************************************************/
LispPTR 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. */
/* */
/************************************************************************/
LispPTR 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. */
/* */
/************************************************************************/
LispPTR 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. */
/* */
/************************************************************************/
LispPTR 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