/* peekpoke.c zilla 20sep - Peek/Poke routines:foundations of fstructures
 * Peek/Poke routines are the foundation access routine for fstructs;
 * see fstruct.e.
 * There are two sets of routines:
 * 1) named like farray%peek-int, peek or poke signed or unsigned
 *    (4byte) ints or shorts within an farray.  The offset within the farray
 *    is checked, so these routines are relatively safe.
 *    Char access is not needed because fstructs are based on
 *    'string (byte) farrays, and farray-ref/set can be used directly.
 * >> This set is used for mapping an fstruct onto scheme heap memory
 *    allocated with farray.  Use this type if possible.
 * 2) named like %peek-int, peek or poke signed or unsigned 
 *    (4 byte) ints, shorts, or chars at an arbitrary address.
 * >> This set is used for mapping an fstruct onto memory returned by 
 *    malloc or some other routine; the address looks like an integer
 *    to scheme.
 *
 * The farray routines appear to work (see fstruct.e);
 * The unsafe routines have not been used or tested.

    Portions of this file are Copyright (C) 1991 John Lewis

    This file is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

#include <theusual.h>
#include <constants.h>
#include <scheme.h>
#include <assert.h>
#include <zelk.h>

/*%%%%%%%%%%%%%%%% peek/poke in an farray %%%%%%%%%%%%%%%%*/

static void check_offset P_((int,int,int));

/* helper to farray peek/poke */
static void check_offset(off,align,len)
  int off,align,len;
{
  if ((align*off/align) != off)
    Primitive_Error("peek/poke datum is not aligned");
  if ((off < 0) || (off >= len)) Primitive_Error("index out of array");
}


#define FARRAYPEEKTYPE(NAME,SNAME,TYPE,ALIGN) \
Object NAME(F,Off) \
  Object F,Off; \
{\
  int4 off;\
  Farray *f;\
  char *adr;\
  int size;\
  Error_Tag = SNAME;\
  \
  Check_Type(F,T_Farray);\
  off = Get_Integer(Off);\
  f = FARRAY(F);\
  switch(f->type) {\
    case T_String: size = 1; break;\
    default: size = 4; break;\
  }\
  check_offset(off,ALIGN,f->len * size);\
  adr = (char *)(f->data);\
  adr += off;\
  \
  return Make_Integer( *((TYPE *)adr) );\
}


#define FARRAY_PEEKINT   P_farray_peekint, "farray%peek-int", 2,2,EVAL,
FARRAYPEEKTYPE(P_farray_peekint,"farray%peek-int", int4, 4)

#define FARRAY_PEEKUINT   P_farray_peekuint, "farray%peek-uint", 2,2,EVAL,
FARRAYPEEKTYPE(P_farray_peekuint,"farray%peek-uint", unsigned int4, 4)

#define FARRAY_PEEKSHORT  P_farray_peekshort, "farray%peek-short", 2,2,EVAL,
FARRAYPEEKTYPE(P_farray_peekshort,"farray%peek-short", short, 2)

#define FARRAY_PEEKUSHORT  P_farray_peekushort, "farray%peek-ushort", 2,2,EVAL,
FARRAYPEEKTYPE(P_farray_peekushort,"farray%peek-ushort", unsigned short, 2)



#define FARRAYPOKETYPE(NAME,SNAME,TYPE,ALIGN) \
Object NAME(F,Off,Value) \
  Object F,Off,Value;\
{\
  int4 off; TYPE val;\
  Farray *f;\
  char *adr;\
  int size;\
  Error_Tag = SNAME ;\
\
  Check_Type(F,T_Farray);\
  off = Get_Integer(Off);\
  val = Get_Integer(Value);\
  f = FARRAY(F);\
  switch(f->type) {\
    case T_String: size = 1; break;\
    default: size = 4; break;\
  }\
  check_offset(off,ALIGN,f->len * size);\
\
  adr = (char *)(f->data);\
  adr += off;\
  *((TYPE *)adr) = val;\
  return Null;\
} /*%poke*/


#define FARRAY_POKEINT  P_farray_pokeint,"farray%poke-int",3,3,EVAL,
FARRAYPOKETYPE(P_farray_pokeint,"farray%poke-int",int4,4)

#define FARRAY_POKEUINT  P_farray_pokeuint,"farray%poke-uint",3,3,EVAL,
FARRAYPOKETYPE(P_farray_pokeuint,"farray%poke-uint",unsigned int4,4)

#define FARRAY_POKESHORT  P_farray_pokeshort,"farray%poke-short",3,3,EVAL,
FARRAYPOKETYPE(P_farray_pokeshort,"farray%poke-short",short,2)

#define FARRAY_POKEUSHORT  P_farray_pokeushort,"farray%poke-ushort",3,3,EVAL,
FARRAYPOKETYPE(P_farray_pokeushort,"farray%poke-ushort",unsigned short,2)

/*%%%%%%%%%%%%%%%% unsafe peek/poke %%%%%%%%%%%%%%%%*/

/* helper to unsafe peek/poke */
static void check_align P_((char *,int));
static void check_align(off,align)
  char *off;
  int align;
{
  int4 ioff = (int4)off;
  if ((align*ioff/align) != ioff)
    Primitive_Error("peek/poke datum is not aligned");
}

#define UNSAFEPEEKTYPE(NAME,SNAME,TYPE,ALIGN) \
Object NAME(Addr,Off) \
  Object Addr,Off; \
{\
  char *addr; int4 off;\
  Error_Tag = SNAME;\
\
  addr = (char *)Get_Integer(Addr);\
  off = Get_Integer(Off);\
  addr += off;\
  check_align((char *)addr,ALIGN);\
\
  return Make_Integer(*((TYPE *)addr));\
}


#define UNSAFE_PEEKINT   P_unsafe_peekint, "%peek-int", 2,2,EVAL,
UNSAFEPEEKTYPE(P_unsafe_peekint,"%peek-int", int4, 4)

#define UNSAFE_PEEKUINT   P_unsafe_peekuint, "%peek-uint", 2,2,EVAL,
UNSAFEPEEKTYPE(P_unsafe_peekuint,"%peek-uint", unsigned int4, 4)

#define UNSAFE_PEEKSHORT  P_unsafe_peekshort, "%peek-short", 2,2,EVAL,
UNSAFEPEEKTYPE(P_unsafe_peekshort,"%peek-short", short, 2)

#define UNSAFE_PEEKUSHORT  P_unsafe_peekushort, "%peek-ushort", 2,2,EVAL,
UNSAFEPEEKTYPE(P_unsafe_peekushort,"%peek-ushort", unsigned short, 2)

#define UNSAFE_PEEKCHAR  P_unsafe_peekchar, "%peek-char", 2,2,EVAL,
UNSAFEPEEKTYPE(P_unsafe_peekchar,"%peek-char", char, 1)

#define UNSAFE_PEEKUCHAR  P_unsafe_peekuchar, "%peek-uchar", 2,2,EVAL,
UNSAFEPEEKTYPE(P_unsafe_peekuchar,"%peek-uchar", unsigned char, 1)



#define UNSAFEPOKETYPE(NAME,SNAME,TYPE,ALIGN) \
Object NAME(Addr,Off,Value) \
Object Addr,Off,Value;\
{\
  int4 off; TYPE val;\
  char *addr;\
  Error_Tag = SNAME ;\
\
  addr = (char *)Get_Integer(Addr);\
  off = Get_Integer(Off);\
  addr += off;\
  check_align((char *)addr,ALIGN);\
  val = Get_Integer(Value);\
\
  *((TYPE *)addr) = val;\
  return Null;\
} /*unsafe%poke*/


#define UNSAFE_POKEINT   P_unsafe_pokeint, "%poke-int", 3,3,EVAL,
UNSAFEPOKETYPE(P_unsafe_pokeint,"%poke-int", int4, 4)

#define UNSAFE_POKEUINT   P_unsafe_pokeuint, "%poke-uint", 3,3,EVAL,
UNSAFEPOKETYPE(P_unsafe_pokeuint,"%poke-uint", unsigned int4, 4)

#define UNSAFE_POKESHORT  P_unsafe_pokeshort, "%poke-short", 3,3,EVAL,
UNSAFEPOKETYPE(P_unsafe_pokeshort,"%poke-short", short, 2)

#define UNSAFE_POKEUSHORT  P_unsafe_pokeushort, "%poke-ushort", 3,3,EVAL,
UNSAFEPOKETYPE(P_unsafe_pokeushort,"%poke-ushort", unsigned short, 2)

#define UNSAFE_POKECHAR  P_unsafe_pokechar, "%poke-char", 3,3,EVAL,
UNSAFEPOKETYPE(P_unsafe_pokechar,"%poke-char", char, 1)

#define UNSAFE_POKEUCHAR  P_unsafe_pokeuchar, "%poke-uchar", 3,3,EVAL,
UNSAFEPOKETYPE(P_unsafe_pokeuchar,"%poke-uchar", unsigned char, 1)


/*%%%% these should go into zelk.c if fstructs work out %%%%*/

#include <sys/stat.h>
#define LINK_STAT  { "os-stat",  (vfunction *)stat, "SARI" },

static struct fordef fortab[] = {
  LINK_STAT
  {(char *)0, (vfunction *)0, (char *)0}
};


/*%%%%%%%%%%%%%%%% link %%%%%%%%%%%%%%%%*/

static struct primdef Prims[] = {
  FARRAY_PEEKINT
  FARRAY_PEEKUINT
  FARRAY_POKEINT
  FARRAY_POKEUINT

  FARRAY_PEEKSHORT
  FARRAY_PEEKUSHORT
  FARRAY_POKESHORT
  FARRAY_POKEUSHORT

  UNSAFE_PEEKINT
  UNSAFE_PEEKUINT
  UNSAFE_PEEKSHORT
  UNSAFE_PEEKUSHORT
  UNSAFE_PEEKCHAR
  UNSAFE_PEEKUCHAR

  UNSAFE_POKEINT
  UNSAFE_POKEUINT
  UNSAFE_POKESHORT
  UNSAFE_POKEUSHORT
  UNSAFE_POKECHAR
  UNSAFE_POKEUCHAR

  (Object (*)())0, (char *)0, 0,0,EVAL
};


void Init_peekpoke()
{
  ZLprimdeftab(Prims);
  Define_Fortab(fortab);
  P_Provide(Intern("pokepoke.o"));
} /*init*/
