mirror of
https://github.com/Interlisp/maiko.git
synced 2026-01-27 04:12:51 +00:00
Maiko sources matching state as of 020102 prior to initial patching for Mac OSX
This commit is contained in:
Nick Briggs
453
src/mkatom.c
Executable file
453
src/mkatom.c
Executable file
@@ -0,0 +1,453 @@
|
||||
/* $Id: mkatom.c,v 1.4 2001/12/24 01:09:05 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved */
|
||||
static char *id = "$Id: mkatom.c,v 1.4 2001/12/24 01:09:05 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"
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/*
|
||||
File Name : makeatom.c
|
||||
|
||||
Desc. : Create atom
|
||||
|
||||
Date : January 29, 1987
|
||||
Edited by : Takeshi Shimizu
|
||||
Change : create_symbol
|
||||
take,30-Jun
|
||||
1 May 1987 take
|
||||
28 Aug. 1987 take
|
||||
|
||||
Including : make_atom
|
||||
compute_hash
|
||||
create_symbol
|
||||
compare_chars
|
||||
parse_number
|
||||
*/
|
||||
/**********************************************************************/
|
||||
|
||||
|
||||
#include "lispemul.h"
|
||||
#include "adr68k.h"
|
||||
#include "lsptypes.h"
|
||||
#include "lispmap.h"
|
||||
#include "cell.h"
|
||||
#include "dbprint.h"
|
||||
|
||||
#define ATOMoffset 2 /* NIL NOBIND */
|
||||
#define MAX_ATOMINDEX 0xffff /* max number of atoms */
|
||||
|
||||
#define Atom_reprobe( hash , char ) ((((char) ^ (hash))| 1) & 63 )
|
||||
|
||||
extern DLword *Lisp_world ;
|
||||
|
||||
/**********************************************************************/
|
||||
/*
|
||||
Func name : compute_hash
|
||||
|
||||
Compute hash value from chars.
|
||||
THIS ONLY WORKS CORRECTLY ON EMULATOR STRINGS.
|
||||
Don't use it with strings in lisp-space.
|
||||
|
||||
Date : January 29, 1987
|
||||
Chan. Aug. 27 87 take
|
||||
Edited by : Takeshi Shimizu
|
||||
*/
|
||||
/**********************************************************************/
|
||||
|
||||
|
||||
compute_hash (char *char_base, DLword offset, DLword length)
|
||||
{
|
||||
DLword hash;
|
||||
DLword number;
|
||||
DLword temp1,temp2;
|
||||
DLword *word_base;
|
||||
char_base +=offset;
|
||||
hash = (int)(*(char_base)) << 8 ; /* get first byte */
|
||||
char_base++ ; /* skip length area */
|
||||
|
||||
for (number= 1; number <= length -1; char_base++, number++)
|
||||
{
|
||||
hash = (hash + ((hash & 4095) << 2)) & 0x0ffff;
|
||||
temp1 = (hash + ((hash & 255) << 8)) & 0x0ffff;
|
||||
hash = (int)(temp1 + (*(char_base))) & 0x0ffff ;
|
||||
}
|
||||
|
||||
return (hash);
|
||||
|
||||
} /* end compute_hash */
|
||||
|
||||
/**********************************************************************/
|
||||
/*
|
||||
Func name : compute_lisp_hash
|
||||
|
||||
Compute hash value from chars. WORKS ONLY ON LISP CHARS.
|
||||
|
||||
Date : January 29, 1987
|
||||
Chan. Aug. 27 87 take
|
||||
Edited by : Takeshi Shimizu
|
||||
*/
|
||||
/**********************************************************************/
|
||||
|
||||
|
||||
compute_lisp_hash (char *char_base, DLword offset, DLword length, DLword fatp)
|
||||
{
|
||||
DLword hash;
|
||||
DLword number;
|
||||
DLword temp1,temp2;
|
||||
DLword *word_base;
|
||||
|
||||
if (length == 0) return(0);
|
||||
|
||||
if (fatp)
|
||||
{ /* fat characters in the string to be searched. */
|
||||
word_base = (DLword *)char_base;
|
||||
word_base +=offset;
|
||||
hash = (DLword)(0xFF & GETWORD(word_base)) << 8 ; /* get first byte */
|
||||
word_base++ ; /* skip length area */
|
||||
|
||||
for (number= 1; number <= length -1; word_base++, number++)
|
||||
{
|
||||
hash = (hash + ((hash & 4095) << 2)) & 0x0ffff;
|
||||
temp1 = (hash + ((hash & 255) << 8)) & 0x0ffff;
|
||||
hash = (int)(temp1 + (0xFF & GETWORD(word_base))) & 0x0ffff ;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
char_base +=offset;
|
||||
hash = (int)(0xFF & GETBYTE(char_base)) << 8 ; /* get first byte */
|
||||
char_base++ ; /* skip length area */
|
||||
|
||||
for (number= 1; number <= length -1; char_base++, number++)
|
||||
{
|
||||
hash = (hash + ((hash & 4095) << 2)) & 0x0ffff;
|
||||
temp1 = (hash + ((hash & 255) << 8)) & 0x0ffff;
|
||||
hash = (int)(temp1 + (0xFF & GETBYTE(char_base))) & 0x0ffff ;
|
||||
}
|
||||
}
|
||||
return (hash);
|
||||
|
||||
} /* end compute_lisp_hash */
|
||||
|
||||
/**********************************************************************/
|
||||
/*
|
||||
Func name : compare_chars
|
||||
|
||||
Compare two strings, char1, char2
|
||||
char1 -- in the LISP address space (& potentially
|
||||
byte swapped!)
|
||||
char2 -- in emulator space, and obeying the "natural"
|
||||
ordering of bytes in a string.
|
||||
|
||||
Date : January 29, 1987
|
||||
Edited by : Takeshi Shimizu
|
||||
(why not call strncmp directly??)
|
||||
Because we need to account for byte ordering!! --JDS
|
||||
AND we need to compare NS chars (which have 0s in the string) correctly!
|
||||
*/
|
||||
/**********************************************************************/
|
||||
|
||||
compare_chars(register char *char1, register char *char2, register DLword length)
|
||||
{
|
||||
#ifndef BYTESWAP
|
||||
if (memcmp ( char1, char2, length ) == 0)
|
||||
#else
|
||||
if (bytecmp ( char1, char2, length ))
|
||||
#endif /* BYTESWAP */
|
||||
|
||||
{
|
||||
return(T);
|
||||
}
|
||||
else
|
||||
{
|
||||
return(NIL);
|
||||
}
|
||||
|
||||
} /* end compare_chars */
|
||||
#ifdef BYTESWAP
|
||||
bytecmp (char1, char2, len)
|
||||
char *char1;
|
||||
char *char2;
|
||||
int len;
|
||||
{
|
||||
int index;
|
||||
for (index=0; index<len; index++)
|
||||
{
|
||||
if (GETBYTE(char1++) != *(char2++)) return(0);
|
||||
}
|
||||
return(1);
|
||||
}
|
||||
#endif /* BYTESWAP */
|
||||
|
||||
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/*
|
||||
Func name : compare_lisp_chars
|
||||
|
||||
Compare two strings, char1, char2
|
||||
in the LISP address space (& potentially
|
||||
byte swapped!)
|
||||
|
||||
Date : January 29, 1987
|
||||
Edited by : Takeshi Shimizu
|
||||
(why not call strncmp directly??)
|
||||
Because we need to account for byte ordering!! --JDS
|
||||
And for fat/thin differences.
|
||||
OFFSETs must be accounted for in the pointers already.
|
||||
*/
|
||||
/**********************************************************************/
|
||||
|
||||
compare_lisp_chars(register char *char1, register char *char2, register DLword length, DLword fat1, DLword fat2)
|
||||
{
|
||||
if ((!fat1) == (!fat2))
|
||||
{ /* both fat or both non-fat. */
|
||||
#ifdef BYTESWAP
|
||||
if (fat1)
|
||||
{ /* both fat, so compare 'em a word at a time */
|
||||
int i;
|
||||
for (i = 0; i < length; i++)
|
||||
if (GETWORD(char1++) != GETWORD(char2++)) return(NIL);
|
||||
return(T);
|
||||
}
|
||||
else
|
||||
{ /* both thin, so compare 'em a byte at a time */
|
||||
/* (it's this way in case we're byte-swapped.)*/
|
||||
int i;
|
||||
for (i=0; i< length; i++)
|
||||
if (GETBYTE(char1++) != GETBYTE(char2++)) return(NIL);
|
||||
return(T);
|
||||
}
|
||||
#else
|
||||
/* This one fails for byte-swapped machines */
|
||||
if (fat1) length = length + length;
|
||||
if (memcmp ( char1, char2, length ) == 0) return(T);
|
||||
else{ return(NIL);}
|
||||
#endif /* BYTESWAP */
|
||||
|
||||
}
|
||||
else if (fat1)
|
||||
{ /* char1 is fat, char2 isn't */
|
||||
if (lispcmp(char1, char2, length)) return(T);
|
||||
else return(NIL);
|
||||
}
|
||||
else
|
||||
{ /* char2 is fat, char1 isn't */
|
||||
if (lispcmp(char2, char1, length)) return(T);
|
||||
else return(NIL);
|
||||
}
|
||||
|
||||
} /* end compare_lisp_chars */
|
||||
|
||||
|
||||
|
||||
lispcmp (DLword *char1, unsigned char *char2, int len)
|
||||
{
|
||||
int index;
|
||||
for (index=0; index<len; index++)
|
||||
{
|
||||
if (GETWORD(char1++) != GETBYTE(char2++)) return(0);
|
||||
}
|
||||
return(1);
|
||||
}
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/*
|
||||
Func name : make_atom
|
||||
|
||||
If the atom already existed then return
|
||||
else create new atom . Returns the Atom's index.
|
||||
|
||||
This function does not handle FAT pname's.
|
||||
|
||||
Date : January 29, 1987
|
||||
Edited by : Takeshi Shimizu
|
||||
Changed : take 20-Jan
|
||||
Changed : March 27 '87 take
|
||||
Changed : May 1 '87 take
|
||||
Changed : May 9 '87 take
|
||||
Changed : May 13 '87 take
|
||||
May 15 '87 take
|
||||
*/
|
||||
/**********************************************************************/
|
||||
|
||||
LispPTR
|
||||
make_atom(char *char_base, DLword offset,
|
||||
DLword length, short int non_numericp)
|
||||
/* if it is NIL then these chars are treated as NUMBER */
|
||||
{
|
||||
extern DLword *Spospspace ;
|
||||
extern DLword *AtomHT ;
|
||||
extern DLword *Pnamespace ;
|
||||
extern DLword *AtomSpace ;
|
||||
LispPTR parse_number(char *char_base, short int length);
|
||||
|
||||
DLword hash;
|
||||
LispPTR hash_entry ; /* hash entry contents */
|
||||
DLword atom_index ;
|
||||
DLword reprobe ;
|
||||
|
||||
PNCell *pnptr ;
|
||||
char *pname_base ;
|
||||
unsigned short first_char ;
|
||||
|
||||
#ifdef TRACE2
|
||||
printf("TRACE: make_atom( %s , offset= %d, len= %d, non_numericp = %d)\n",
|
||||
char_base, offset, length , non_numericp);
|
||||
#endif
|
||||
|
||||
first_char = (*(char_base+offset)) & 0xff ;
|
||||
if (length!=0)
|
||||
{
|
||||
if(length==1) /* one char. atoms */
|
||||
{
|
||||
if (first_char > 57 ) /* greater than '9 */
|
||||
return((LispPTR)(ATOMoffset + (first_char -10)) );
|
||||
else if (first_char > 47) /* between '0 to '9 */
|
||||
return((LispPTR)(S_POSITIVE + (first_char - 48)) );
|
||||
/* fixed S_... mar-27-87 take */
|
||||
else /* other one char. atoms */
|
||||
return ((LispPTR)(ATOMoffset +first_char));
|
||||
} /* if(length==1.. end */
|
||||
else if ((non_numericp ==NIL) &&(first_char <= '9'))
|
||||
/* more than 10 arithmetic aon + - mixed atom process */
|
||||
{
|
||||
if((hash_entry = parse_number(char_base+offset,length))!=0)
|
||||
return((LispPTR)hash_entry); /* if NIL that means THE ATOM is +- mixed litatom */
|
||||
/* 15 may 87 take */
|
||||
}
|
||||
|
||||
hash = compute_hash(char_base, offset,length) ;
|
||||
|
||||
} /* if(lengt.. end */
|
||||
else
|
||||
{
|
||||
hash = 0;
|
||||
first_char = 255 ;
|
||||
}
|
||||
|
||||
/* This point corresponds with LP in Lisp source */
|
||||
|
||||
/* following for loop never exits until it finds new hash enty or same atom */
|
||||
for ( reprobe=Atom_reprobe(hash ,first_char) ;
|
||||
(hash_entry= GETWORD(AtomHT+hash)) != 0 ;
|
||||
hash = ((hash + reprobe) & 0xffff) )
|
||||
{
|
||||
atom_index = hash_entry -1 ;
|
||||
/* get pname pointer */
|
||||
pnptr = (PNCell *)GetPnameCell( atom_index);
|
||||
pname_base= (char *)Addr68k_from_LADDR(POINTERMASK & pnptr->pnamebase) ;
|
||||
|
||||
if ((length == GETBYTE(pname_base) ) &&
|
||||
(compare_chars(++pname_base,char_base+offset,length) ==T))
|
||||
{
|
||||
DBPRINT(("FOUND the atom. \n"));
|
||||
return ( atom_index ); /* find already existed atom */
|
||||
}
|
||||
DBPRINT(("HASH doesn't hit. reprobe!\n"));
|
||||
|
||||
} /* for end */
|
||||
|
||||
/* we can't find that atom, then we should make new atom */
|
||||
DBPRINT(("HASH NEVER HIT. Returning -1.\n"));
|
||||
return(0xffffffff);
|
||||
/** Don't create newatom now **/
|
||||
} /* make_atom end */
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
/*********************************************************************/
|
||||
/*
|
||||
Func name : parse_number
|
||||
|
||||
Desc : It can treat -65534 to 65535 integer
|
||||
Returns SMALLP PTR
|
||||
Date : 1,May 1987 Take
|
||||
15 May 87 take
|
||||
*/
|
||||
/*********************************************************************/
|
||||
|
||||
/* Assume this func. should be called with C string in "char_base" */
|
||||
LispPTR parse_number(char *char_base, short int length)
|
||||
{
|
||||
register LispPTR sign_mask ;
|
||||
register LispPTR val ;
|
||||
register int radix ;
|
||||
register int *cell68k;
|
||||
|
||||
|
||||
#ifdef TRACE2
|
||||
printf("TRACE: parse_number()\n");
|
||||
#endif
|
||||
|
||||
/* Check for Radix 8(Q) postfixed ?? */
|
||||
if( (*(char_base +(length -1))) == 'Q')
|
||||
{
|
||||
radix= 8;
|
||||
length--;
|
||||
}
|
||||
else radix = 10 ;
|
||||
|
||||
/* Check for Sign */
|
||||
sign_mask =S_POSITIVE ;
|
||||
|
||||
if((*(char_base) == '+') || (*(char_base) == '-'))
|
||||
{
|
||||
sign_mask = ((*char_base++) =='+') ? S_POSITIVE : S_NEGATIVE ;
|
||||
length--;
|
||||
}
|
||||
|
||||
for(val=0;length>0;length--)
|
||||
{
|
||||
if ( (((*char_base)) < '0' ) || ( '9' < ((*char_base))) )
|
||||
return(NIL);
|
||||
val = radix * val + (*char_base++) - '0' ;
|
||||
}
|
||||
|
||||
if(val > 0xffffffff)
|
||||
error("parse_number : Overflow ...exceeded range of FIXP");
|
||||
|
||||
if((sign_mask == S_POSITIVE)&&(val > 0xffff))
|
||||
{
|
||||
cell68k = (int *)createcell68k(TYPE_FIXP);
|
||||
*cell68k = val ;
|
||||
return(LADDR_from_68k(cell68k));
|
||||
}
|
||||
else if((sign_mask == S_NEGATIVE) && (val > 0xffff))
|
||||
{
|
||||
cell68k =(int *) createcell68k(TYPE_FIXP);
|
||||
*cell68k = ~val +1 ;
|
||||
return(LADDR_from_68k(cell68k));
|
||||
}
|
||||
|
||||
else if(sign_mask == S_NEGATIVE)
|
||||
return(sign_mask | (~((DLword)val) + 1));
|
||||
else
|
||||
{
|
||||
return(sign_mask | val);
|
||||
}
|
||||
}
|
||||
/* end parse_number */
|
||||
Reference in New Issue
Block a user