view release on metacpan or  search on metacpan

hugs98-Nov2003/src/builtin.h  view on Meta::CPAN

/* --------------------------------------------------------------------------
 * Primitive functions, input output etc...
 *
 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
 * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU,
 * 1994-2003, All rights reserved.  It is distributed as free software under
 * the license in the file "License", which is included in the distribution.
 *
 * $RCSfile: builtin.h,v $
 * $Revision: 1.5 $
 * $Date: 2003/10/14 13:56:21 $
 * ------------------------------------------------------------------------*/
#ifndef __BUILTIN_H__
#define __BUILTIN_H__

extern String evalName  Args((Cell));
extern Cell   mkIOError Args((Cell,Name,String,String,Cell));

/* --------------------------------------------------------------------------
 * Macros used to define primitives:
 * ------------------------------------------------------------------------*/

#define PROTO_PRIM(name)      static Void name Args((StackPtr))
#define EXT_PROTO_PRIM(name)  extern Void name Args((StackPtr))
#define primFun(name)         static Void name(root) StackPtr root;
#define extPrimFun(name)      Void name(StackPtr root)
#define primCAF(name)         static Void name(root) StackPtr root HUGS_unused;
#define primArg(n)            stack(root+n)

/* IMPORTANT: the second element of an update must be written first.
 * this is to deal with the case where an INDIRECT tag is written into
 * a Cell before the second value has been set.  If a garbage collection
 * occurs before the second element was set then the INDIRECTion will be
 * (wrongly) elided and result in chaos.  I know.  It happened to me.
 */

#define update(l,r)             ((snd(stack(root))=r),(fst(stack(root))=l))
#define updateRoot(c)           update(INDIRECT,c)
#define updapRoot(l,r)          update(l,r)
#define blackHoleRoot()         update(nameBlackHole,nameBlackHole)

#if CHECK_TAGS

# define checkChar()  if (!isChar(whnfHead))  internal("Char expected")
# define checkInt()   if (!isInt(whnfHead))   internal("Int expected")
# define checkWord()  if (!isInt(whnfHead))   internal("Word expected")
# define checkPtr()   if (!isPtr(whnfHead))   internal("Ptr expected")
# define checkFloat() if (!isFloat(whnfHead)) internal("Float expected")
# define checkDouble() if (!isDouble(whnfHead)) internal("Double expected")

# define checkBool()  if (whnfHead != nameTrue && whnfHead != nameFalse) internal("Bool expected");

# define checkCon()   if (!isName(whnfHead) || !isCfun(whnfHead)) internal("Constructor expected");

#else

# define checkChar()  doNothing()
# define checkInt()   doNothing()
# define checkWord()  doNothing()
# define checkPtr()   doNothing()
# define checkFloat() doNothing()
# define checkDouble() doNothing()
# define checkBool()  doNothing()
# define checkCon()   doNothing()

#endif

/* e is a constant expression                     */
#define CAFPtr(nm,e)                               \
  primCAF(nm) {                                    \
      Pointer r = e;                               \
      push(mkPtr(r));                              \
  }

#define PtrArg(nm,offset)                          \
    eval(primArg(offset));                         \
    checkPtr();                                    \
    nm = ptrOf(whnfHead)

/* nm should be a variable in which result is stored.