xref: /dports/x11/xedit/xedit-1.2.2/lisp/lisp.c

/*
 * Copyright (c) 2001 by The XFree86 Project, Inc.
 *
 * Permission is hereby granted, free of charge, to any person obtaining a
 * copy of this software and associated documentation files (the "Software"),
 * to deal in the Software without restriction, including without limitation
 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
 * and/or sell copies of the Software, and to permit persons to whom the
 * Software is furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be included in
 * all copies or substantial portions of the Software.
 *
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 * SOFTWARE.
 *
 * Except as contained in this notice, the name of the XFree86 Project shall
 * not be used in advertising or otherwise to promote the sale, use or other
 * dealings in this Software without prior written authorization from the
 * XFree86 Project.
 *
 * Author: Paulo César Pereira de Andrade
 */

/* $XFree86: xc/programs/xedit/lisp/lisp.c,v 1.87tsi Exp $ */

#ifdef HAVE_CONFIG_H
# include "config.h"
#endif

#include <stdlib.h>
#include <string.h>
#ifdef sun
#include <strings.h>
#endif
#include <ctype.h>
#include <errno.h>
#include <fcntl.h>
#include <stdarg.h>
#include <signal.h>
#include <sys/wait.h>

#ifndef X_NOT_POSIX
#include <unistd.h>	/* for sysconf(), and getpagesize() */
#endif

#include "lisp/bytecode.h"

#include "lisp/read.h"
#include "lisp/format.h"
#include "lisp/math.h"
#include "lisp/hash.h"
#include "lisp/package.h"
#include "lisp/pathname.h"
#include "lisp/regex.h"
#include "lisp/require.h"
#include "lisp/stream.h"
#include "lisp/struct.h"
#include "lisp/time.h"
#include "lisp/write.h"
#include <math.h>

typedef struct {
    LispObj **objects;
    LispObj *freeobj;
    int nsegs;
    int nobjs;
    int nfree;
} LispObjSeg;

/*
 * Prototypes
 */
static void Lisp__GC(LispObj*, LispObj*);
static LispObj *Lisp__New(LispObj*, LispObj*);

/* run a user function, to be called only by LispEval */
static LispObj *LispRunFunMac(LispObj*, LispObj*, int, int);

/* expands and executes a setf method, to be called only by Lisp_Setf */
LispObj *LispRunSetf(LispArgList*, LispObj*, LispObj*, LispObj*);
LispObj *LispRunSetfMacro(LispAtom*, LispObj*, LispObj*);

/* increases storage size for environment */
void LispMoreEnvironment(void);

/* increases storage size for stack of builtin arguments */
void LispMoreStack(void);

/* increases storage size for global variables */
void LispMoreGlobals(LispPackage*);

#ifdef __GNUC__
static INLINE LispObj *LispDoGetVar(LispObj*);
#endif
static INLINE void LispDoAddVar(LispObj*, LispObj*);

/* Helper for importing symbol(s) functions,
 * Search for the specified object in the current package */
static INLINE LispObj *LispGetVarPack(LispObj*);

/* create environment for function call */
static int LispMakeEnvironment(LispArgList*, LispObj*, LispObj*, int, int);

	/* if not already in keyword package, move atom to keyword package */
static LispObj *LispCheckKeyword(LispObj*);

	/* builtin backquote parsing */
static LispObj *LispEvalBackquoteObject(LispObj*, int, int);
	/* used also by the bytecode compiler */
LispObj *LispEvalBackquote(LispObj*, int);

	/* create or change object property */
void LispSetAtomObjectProperty(LispAtom*, LispObj*);
	/* remove object property */
static void LispRemAtomObjectProperty(LispAtom*);

	/* allocates a new LispProperty for the given atom */
static void LispAllocAtomProperty(LispAtom*);
	/* Increment reference count of atom property */
static void LispIncrementAtomReference(LispAtom*);
	/* Decrement reference count of atom property */
static void LispDecrementAtomReference(LispAtom*);
	/* Removes all atom properties */
static void LispRemAtomAllProperties(LispAtom*);

static LispObj *LispAtomPropertyFunction(LispAtom*, LispObj*, int);

static INLINE void LispCheckMemLevel(void);

void LispAllocSeg(LispObjSeg*, int);
static INLINE void LispMark(LispObj*);

/* functions, macros, setf methods, and structure definitions */
static INLINE void LispProt(LispObj*);

static LispObj *LispCheckNeedProtect(LispObj*);

static void LispSignalHandler(int);

/*
 * Initialization
 */
LispMac lisp__data;

static LispObj lispunbound = {LispNil_t};
LispObj *UNBOUND = &lispunbound;

static volatile int lisp__disable_int;
static volatile int lisp__interrupted;

LispObj *Okey, *Orest, *Ooptional, *Oaux, *Olambda;

Atom_id Snil, St;
Atom_id Saux, Skey, Soptional, Srest;
Atom_id Satom, Ssymbol, Sinteger, Scharacter, Sstring, Slist,
	Scons, Svector, Sarray, Sstruct, Skeyword, Sfunction, Spathname,
	Srational, Sfloat, Scomplex, Sopaque, Sdefault;

LispObj *Oformat, *Kunspecific;
LispObj *Oexpand_setf_method;

static LispProperty noproperty;
LispProperty *NOPROPERTY = &noproperty;
static int segsize, minfree;
int pagesize, gcpro;

static LispObjSeg objseg = {NULL, NIL};
static LispObjSeg atomseg = {NULL, NIL};

int LispArgList_t;

LispFile *Stdout, *Stdin, *Stderr;

static LispBuiltin lispbuiltins[] = {
    {LispFunction, Lisp_Mul, "* &rest numbers"},
    {LispFunction, Lisp_Plus, "+ &rest numbers"},
    {LispFunction, Lisp_Minus, "- number &rest more-numbers"},
    {LispFunction, Lisp_Div, "/ number &rest more-numbers"},
    {LispFunction, Lisp_OnePlus, "1+ number"},
    {LispFunction, Lisp_OneMinus, "1- number"},
    {LispFunction, Lisp_Less, "< number &rest more-numbers"},
    {LispFunction, Lisp_LessEqual, "<= number &rest more-numbers"},
    {LispFunction, Lisp_Equal_, "= number &rest more-numbers"},
    {LispFunction, Lisp_Greater, "> number &rest more-numbers"},
    {LispFunction, Lisp_GreaterEqual, ">= number &rest more-numbers"},
    {LispFunction, Lisp_NotEqual, "/= number &rest more-numbers"},
    {LispFunction, Lisp_Max, "max number &rest more-numbers"},
    {LispFunction, Lisp_Min, "min number &rest more-numbers"},
    {LispFunction, Lisp_Abs, "abs number"},
    {LispFunction, Lisp_Acons, "acons key datum alist"},
    {LispFunction, Lisp_Adjoin, "adjoin item list &key key test test-not"},
    {LispFunction, Lisp_AlphaCharP, "alpha-char-p char"},
    {LispMacro, Lisp_And, "and &rest args", 1, 0, Com_And},
    {LispFunction, Lisp_Append, "append &rest lists"},
    {LispFunction, Lisp_Apply, "apply function arg &rest more-args", 1},
    {LispFunction, Lisp_Aref, "aref array &rest subscripts"},
    {LispFunction, Lisp_Assoc, "assoc item list &key test test-not key"},
    {LispFunction, Lisp_AssocIf, "assoc-if predicate list &key key"},
    {LispFunction, Lisp_AssocIfNot, "assoc-if-not predicate list &key key"},
    {LispFunction, Lisp_Atom, "atom object"},
    {LispMacro, Lisp_Block, "block name &rest body", 1, 0, Com_Block},
    {LispFunction, Lisp_BothCaseP, "both-case-p character"},
    {LispFunction, Lisp_Boundp, "boundp symbol"},
    {LispFunction, Lisp_Butlast, "butlast list &optional count"},
    {LispFunction, Lisp_Nbutlast, "nbutlast list &optional count"},
    {LispFunction, Lisp_Car, "car list", 0, 0, Com_C_r},
    {LispFunction, Lisp_Car, "first list", 0, 0, Com_C_r},
    {LispMacro, Lisp_Case, "case keyform &rest body"},
    {LispMacro, Lisp_Catch, "catch tag &rest body", 1},
    {LispFunction, Lisp_Cdr, "cdr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_Cdr, "rest list", 0, 0, Com_C_r},
    {LispFunction, Lisp_Ceiling, "ceiling number &optional divisor", 1},
    {LispFunction, Lisp_Fceiling, "fceiling number &optional divisor", 1},
    {LispFunction, Lisp_Char, "char string index"},
    {LispFunction, Lisp_Char, "schar simple-string index"},
    {LispFunction, Lisp_CharLess, "char< character &rest more-characters"},
    {LispFunction, Lisp_CharLessEqual, "char<= character &rest more-characters"},
    {LispFunction, Lisp_CharEqual_, "char= character &rest more-characters"},
    {LispFunction, Lisp_CharGreater, "char> character &rest more-characters"},
    {LispFunction, Lisp_CharGreaterEqual, "char>= character &rest more-characters"},
    {LispFunction, Lisp_CharNotEqual_, "char/= character &rest more-characters"},
    {LispFunction, Lisp_CharLessp, "char-lessp character &rest more-characters"},
    {LispFunction, Lisp_CharNotGreaterp, "char-not-greaterp character &rest more-characters"},
    {LispFunction, Lisp_CharEqual, "char-equal character &rest more-characters"},
    {LispFunction, Lisp_CharGreaterp, "char-greaterp character &rest more-characters"},
    {LispFunction, Lisp_CharNotLessp, "char-not-lessp character &rest more-characters"},
    {LispFunction, Lisp_CharNotEqual, "char-not-equal character &rest more-characters"},
    {LispFunction, Lisp_CharDowncase, "char-downcase character"},
    {LispFunction, Lisp_CharInt, "char-code character"},
    {LispFunction, Lisp_CharInt, "char-int character"},
    {LispFunction, Lisp_CharUpcase, "char-upcase character"},
    {LispFunction, Lisp_Character, "character object"},
    {LispFunction, Lisp_Characterp, "characterp object"},
    {LispFunction, Lisp_Clrhash, "clrhash hash-table"},
    {LispFunction, Lisp_IntChar, "code-char integer"},
    {LispFunction, Lisp_Coerce, "coerce object result-type"},
    {LispFunction, Lisp_Compile, "compile name &optional definition", 1},
    {LispFunction, Lisp_Complex, "complex realpart &optional imagpart"},
    {LispMacro, Lisp_Cond, "cond &rest body", 0, 0, Com_Cond},
    {LispFunction, Lisp_Cons, "cons car cdr", 0, 0, Com_Cons},
    {LispFunction, Lisp_Consp, "consp object", 0, 0, Com_Consp},
    {LispFunction, Lisp_Constantp, "constantp form &optional environment"},
    {LispFunction, Lisp_Conjugate, "conjugate number"},
    {LispFunction, Lisp_Complexp, "complexp object"},
    {LispFunction, Lisp_CopyAlist, "copy-alist list"},
    {LispFunction, Lisp_CopyList, "copy-list list"},
    {LispFunction, Lisp_CopyTree, "copy-tree list"},
    {LispFunction, Lisp_Close, "close stream &key abort"},
    {LispFunction, Lisp_C_r, "caar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cadr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cdar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cddr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "caaar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "caadr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cadar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "caddr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cdaar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cdadr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cddar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cdddr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "caaaar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "caaadr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "caadar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "caaddr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cadaar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cadadr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "caddar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cadddr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cdaaar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cdaadr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cdadar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cdaddr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cddaar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cddadr list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cdddar list", 0, 0, Com_C_r},
    {LispFunction, Lisp_C_r, "cddddr list", 0, 0, Com_C_r},
    {LispMacro, Lisp_Decf, "decf place &optional delta"},
    {LispMacro, Lisp_Defconstant, "defconstant name initial-value &optional documentation"},
    {LispMacro, Lisp_Defmacro, "defmacro name lambda-list &rest body"},
    {LispMacro, Lisp_Defstruct, "defstruct name &rest description"},
    {LispMacro, Lisp_Defun, "defun name lambda-list &rest body"},
    {LispMacro, Lisp_Defsetf, "defsetf function lambda-list &rest body"},
    {LispMacro, Lisp_Defparameter, "defparameter name initial-value &optional documentation"},
    {LispMacro, Lisp_Defvar, "defvar name &optional initial-value documentation"},
    {LispFunction, Lisp_Delete, "delete item sequence &key from-end test test-not start end count key"},
    {LispFunction, Lisp_DeleteDuplicates, "delete-duplicates sequence &key from-end test test-not start end key"},
    {LispFunction, Lisp_DeleteIf, "delete-if predicate sequence &key from-end start end count key"},
    {LispFunction, Lisp_DeleteIfNot, "delete-if-not predicate sequence &key from-end start end count key"},
    {LispFunction, Lisp_DeleteFile, "delete-file filename"},
    {LispFunction, Lisp_Denominator, "denominator rational"},
    {LispFunction, Lisp_DigitChar, "digit-char weight &optional radix"},
    {LispFunction, Lisp_DigitCharP, "digit-char-p character &optional radix"},
    {LispFunction, Lisp_Directory, "directory pathname &key all if-cannot-read"},
    {LispFunction, Lisp_DirectoryNamestring, "directory-namestring pathname"},
    {LispFunction, Lisp_Disassemble, "disassemble function"},
    {LispMacro, Lisp_Do, "do init test &rest body"},
    {LispMacro, Lisp_DoP, "do* init test &rest body"},
    {LispFunction, Lisp_Documentation, "documentation symbol type"},
    {LispMacro, Lisp_DoList, "dolist init &rest body", 0, 0, Com_Dolist},
    {LispMacro, Lisp_DoTimes, "dotimes init &rest body"},
    {LispMacro, Lisp_DoAllSymbols, "do-all-symbols init &rest body"},
    {LispMacro, Lisp_DoExternalSymbols, "do-external-symbols init &rest body"},
    {LispMacro, Lisp_DoSymbols, "do-symbols init &rest body"},
    {LispFunction, Lisp_Elt, "elt sequence index"},
    {LispFunction, Lisp_Endp, "endp object"},
    {LispFunction, Lisp_EnoughNamestring, "enough-namestring pathname &optional defaults"},
    {LispFunction, Lisp_Eq, "eq left right", 0, 0, Com_Eq},
    {LispFunction, Lisp_Eql, "eql left right", 0, 0, Com_Eq},
    {LispFunction, Lisp_Equal, "equal left right", 0, 0, Com_Eq},
    {LispFunction, Lisp_Equalp, "equalp left right", 0, 0, Com_Eq},
    {LispFunction, Lisp_Error, "error control-string &rest arguments"},
    {LispFunction, Lisp_Evenp, "evenp integer"},
    {LispFunction, Lisp_Export, "export symbols &optional package"},
    {LispFunction, Lisp_Eval, "eval form"},
    {LispFunction, Lisp_Every, "every predicate sequence &rest more-sequences"},
    {LispFunction, Lisp_Some, "some predicate sequence &rest more-sequences"},
    {LispFunction, Lisp_Notevery, "notevery predicate sequence &rest more-sequences"},
    {LispFunction, Lisp_Notany, "notany predicate sequence &rest more-sequences"},
    {LispFunction, Lisp_Fboundp, "fboundp symbol"},
    {LispFunction, Lisp_Find, "find item sequence &key from-end test test-not start end key"},
    {LispFunction, Lisp_FindIf, "find-if predicate sequence &key from-end start end key"},
    {LispFunction, Lisp_FindIfNot, "find-if-not predicate sequence &key from-end start end key"},
    {LispFunction, Lisp_FileNamestring, "file-namestring pathname"},
    {LispFunction, Lisp_Fill, "fill sequence item &key start end"},
    {LispFunction, Lisp_FindAllSymbols, "find-all-symbols string-or-symbol"},
    {LispFunction, Lisp_FindSymbol, "find-symbol string &optional package", 1},
    {LispFunction, Lisp_FindPackage, "find-package name"},
    {LispFunction, Lisp_Float, "float number &optional other"},
    {LispFunction, Lisp_Floatp, "floatp object"},
    {LispFunction, Lisp_Floor, "floor number &optional divisor", 1},
    {LispFunction, Lisp_Ffloor, "ffloor number &optional divisor", 1},
    {LispFunction, Lisp_Fmakunbound, "fmakunbound symbol"},
    {LispFunction, Lisp_Format, "format destination control-string &rest arguments"},
    {LispFunction, Lisp_FreshLine, "fresh-line &optional output-stream"},
    {LispFunction, Lisp_Funcall, "funcall function &rest arguments", 1},
    {LispFunction, Lisp_Functionp, "functionp object"},
    {LispFunction, Lisp_Gc, "gc &optional car cdr"},
    {LispFunction, Lisp_Gcd, "gcd &rest integers"},
    {LispFunction, Lisp_Gensym, "gensym &optional arg"},
    {LispFunction, Lisp_Get, "get symbol indicator &optional default"},
    {LispFunction, Lisp_Gethash, "gethash key hash-table &optional default", 1},
    {LispMacro, Lisp_Go, "go tag", 0, 0, Com_Go},
    {LispFunction, Lisp_GraphicCharP, "graphic-char-p char"},
    {LispFunction, Lisp_HashTableP, "hash-table-p object"},
    {LispFunction, Lisp_HashTableCount, "hash-table-count hash-table"},
    {LispFunction, Lisp_HashTableRehashSize, "hash-table-rehash-size hash-table"},
    {LispFunction, Lisp_HashTableRehashThreshold, "hash-table-rehash-threshold hash-table"},
    {LispFunction, Lisp_HashTableSize, "hash-table-size hash-table"},
    {LispFunction, Lisp_HashTableTest, "hash-table-test hash-table"},
    {LispFunction, Lisp_HostNamestring, "host-namestring pathname"},
    {LispMacro, Lisp_If, "if test then &optional else", 0, 0, Com_If},
    {LispMacro, Lisp_IgnoreErrors, "ignore-errors &rest body", 1},
    {LispFunction, Lisp_Imagpart, "imagpart number"},
    {LispMacro, Lisp_InPackage, "in-package name"},
    {LispMacro, Lisp_Incf, "incf place &optional delta"},
    {LispFunction, Lisp_Import, "import symbols &optional package"},
    {LispFunction, Lisp_InputStreamP, "input-stream-p stream"},
    {LispFunction, Lisp_IntChar, "int-char integer"},
    {LispFunction, Lisp_Integerp, "integerp object"},
    {LispFunction, Lisp_Intern, "intern string &optional package", 1},
    {LispFunction, Lisp_Intersection, "intersection list1 list2 &key test test-not key"},
    {LispFunction, Lisp_Nintersection, "nintersection list1 list2 &key test test-not key"},
    {LispFunction, Lisp_Isqrt, "isqrt natural"},
    {LispFunction, Lisp_Keywordp, "keywordp object"},
    {LispFunction, Lisp_Last, "last list &optional count", 0, 0, Com_Last},
    {LispMacro, Lisp_Lambda, "lambda lambda-list &rest body"},
    {LispFunction, Lisp_Lcm, "lcm &rest integers"},
    {LispFunction, Lisp_Length, "length sequence", 0, 0, Com_Length},
    {LispMacro, Lisp_Let, "let init &rest body", 1, 0, Com_Let},
    {LispMacro, Lisp_LetP, "let* init &rest body", 1, 0, Com_Letx},
    {LispFunction, Lisp_ListP, "list* object &rest more-objects"},
    {LispFunction, Lisp_ListAllPackages, "list-all-packages"},
    {LispFunction, Lisp_List, "list &rest args"},
    {LispFunction, Lisp_ListLength, "list-length list"},
    {LispFunction, Lisp_Listp, "listp object", 0, 0, Com_Listp},
    {LispFunction, Lisp_Listen, "listen &optional input-stream"},
    {LispFunction, Lisp_Load, "load filename &key verbose print if-does-not-exist"},
    {LispFunction, Lisp_Logand, "logand &rest integers"},
    {LispFunction, Lisp_Logeqv, "logeqv &rest integers"},
    {LispFunction, Lisp_Logior, "logior &rest integers"},
    {LispFunction, Lisp_Lognot, "lognot integer"},
    {LispFunction, Lisp_Logxor, "logxor &rest integers"},
    {LispMacro, Lisp_Loop, "loop &rest body", 0, 0, Com_Loop},
    {LispFunction, Lisp_LowerCaseP, "lower-case-p character"},
    {LispFunction, Lisp_MakeArray, "make-array dimensions &key element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset"},
    {LispFunction, Lisp_MakeHashTable, "make-hash-table &key test size rehash-size rehash-threshold initial-contents"},
    {LispFunction, Lisp_MakeList, "make-list size &key initial-element"},
    {LispFunction, Lisp_MakePackage, "make-package package-name &key nicknames use"},
    {LispFunction, Lisp_MakePathname, "make-pathname &key host device directory name type version defaults"},
    {LispFunction, Lisp_MakeString, "make-string size &key initial-element element-type"},
    {LispFunction, Lisp_MakeSymbol, "make-symbol name"},
    {LispFunction, Lisp_MakeStringInputStream, "make-string-input-stream string &optional start end"},
    {LispFunction, Lisp_MakeStringOutputStream, "make-string-output-stream &key element-type"},
    {LispFunction, Lisp_GetOutputStreamString, "get-output-stream-string string-output-stream"},
    {LispFunction, Lisp_Makunbound, "makunbound symbol"},
    {LispFunction, Lisp_Mapc, "mapc function list &rest more-lists"},
    {LispFunction, Lisp_Mapcar, "mapcar function list &rest more-lists"},
    {LispFunction, Lisp_Mapcan, "mapcan function list &rest more-lists"},
    {LispFunction, Lisp_Maphash, "maphash function hash-table"},
    {LispFunction, Lisp_Mapl, "mapl function list &rest more-lists"},
    {LispFunction, Lisp_Maplist, "maplist function list &rest more-lists"},
    {LispFunction, Lisp_Mapcon, "mapcon function list &rest more-lists"},
    {LispFunction, Lisp_Member, "member item list &key test test-not key"},
    {LispFunction, Lisp_MemberIf, "member-if predicate list &key key"},
    {LispFunction, Lisp_MemberIfNot, "member-if-not predicate list &key key"},
    {LispFunction, Lisp_Minusp, "minusp number"},
    {LispFunction, Lisp_Mod, "mod number divisor"},
    {LispMacro, Lisp_MultipleValueBind, "multiple-value-bind symbols values &rest body"},
    {LispMacro, Lisp_MultipleValueCall, "multiple-value-call function &rest form", 1},
    {LispMacro, Lisp_MultipleValueProg1, "multiple-value-prog1 first-form &rest form", 1},
    {LispMacro, Lisp_MultipleValueList, "multiple-value-list form"},
    {LispMacro, Lisp_MultipleValueSetq, "multiple-value-setq symbols form"},
    {LispFunction, Lisp_Nconc, "nconc &rest lists"},
    {LispFunction, Lisp_Nreverse, "nreverse sequence"},
    {LispFunction, Lisp_NsetDifference, "nset-difference list1 list2 &key test test-not key"},
    {LispFunction, Lisp_Nsubstitute, "nsubstitute newitem olditem sequence &key from-end test test-not start end count key"},
    {LispFunction, Lisp_NsubstituteIf, "nsubstitute-if newitem test sequence &key from-end start end count key"},
    {LispFunction, Lisp_NsubstituteIfNot, "nsubstitute-if-not newitem test sequence &key from-end start end count key"},
    {LispFunction, Lisp_Nth, "nth index list"},
    {LispFunction, Lisp_Nthcdr, "nthcdr index list", 0, 0, Com_Nthcdr},
    {LispMacro, Lisp_NthValue, "nth-value index form"},
    {LispFunction, Lisp_Numerator, "numerator rational"},
    {LispFunction, Lisp_Namestring, "namestring pathname"},
    {LispFunction, Lisp_Null, "not arg", 0, 0, Com_Null},
    {LispFunction, Lisp_Null, "null list", 0, 0, Com_Null},
    {LispFunction, Lisp_Numberp, "numberp object", 0, 0, Com_Numberp},
    {LispFunction, Lisp_Oddp, "oddp integer"},
    {LispFunction, Lisp_Open, "open filename &key direction element-type if-exists if-does-not-exist external-format"},
    {LispFunction, Lisp_OpenStreamP, "open-stream-p stream"},
    {LispMacro, Lisp_Or, "or &rest args", 1, 0, Com_Or},
    {LispFunction, Lisp_OutputStreamP, "output-stream-p stream"},
    {LispFunction, Lisp_Packagep, "packagep object"},
    {LispFunction, Lisp_PackageName, "package-name package"},
    {LispFunction, Lisp_PackageNicknames, "package-nicknames package"},
    {LispFunction, Lisp_PackageUseList, "package-use-list package"},
    {LispFunction, Lisp_PackageUsedByList, "package-used-by-list package"},
    {LispFunction, Lisp_Pairlis, "pairlis key data &optional alist"},
    {LispFunction, Lisp_ParseInteger, "parse-integer string &key start end radix junk-allowed", 1},
    {LispFunction, Lisp_ParseNamestring, "parse-namestring object &optional host defaults &key start end junk-allowed", 1},
    {LispFunction, Lisp_PathnameHost, "pathname-host pathname"},
    {LispFunction, Lisp_PathnameDevice, "pathname-device pathname"},
    {LispFunction, Lisp_PathnameDirectory, "pathname-directory pathname"},
    {LispFunction, Lisp_PathnameName, "pathname-name pathname"},
    {LispFunction, Lisp_PathnameType, "pathname-type pathname"},
    {LispFunction, Lisp_PathnameVersion, "pathname-version pathname"},
    {LispFunction, Lisp_Pathnamep, "pathnamep object"},
    {LispFunction, Lisp_Plusp, "plusp number"},
    {LispMacro, Lisp_Pop, "pop place"},
    {LispFunction, Lisp_Position, "position item sequence &key from-end test test-not start end key"},
    {LispFunction, Lisp_PositionIf, "position-if predicate sequence &key from-end start end key"},
    {LispFunction, Lisp_PositionIfNot, "position-if-not predicate sequence &key from-end start end key"},
    {LispFunction, Lisp_Prin1, "prin1 object &optional output-stream"},
    {LispFunction, Lisp_Princ, "princ object &optional output-stream"},
    {LispFunction, Lisp_Print, "print object &optional output-stream"},
    {LispFunction, Lisp_ProbeFile, "probe-file pathname"},
    {LispFunction, Lisp_Proclaim, "proclaim declaration"},
    {LispMacro, Lisp_Prog1, "prog1 first &rest body"},
    {LispMacro, Lisp_Prog2, "prog2 first second &rest body"},
    {LispMacro, Lisp_Progn, "progn &rest body", 1, 0, Com_Progn},
    {LispMacro, Lisp_Progv, "progv symbols values &rest body", 1},
    {LispFunction, Lisp_Provide, "provide module"},
    {LispMacro, Lisp_Push, "push item place"},
    {LispMacro, Lisp_Pushnew, "pushnew item place &key key test test-not"},
    {LispFunction, Lisp_Quit, "quit &optional status"},
    {LispMacro, Lisp_Quote, "quote object"},
    {LispFunction, Lisp_Rational, "rational number"},
    {LispFunction, Lisp_Rationalp, "rationalp object"},
    {LispFunction, Lisp_Read, "read &optional input-stream eof-error-p eof-value recursive-p"},
    {LispFunction, Lisp_ReadChar, "read-char &optional input-stream eof-error-p eof-value recursive-p"},
    {LispFunction, Lisp_ReadCharNoHang, "read-char-no-hang &optional input-stream eof-error-p eof-value recursive-p"},
    {LispFunction, Lisp_ReadLine, "read-line &optional input-stream eof-error-p eof-value recursive-p", 1},
    {LispFunction, Lisp_Realpart, "realpart number"},
    {LispFunction, Lisp_Replace, "replace sequence1 sequence2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_ReadFromString, "read-from-string string &optional eof-error-p eof-value &key start end preserve-whitespace", 1},
    {LispFunction, Lisp_Require, "require module &optional pathname"},
    {LispFunction, Lisp_Rem, "rem number divisor"},
    {LispFunction, Lisp_Remhash, "remhash key hash-table"},
    {LispFunction, Lisp_Remove, "remove item sequence &key from-end test test-not start end count key"},
    {LispFunction, Lisp_RemoveDuplicates, "remove-duplicates sequence &key from-end test test-not start end key"},
    {LispFunction, Lisp_RemoveIf, "remove-if predicate sequence &key from-end start end count key"},
    {LispFunction, Lisp_RemoveIfNot, "remove-if-not predicate sequence &key from-end start end count key"},
    {LispFunction, Lisp_Remprop, "remprop symbol indicator"},
    {LispFunction, Lisp_RenameFile, "rename-file filename new-name", 1},
    {LispMacro, Lisp_Return, "return &optional result", 1, 0, Com_Return},
    {LispMacro, Lisp_ReturnFrom, "return-from name &optional result", 1, 0, Com_ReturnFrom},
    {LispFunction, Lisp_Reverse, "reverse sequence"},
    {LispFunction, Lisp_Round, "round number &optional divisor", 1},
    {LispFunction, Lisp_Fround, "fround number &optional divisor", 1},
    {LispFunction, Lisp_Rplaca, "rplaca place value", 0, 0, Com_Rplac_},
    {LispFunction, Lisp_Rplacd, "rplacd place value", 0, 0, Com_Rplac_},
    {LispFunction, Lisp_Search, "search sequence1 sequence2 &key from-end test test-not key start1 start2 end1 end2"},
    {LispFunction, Lisp_Set, "set symbol value"},
    {LispFunction, Lisp_SetDifference, "set-difference list1 list2 &key test test-not key"},
    {LispFunction, Lisp_SetExclusiveOr, "set-exclusive-or list1 list2 &key test test-not key"},
    {LispFunction, Lisp_NsetExclusiveOr, "nset-exclusive-or list1 list2 &key test test-not key"},
    {LispMacro, Lisp_Setf, "setf &rest form"},
    {LispMacro, Lisp_Psetf, "psetf &rest form"},
    {LispMacro, Lisp_SetQ, "setq &rest form", 0, 0, Com_Setq},
    {LispMacro, Lisp_Psetq, "psetq &rest form"},
    {LispFunction, Lisp_Sleep, "sleep seconds"},
    {LispFunction, Lisp_Sort, "sort sequence predicate &key key"},
    {LispFunction, Lisp_Sqrt, "sqrt number"},
    {LispFunction, Lisp_Elt, "svref sequence index"},
    {LispFunction, Lisp_Sort, "stable-sort sequence predicate &key key"},
    {LispFunction, Lisp_Streamp, "streamp object"},
    {LispFunction, Lisp_String, "string object"},
    {LispFunction, Lisp_Stringp, "stringp object"},
    {LispFunction, Lisp_StringEqual_, "string= string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringLess, "string< string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringGreater, "string> string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringLessEqual, "string<= string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringGreaterEqual, "string>= string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringNotEqual_, "string/= string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringConcat, "string-concat &rest strings"},
    {LispFunction, Lisp_StringEqual, "string-equal string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringGreaterp, "string-greaterp string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringNotEqual, "string-not-equal string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringNotGreaterp, "string-not-greaterp string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringNotLessp, "string-not-lessp string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringLessp, "string-lessp string1 string2 &key start1 end1 start2 end2"},
    {LispFunction, Lisp_StringTrim, "string-trim character-bag string"},
    {LispFunction, Lisp_StringLeftTrim, "string-left-trim character-bag string"},
    {LispFunction, Lisp_StringRightTrim, "string-right-trim character-bag string"},
    {LispFunction, Lisp_StringUpcase, "string-upcase string &key start end"},
    {LispFunction, Lisp_NstringUpcase, "nstring-upcase string &key start end"},
    {LispFunction, Lisp_StringDowncase, "string-downcase string &key start end"},
    {LispFunction, Lisp_NstringDowncase, "nstring-downcase string &key start end"},
    {LispFunction, Lisp_StringCapitalize, "string-capitalize string &key start end"},
    {LispFunction, Lisp_NstringCapitalize, "nstring-capitalize string &key start end"},
    {LispFunction, Lisp_Subseq, "subseq sequence start &optional end"},
    {LispFunction, Lisp_Subsetp, "subsetp list1 list2 &key test test-not key"},
    {LispFunction, Lisp_Substitute, "substitute newitem olditem sequence &key from-end test test-not start end count key"},
    {LispFunction, Lisp_SubstituteIf, "substitute-if newitem test sequence &key from-end start end count key"},
    {LispFunction, Lisp_SubstituteIfNot, "substitute-if-not newitem test sequence &key from-end start end count key"},
    {LispFunction, Lisp_SymbolFunction, "symbol-function symbol"},
    {LispFunction, Lisp_SymbolName, "symbol-name symbol"},
    {LispFunction, Lisp_Symbolp, "symbolp object"},
    {LispFunction, Lisp_SymbolPlist, "symbol-plist symbol"},
    {LispFunction, Lisp_SymbolPackage, "symbol-package symbol"},
    {LispFunction, Lisp_SymbolValue, "symbol-value symbol"},
    {LispMacro, Lisp_Tagbody, "tagbody &rest body", 0, 0, Com_Tagbody},
    {LispFunction, Lisp_Terpri, "terpri &optional output-stream"},
    {LispFunction, Lisp_Typep, "typep object type"},
    {LispMacro, Lisp_The, "the value-type form"},
    {LispMacro, Lisp_Throw, "throw tag result", 1},
    {LispMacro, Lisp_Time, "time form"},
    {LispFunction, Lisp_Truename, "truename pathname"},
    {LispFunction, Lisp_TreeEqual, "tree-equal tree-1 tree-2 &key test test-not"},
    {LispFunction, Lisp_Truncate, "truncate number &optional divisor", 1},
    {LispFunction, Lisp_Ftruncate, "ftruncate number &optional divisor", 1},
    {LispFunction, Lisp_Unexport, "unexport symbols &optional package"},
    {LispFunction, Lisp_Union, "union list1 list2 &key test test-not key"},
    {LispFunction, Lisp_Nunion, "nunion list1 list2 &key test test-not key"},
    {LispMacro, Lisp_Unless, "unless test &rest body", 1, 0, Com_Unless},
    {LispFunction, Lisp_UserHomedirPathname, "user-homedir-pathname &optional host"},
    {LispMacro, Lisp_UnwindProtect, "unwind-protect protect &rest cleanup"},
    {LispFunction, Lisp_UpperCaseP, "upper-case-p character"},
    {LispFunction, Lisp_Values, "values &rest objects", 1},
    {LispFunction, Lisp_ValuesList, "values-list list", 1},
    {LispFunction, Lisp_Vector, "vector &rest objects"},
    {LispMacro, Lisp_When, "when test &rest body", 1, 0, Com_When},
    {LispFunction, Lisp_Write, " write object &key case circle escape length level lines pretty readably right-margin stream"},
    {LispFunction, Lisp_WriteChar, "write-char string &optional output-stream"},
    {LispFunction, Lisp_WriteLine, "write-line string &optional output-stream &key start end"},
    {LispFunction, Lisp_WriteString, "write-string string &optional output-stream &key start end"},
    {LispFunction, Lisp_XeditCharStore, "lisp::char-store string index value", 0, 1},
    {LispFunction, Lisp_XeditEltStore, "lisp::elt-store sequence index value", 0, 1},
    {LispFunction, Lisp_XeditMakeStruct, "lisp::make-struct atom &rest init", 0, 1},
    {LispFunction, Lisp_XeditPut, " lisp::put symbol indicator value", 0, 1},
    {LispFunction, Lisp_XeditPuthash, "lisp::puthash key hash-table value", 0, 1},
    {LispFunction, Lisp_XeditSetSymbolPlist, "lisp::set-symbol-plist symbol list", 0, 1},
    {LispFunction, Lisp_XeditStructAccess, "lisp::struct-access atom struct", 0, 1},
    {LispFunction, Lisp_XeditStructType, "lisp::struct-type atom struct", 0, 1},
    {LispFunction, Lisp_XeditStructStore, "lisp::struct-store atom struct value", 0, 1},
    {LispFunction, Lisp_XeditVectorStore, "lisp::vector-store array &rest values", 0, 1},
    {LispFunction, Lisp_XeditDocumentationStore, "lisp::documentation-store symbol type string", 0, 1},
    {LispFunction, Lisp_Zerop, "zerop number"},
};

static LispBuiltin extbuiltins[] = {
    {LispFunction, Lisp_Getenv, "getenv name"},
    {LispFunction, Lisp_MakePipe, "make-pipe command-line &key direction element-type external-format"},
    {LispFunction, Lisp_PipeBroken, "pipe-broken pipe-stream"},
    {LispFunction, Lisp_PipeErrorStream, "pipe-error-stream pipe-stream"},
    {LispFunction, Lisp_PipeInputDescriptor, "pipe-input-descriptor pipe-stream"},
    {LispFunction, Lisp_PipeErrorDescriptor, "pipe-error-descriptor pipe-stream"},
    {LispFunction, Lisp_Recomp, "re-comp pattern &key nospec icase nosub newline"},
    {LispFunction, Lisp_Reexec, "re-exec regex string &key count start end notbol noteol"},
    {LispFunction, Lisp_Rep, "re-p object"},
    {LispFunction, Lisp_Setenv, "setenv name value &optional overwrite"},
    {LispFunction, Lisp_Unsetenv, "unsetenv name"},
    {LispFunction, Lisp_NstringTrim, "nstring-trim character-bag string"},
    {LispFunction, Lisp_NstringLeftTrim, "nstring-left-trim character-bag string"},
    {LispFunction, Lisp_NstringRightTrim, "nstring-right-trim character-bag string"},
    {LispMacro, Lisp_Until, "until test &rest body", 0, 0, Com_Until},
    {LispMacro, Lisp_While, "while test &rest body", 0, 0, Com_While},
};

/* byte code function argument list for functions that don't change it's
 * &REST argument list. */
extern LispObj x_cons[8];

/*
 * Implementation
 */
static int
LispGetPageSize(void)
{
    static int pagesize = -1;

    if (pagesize != -1)
	return pagesize;

    /* Try each supported method in the preferred order */

#if defined(_SC_PAGESIZE) || defined(HAVE_DECL__SC_PAGESIZE)
    pagesize = sysconf(_SC_PAGESIZE);
#endif

#ifdef _SC_PAGE_SIZE
    if (pagesize == -1)
	pagesize = sysconf(_SC_PAGE_SIZE);
#endif

#ifdef HAVE_GETPAGESIZE
    if (pagesize == -1)
	pagesize = getpagesize();
#endif

#ifdef PAGE_SIZE
    if (pagesize == -1)
	pagesize = PAGE_SIZE;
#endif

    if (pagesize < sizeof(LispObj) * 16)
	pagesize = sizeof(LispObj) * 16;	/* need a reasonable sane size */

    return pagesize;
}

void
LispDestroy(const char *fmt, ...)
{
    static char Error[] = "*** ";

    if (!lisp__data.destroyed) {
	char string[128];
	va_list ap;

	va_start(ap, fmt);
	vsnprintf(string, sizeof(string), fmt, ap);
	va_end(ap);

	if (!lisp__data.ignore_errors) {
	    if (Stderr->column)
		LispFputc(Stderr, '\n');
	    LispFputs(Stderr, Error);
	    LispFputs(Stderr, string);
	    LispFputc(Stderr, '\n');
	    LispFflush(Stderr);
	}
	else
	    lisp__data.error_condition = STRING(string);

#ifdef DEBUGGER
	if (lisp__data.debugging) {
	    LispDebugger(LispDebugCallWatch, NIL, NIL);
	    LispDebugger(LispDebugCallFatal, NIL, NIL);
	}
#endif

	lisp__data.destroyed = 1;
	LispBlockUnwind(NULL);
	if (lisp__data.errexit)
	    exit(1);
    }

#ifdef DEBUGGER
    if (lisp__data.debugging) {
	/* when stack variables could be changed, this must be also changed! */
	lisp__data.debug_level = -1;
	lisp__data.debug = LispDebugUnspec;
    }
#endif

    while (lisp__data.mem.level) {
	--lisp__data.mem.level;
	if (lisp__data.mem.mem[lisp__data.mem.level])
	    free(lisp__data.mem.mem[lisp__data.mem.level]);
    }
    lisp__data.mem.index = 0;

    /* If the package was changed and an error happened */
    PACKAGE = lisp__data.savepackage;
    lisp__data.pack = lisp__data.savepack;

    LispTopLevel();

    if (!lisp__data.running) {
	static const char *Fatal = "*** Fatal: nowhere to longjmp.\n";

	LispFputs(Stderr, Fatal);
	LispFflush(Stderr);
	abort();
    }

    siglongjmp(lisp__data.jmp, 1);
}

void
LispContinuable(const char *fmt, ...)
{
    va_list ap;
    char string[128];
    static const char *Error = "*** Error: ";

    if (Stderr->column)
	LispFputc(Stderr, '\n');
    LispFputs(Stderr, Error);
    va_start(ap, fmt);
    vsnprintf(string, sizeof(string), fmt, ap);
    va_end(ap);
    LispFputs(Stderr, string);
    LispFputc(Stderr, '\n');
    LispFputs(Stderr, "Type 'continue' if you want to proceed: ");
    LispFflush(Stderr);

    /* NOTE: does not check if stdin is a tty */
    if (LispFgets(Stdin, string, sizeof(string)) &&
	strcmp(string, "continue\n") == 0)
	return;

    LispDestroy("aborted on continuable error");
}

void
LispMessage(const char *fmt, ...)
{
    va_list ap;
    char string[128];

    if (Stderr->column)
	LispFputc(Stderr, '\n');
    va_start(ap, fmt);
    vsnprintf(string, sizeof(string), fmt, ap);
    va_end(ap);
    LispFputs(Stderr, string);
    LispFputc(Stderr, '\n');
    LispFflush(Stderr);
}

void
LispWarning(const char *fmt, ...)
{
    va_list ap;
    char string[128];
    static const char *Warning = "*** Warning: ";

    if (Stderr->column)
	LispFputc(Stderr, '\n');
    LispFputs(Stderr, Warning);
    va_start(ap, fmt);
    vsnprintf(string, sizeof(string), fmt, ap);
    va_end(ap);
    LispFputs(Stderr, string);
    LispFputc(Stderr, '\n');
    LispFflush(Stderr);
}

void
LispTopLevel(void)
{
    int count;

    COD = NIL;
#ifdef DEBUGGER
    if (lisp__data.debugging) {
	DBG = NIL;
	if (lisp__data.debug == LispDebugFinish)
	    lisp__data.debug = LispDebugUnspec;
	lisp__data.debug_level = -1;
	lisp__data.debug_step = 0;
    }
#endif
    gcpro = 0;
    lisp__data.block.block_level = 0;
    if (lisp__data.block.block_size) {
	while (lisp__data.block.block_size)
	    free(lisp__data.block.block[--lisp__data.block.block_size]);
	free(lisp__data.block.block);
	lisp__data.block.block = NULL;
    }

    lisp__data.destroyed = lisp__data.ignore_errors = 0;

    if (CONSP(lisp__data.input_list)) {
	LispUngetInfo **info, *unget = lisp__data.unget[0];

	while (CONSP(lisp__data.input_list))
	    lisp__data.input_list = CDR(lisp__data.input_list);
	SINPUT = lisp__data.input_list;
	while (lisp__data.nunget > 1)
	    free(lisp__data.unget[--lisp__data.nunget]);
	if ((info = realloc(lisp__data.unget, sizeof(LispUngetInfo*))) != NULL)
	    lisp__data.unget = info;
	lisp__data.unget[0] = unget;
	lisp__data.iunget = 0;
	lisp__data.eof = 0;
    }

    for (count = 0; lisp__data.mem.level;) {
	--lisp__data.mem.level;
	if (lisp__data.mem.mem[lisp__data.mem.level]) {
	    ++count;
#if 0
	    printf("LEAK: %p\n", lisp__data.mem.mem[lisp__data.mem.level]);
#endif
	}
    }
    lisp__data.mem.index = 0;
    if (count)
	LispWarning("%d raw memory pointer(s) left. Probably a leak.", count);

    lisp__data.stack.base = lisp__data.stack.length =
	lisp__data.env.lex = lisp__data.env.length = lisp__data.env.head = 0;
    RETURN_COUNT = 0;
    lisp__data.protect.length = 0;

    lisp__data.savepackage = PACKAGE;
    lisp__data.savepack = lisp__data.pack;

    lisp__disable_int = lisp__interrupted = 0;
}

void
LispGC(LispObj *car, LispObj *cdr)
{
    Lisp__GC(car, cdr);
}

static void
Lisp__GC(LispObj *car, LispObj *cdr)
{
    register LispObj *entry, *last, *freeobj, **pentry, **eentry;
    register int nfree;
    unsigned i, j;
    LispAtom *atom;
    struct timeval start, end;
#ifdef DEBUG
    long sec, msec;
    int count = objseg.nfree;
#else
    long msec;
#endif

    if (gcpro)
	return;

    DISABLE_INTERRUPTS();

    nfree = 0;
    freeobj = NIL;

    ++lisp__data.gc.count;

#ifdef DEBUG
    gettimeofday(&start, NULL);
#else
    if (lisp__data.gc.timebits)
	gettimeofday(&start, NULL);
#endif

    /*  Need to measure timings again to check if it is not better/faster
     * to just mark these fields as any other data, as the interface was
     * changed to properly handle circular lists in the function body itself.
     */
    if (lisp__data.gc.immutablebits) {
	for (j = 0; j < objseg.nsegs; j++) {
	    for (entry = objseg.objects[j], last = entry + segsize;
		 entry < last; entry++)
		entry->prot = 0;
	}
    }

    /* Protect all packages */
    for (entry = PACK; CONSP(entry); entry = CDR(entry)) {
	LispObj *package = CAR(entry);
	LispPackage *pack = package->data.package.package;

	/* Protect cons cell */
	entry->mark = 1;

	/* Protect the package cell */
	package->mark = 1;

	/* Protect package name */
	package->data.package.name->mark = 1;

	/* Protect package nicknames */
	LispMark(package->data.package.nicknames);

	/* Protect global symbols */
	for (pentry = pack->glb.pairs, eentry = pentry + pack->glb.length;
	    pentry < eentry; pentry++)
	    LispMark((*pentry)->data.atom->property->value);

	/* Traverse atom list, protecting properties, and function/structure
	 * definitions if lisp__data.gc.immutablebits set */
	for (atom = (LispAtom *)hash_iter_first(pack->atoms);
	     atom;
	     atom = (LispAtom *)hash_iter_next(pack->atoms)) {
	    if (atom->property != NOPROPERTY) {
		if (atom->a_property)
		    LispMark(atom->property->properties);
		if (lisp__data.gc.immutablebits) {
		    if (atom->a_function || atom->a_compiled)
			LispProt(atom->property->fun.function);
		    if (atom->a_defsetf)
			LispProt(atom->property->setf);
		    if (atom->a_defstruct)
			LispProt(atom->property->structure.definition);
		}
	    }
	}
    }

    /* protect environment */
    for (pentry = lisp__data.env.values,
	 eentry = pentry + lisp__data.env.length;
	 pentry < eentry; pentry++)
	LispMark(*pentry);

    /* protect multiple return values */
    for (pentry = lisp__data.returns.values,
	 eentry = pentry + lisp__data.returns.count;
	 pentry < eentry; pentry++)
	LispMark(*pentry);

    /* protect stack of arguments to builtin functions */
    for (pentry = lisp__data.stack.values,
	 eentry = pentry + lisp__data.stack.length;
	 pentry < eentry; pentry++)
	LispMark(*pentry);

    /* protect temporary data used by builtin functions */
    for (pentry = lisp__data.protect.objects,
	 eentry = pentry + lisp__data.protect.length;
	 pentry < eentry; pentry++)
	LispMark(*pentry);

    for (i = 0; i < sizeof(x_cons) / sizeof(x_cons[0]); i++)
	x_cons[i].mark = 0;

    LispMark(COD);
#ifdef DEBUGGER
    LispMark(DBG);
    LispMark(BRK);
#endif
    LispMark(PRO);
    LispMark(lisp__data.input_list);
    LispMark(lisp__data.output_list);
    LispMark(car);
    LispMark(cdr);

    for (j = 0; j < objseg.nsegs; j++) {
	for (entry = objseg.objects[j], last = entry + segsize;
	     entry < last; entry++) {
	    if (entry->prot)
		continue;
	    else if (entry->mark)
		entry->mark = 0;
	    else {
		switch (XOBJECT_TYPE(entry)) {
		    case LispString_t:
			free(THESTR(entry));
			entry->type = LispCons_t;
			break;
		    case LispStream_t:
			switch (entry->data.stream.type) {
			    case LispStreamString:
				free(SSTREAMP(entry)->string);
				free(SSTREAMP(entry));
				break;
			    case LispStreamFile:
				if (FSTREAMP(entry))
				    LispFclose(FSTREAMP(entry));
				break;
			    case LispStreamPipe:
				/* XXX may need special handling if child hangs */
				if (PSTREAMP(entry)) {
				    if (IPSTREAMP(entry))
					LispFclose(IPSTREAMP(entry));
				    if (OPSTREAMP(entry))
					LispFclose(OPSTREAMP(entry));
				    /* don't bother with error stream, will also
				     * freed in this GC call, maybe just out
				     * of order */
				    if (PIDPSTREAMP(entry) > 0) {
					kill(PIDPSTREAMP(entry), SIGTERM);
					waitpid(PIDPSTREAMP(entry), NULL, 0);
				    }
				    free(PSTREAMP(entry));
				}
				break;
			    default:
				break;
			}
			entry->type = LispCons_t;
			break;
		    case LispBignum_t:
			mpi_clear(entry->data.mp.integer);
			free(entry->data.mp.integer);
			entry->type = LispCons_t;
			break;
		    case LispBigratio_t:
			mpr_clear(entry->data.mp.ratio);
			free(entry->data.mp.ratio);
			entry->type = LispCons_t;
			break;
		    case LispLambda_t:
			if (!SYMBOLP(entry->data.lambda.name))
			    LispFreeArgList((LispArgList*)
				entry->data.lambda.name->data.opaque.data);
			entry->type = LispCons_t;
			break;
		    case LispRegex_t:
			refree(entry->data.regex.regex);
			free(entry->data.regex.regex);
			entry->type = LispCons_t;
			break;
		    case LispBytecode_t:
			free(entry->data.bytecode.bytecode->code);
			free(entry->data.bytecode.bytecode);
			entry->type = LispCons_t;
			break;
		    case LispHashTable_t:
			LispFreeHashTable(entry->data.hash.table);
			entry->type = LispCons_t;
			break;
		    case LispCons_t:
			break;
		    default:
			entry->type = LispCons_t;
			break;
		}
		CDR(entry) = freeobj;
		freeobj = entry;
		++nfree;
	    }
	}
    }

    objseg.nfree = nfree;
    objseg.freeobj = freeobj;

    lisp__data.gc.immutablebits = 0;

#ifdef DEBUG
    gettimeofday(&end, NULL);
    sec = end.tv_sec - start.tv_sec;
    msec = end.tv_usec - start.tv_usec;
    if (msec < 0) {
	--sec;
	msec += 1000000;
    }
    LispMessage("gc: "
		"%ld sec, %ld msec, "
		"%d recovered, %d free, %d protected, %d total",
		sec, msec,
		objseg.nfree - count, objseg.nfree,
		objseg.nobjs - objseg.nfree, objseg.nobjs);
#else
    if (lisp__data.gc.timebits) {
	gettimeofday(&end, NULL);
	if ((msec = end.tv_usec - start.tv_usec) < 0)
	    msec += 1000000;
	lisp__data.gc.gctime += msec;
    }
#endif

    ENABLE_INTERRUPTS();
}

static INLINE void
LispCheckMemLevel(void)
{
    int i;

    /* Check for a free slot before the end. */
    for (i = lisp__data.mem.index; i < lisp__data.mem.level; i++)
	if (lisp__data.mem.mem[i] == NULL) {
	    lisp__data.mem.index = i;
	    return;
	}

    /* Check for a free slot in the beginning */
    for (i = 0; i < lisp__data.mem.index; i++)
	if (lisp__data.mem.mem[i] == NULL) {
	    lisp__data.mem.index = i;
	    return;
	}

    lisp__data.mem.index = lisp__data.mem.level;
    ++lisp__data.mem.level;
    if (lisp__data.mem.index < lisp__data.mem.space)
	/* There is free space to store pointer. */
	return;
    else {
	void **ptr = (void**)realloc(lisp__data.mem.mem,
				     (lisp__data.mem.space + 16) *
				     sizeof(void*));

	if (ptr == NULL)
	    LispDestroy("out of memory");
	lisp__data.mem.mem = ptr;
	lisp__data.mem.space += 16;
    }
}

void
LispMused(void *pointer)
{
    int i;

    DISABLE_INTERRUPTS();
    for (i = lisp__data.mem.index; i >= 0; i--)
	if (lisp__data.mem.mem[i] == pointer) {
	    lisp__data.mem.mem[i] = NULL;
	    lisp__data.mem.index = i;
	    goto mused_done;
	}

    for (i = lisp__data.mem.level - 1; i > lisp__data.mem.index; i--)
	if (lisp__data.mem.mem[i] == pointer) {
	    lisp__data.mem.mem[i] = NULL;
	    lisp__data.mem.index = i;
	    break;
	}

mused_done:
    ENABLE_INTERRUPTS();
}

void *
LispMalloc(size_t size)
{
    void *pointer;

    DISABLE_INTERRUPTS();
    LispCheckMemLevel();
    if ((pointer = malloc(size)) == NULL)
	LispDestroy("out of memory, couldn't allocate %lu bytes",
		    (unsigned long)size);

    lisp__data.mem.mem[lisp__data.mem.index] = pointer;
    ENABLE_INTERRUPTS();

    return (pointer);
}

void *
LispCalloc(size_t nmemb, size_t size)
{
    void *pointer;

    DISABLE_INTERRUPTS();
    LispCheckMemLevel();
    if ((pointer = calloc(nmemb, size)) == NULL)
	LispDestroy("out of memory, couldn't allocate %lu bytes",
		    (unsigned long)size);

    lisp__data.mem.mem[lisp__data.mem.index] = pointer;
    ENABLE_INTERRUPTS();

    return (pointer);
}

void *
LispRealloc(void *pointer, size_t size)
{
    void *ptr;
    int i;

    DISABLE_INTERRUPTS();
    if (pointer != NULL) {
	for (i = lisp__data.mem.index; i >= 0; i--)
	    if (lisp__data.mem.mem[i] == pointer)
		goto index_found;

	for (i = lisp__data.mem.index + 1; i < lisp__data.mem.level; i++)
	    if (lisp__data.mem.mem[i] == pointer)
		goto index_found;

    }
    LispCheckMemLevel();
    i = lisp__data.mem.index;

index_found:
    if ((ptr = realloc(pointer, size)) == NULL)
	LispDestroy("out of memory, couldn't realloc");

    lisp__data.mem.mem[i] = ptr;
    ENABLE_INTERRUPTS();

    return (ptr);
}

char *
LispStrdup(const char *str)
{
    char *ptr = LispMalloc(strlen(str) + 1);

    strcpy(ptr, str);

    return (ptr);
}

void
LispFree(void *pointer)
{
    int i;

    DISABLE_INTERRUPTS();
    for (i = lisp__data.mem.index; i >= 0; i--)
	if (lisp__data.mem.mem[i] == pointer) {
	    lisp__data.mem.mem[i] = NULL;
	    lisp__data.mem.index = i;
	    goto free_done;
	}

    for (i = lisp__data.mem.level - 1; i > lisp__data.mem.index; i--)
	if (lisp__data.mem.mem[i] == pointer) {
	    lisp__data.mem.mem[i] = NULL;
	    lisp__data.mem.index = i;
	    break;
	}

free_done:
    free(pointer);
    ENABLE_INTERRUPTS();
}

LispObj *
LispSetVariable(LispObj *var, LispObj *val, const char *fname, int eval)
{
    if (!SYMBOLP(var))
	LispDestroy("%s: %s is not a symbol", fname, STROBJ(var));
    if (eval)
	val = EVAL(val);

    return (LispSetVar(var, val));
}

int
LispRegisterOpaqueType(const char *desc)
{
    int length;
    LispOpaque *opaque;

    length = strlen(desc);
    opaque = (LispOpaque *)hash_check(lisp__data.opqs, desc, length);

    if (opaque == NULL) {
	opaque = (LispOpaque*)LispMalloc(sizeof(LispOpaque));
	opaque->desc = (hash_key*)LispCalloc(1, sizeof(hash_key));
	opaque->desc->value = LispStrdup(desc);
	opaque->desc->length = length;
	hash_put(lisp__data.opqs, (hash_entry *)opaque);
	LispMused(opaque->desc->value);
	LispMused(opaque->desc);
	LispMused(opaque);
	opaque->type = ++lisp__data.opaque;
    }

    return (opaque->type);
}

char *
LispIntToOpaqueType(int type)
{
    LispOpaque *opaque;

    if (type) {
	for (opaque = (LispOpaque *)hash_iter_first(lisp__data.opqs);
	     opaque;
	     opaque = (LispOpaque *)hash_iter_next(lisp__data.opqs)) {
	    if (opaque->type == type)
		return (opaque->desc->value);
	}
	LispDestroy("Opaque type %d not registered", type);
    }

    return (Snil->value);
}

hash_key *
LispGetAtomKey(const char *string, int perm)
{
    int length;
    hash_entry *entry;

    length = strlen(string);
    entry = hash_check(lisp__data.strings, string, length);
    if (entry == NULL) {
	entry = LispCalloc(1, sizeof(hash_entry));
	entry->key = LispCalloc(1, sizeof(hash_key));
	if (perm)
	    entry->key->value = (char *) string;
	else
	    entry->key->value = LispStrdup(string);
	entry->key->length = length;

	hash_put(lisp__data.strings, entry);
	if (!perm)
	    LispMused(entry->key->value);
	LispMused(entry->key);
	LispMused(entry);
    }

    return (entry->key);
}

LispAtom *
LispDoGetAtom(const char *str, int perm)
{
    int length;
    LispAtom *atom;

    length = strlen(str);
    atom = (LispAtom *)hash_check(lisp__data.pack->atoms, str, length);

    if (atom == NULL) {
	atom = (LispAtom*)LispCalloc(1, sizeof(LispAtom));
	atom->key = LispGetAtomKey(str, perm);
	hash_put(lisp__data.pack->atoms, (hash_entry *)atom);
	atom->property = NOPROPERTY;
	LispMused(atom);
    }

    return (atom);
}

static void
LispAllocAtomProperty(LispAtom *atom)
{
    LispProperty *property;

    if (atom->property != NOPROPERTY)
	LispDestroy("internal error at ALLOC-ATOM-PROPERTY");

    property = LispCalloc(1, sizeof(LispProperty));
    LispMused(property);
    atom->property = property;
    property->package = lisp__data.pack;
    if (atom->package == NULL)
	atom->package = PACKAGE;

    LispIncrementAtomReference(atom);
}

static void
LispIncrementAtomReference(LispAtom *atom)
{
    if (atom->property != NOPROPERTY)
	/* if atom->property is NOPROPERTY, this is an unbound symbol */
	++atom->property->refcount;
}

/* Assumes atom property is not NOPROPERTY */
static void
LispDecrementAtomReference(LispAtom *atom)
{
    if (atom->property == NOPROPERTY)
	/* if atom->property is NOPROPERTY, this is an unbound symbol */
	return;

    if (atom->property->refcount <= 0)
	LispDestroy("internal error at DECREMENT-ATOM-REFERENCE");

    --atom->property->refcount;

    if (atom->property->refcount == 0) {
	LispRemAtomAllProperties(atom);
	free(atom->property);
	atom->property = NOPROPERTY;
    }
}

static void
LispRemAtomAllProperties(LispAtom *atom)
{
    if (atom->property != NOPROPERTY) {
	if (atom->a_object)
	    LispRemAtomObjectProperty(atom);
	if (atom->a_function) {
	    lisp__data.gc.immutablebits = 1;
	    LispRemAtomFunctionProperty(atom);
	}
	else if (atom->a_compiled) {
	    lisp__data.gc.immutablebits = 1;
	    LispRemAtomCompiledProperty(atom);
	}
	else if (atom->a_builtin) {
	    lisp__data.gc.immutablebits = 1;
	    LispRemAtomBuiltinProperty(atom);
	}
	if (atom->a_defsetf) {
	    lisp__data.gc.immutablebits = 1;
	    LispRemAtomSetfProperty(atom);
	}
	if (atom->a_defstruct) {
	    lisp__data.gc.immutablebits = 1;
	    LispRemAtomStructProperty(atom);
	}
    }
}

void
LispSetAtomObjectProperty(LispAtom *atom, LispObj *object)
{
    if (atom->property == NOPROPERTY)
	LispAllocAtomProperty(atom);
    else if (atom->watch) {
	if (atom->object == lisp__data.package) {
	    if (!PACKAGEP(object))
		LispDestroy("Symbol %s must be a package, not %s",
			    ATOMID(lisp__data.package)->value, STROBJ(object));
	    lisp__data.pack = object->data.package.package;
	}
    }

    atom->a_object = 1;
    SETVALUE(atom, object);
}

static void
LispRemAtomObjectProperty(LispAtom *atom)
{
    if (atom->a_object) {
	atom->a_object = 0;
	atom->property->value = NULL;
    }
}

void
LispSetAtomCompiledProperty(LispAtom *atom, LispObj *bytecode)
{
    if (atom->property == NOPROPERTY)
	LispAllocAtomProperty(atom);

    lisp__data.gc.immutablebits = 1;
    if (atom->a_builtin) {
	atom->a_builtin = 0;
	LispFreeArgList(atom->property->alist);
    }
    else
	atom->a_function = 0;
    atom->a_compiled = 1;
    atom->property->fun.function = bytecode;
}

void
LispRemAtomCompiledProperty(LispAtom *atom)
{
    if (atom->a_compiled) {
	lisp__data.gc.immutablebits = 1;
	atom->property->fun.function = NULL;
	atom->a_compiled = 0;
	LispFreeArgList(atom->property->alist);
	atom->property->alist = NULL;
    }
}

void
LispSetAtomFunctionProperty(LispAtom *atom, LispObj *function,
			    LispArgList *alist)
{
    if (atom->property == NOPROPERTY)
	LispAllocAtomProperty(atom);

    lisp__data.gc.immutablebits = 1;
    if (atom->a_function == 0 && atom->a_builtin == 0 && atom->a_compiled == 0)
	atom->a_function = 1;
    else {
	if (atom->a_builtin) {
	    atom->a_builtin = 0;
	    LispFreeArgList(atom->property->alist);
	}
	else
	    atom->a_compiled = 0;
	atom->a_function = 1;
    }

    atom->property->fun.function = function;
    atom->property->alist = alist;
}

void
LispRemAtomFunctionProperty(LispAtom *atom)
{
    if (atom->a_function) {
	lisp__data.gc.immutablebits = 1;
	atom->property->fun.function = NULL;
	atom->a_function = 0;
	LispFreeArgList(atom->property->alist);
	atom->property->alist = NULL;
    }
}

void
LispSetAtomBuiltinProperty(LispAtom *atom, LispBuiltin *builtin,
			   LispArgList *alist)
{
    if (atom->property == NOPROPERTY)
	LispAllocAtomProperty(atom);

    lisp__data.gc.immutablebits = 1;
    if (atom->a_builtin == 0 && atom->a_function == 0)
	atom->a_builtin = 1;
    else {
	if (atom->a_function) {
	    atom->a_function = 0;
	    LispFreeArgList(atom->property->alist);
	}
    }

    atom->property->fun.builtin = builtin;
    atom->property->alist = alist;
}

void
LispRemAtomBuiltinProperty(LispAtom *atom)
{
    if (atom->a_builtin) {
	lisp__data.gc.immutablebits = 1;
	atom->property->fun.function = NULL;
	atom->a_builtin = 0;
	LispFreeArgList(atom->property->alist);
	atom->property->alist = NULL;
    }
}

void
LispSetAtomSetfProperty(LispAtom *atom, LispObj *setf, LispArgList *alist)
{
    if (atom->property == NOPROPERTY)
	LispAllocAtomProperty(atom);

    lisp__data.gc.immutablebits = 1;
    if (atom->a_defsetf)
	LispFreeArgList(atom->property->salist);

    atom->a_defsetf = 1;
    atom->property->setf = setf;
    atom->property->salist = alist;
}

void
LispRemAtomSetfProperty(LispAtom *atom)
{
    if (atom->a_defsetf) {
	lisp__data.gc.immutablebits = 1;
	atom->property->setf = NULL;
	atom->a_defsetf = 0;
	LispFreeArgList(atom->property->salist);
	atom->property->salist = NULL;
    }
}

void
LispSetAtomStructProperty(LispAtom *atom, LispObj *def, int fun)
{
    if (fun > 0xff)
	/* Not suported by the bytecode compiler... */
	LispDestroy("SET-ATOM-STRUCT-PROPERTY: "
		    "more than 256 fields not supported");

    if (atom->property == NOPROPERTY)
	LispAllocAtomProperty(atom);

    lisp__data.gc.immutablebits = 1;
    atom->a_defstruct = 1;
    atom->property->structure.definition = def;
    atom->property->structure.function = fun;
}

void
LispRemAtomStructProperty(LispAtom *atom)
{
    if (atom->a_defstruct) {
	lisp__data.gc.immutablebits = 1;
	atom->property->structure.definition = NULL;
	atom->a_defstruct = 0;
    }
}

LispAtom *
LispGetAtom(const char *str)
{
    return (LispDoGetAtom(str, 0));
}

LispAtom *
LispGetPermAtom(const char *str)
{
    return (LispDoGetAtom(str, 1));
}

#define GET_PROPERTY	0
#define ADD_PROPERTY	1
#define REM_PROPERTY	2
static LispObj *
LispAtomPropertyFunction(LispAtom *atom, LispObj *key, int function)
{
    LispObj *list = NIL, *result = NIL;

    if (function == ADD_PROPERTY) {
	if (atom->property == NOPROPERTY)
	    LispAllocAtomProperty(atom);
	if (atom->property->properties == NULL) {
	    atom->a_property = 1;
	    atom->property->properties = NIL;
	}
    }

    if (atom->a_property) {
	LispObj *base;

	for (base = list = atom->property->properties;
	     CONSP(list);
	     list = CDR(list)) {
	    if (key == CAR(list)) {
		result = CDR(list);
		break;
	    }
	    base = list;
	    list = CDR(list);
	    if (!CONSP(list))
		LispDestroy("%s: %s has an odd property list length",
			    STROBJ(atom->object),
			    function == REM_PROPERTY ? "REMPROP" : "GET");
	}
	if (CONSP(list) && function == REM_PROPERTY) {
	    if (!CONSP(CDR(list)))
		LispDestroy("REMPROP: %s has an odd property list length",
			    STROBJ(atom->object));
	    if (base == list)
		atom->property->properties = CDDR(list);
	    else
		RPLACD(CDR(base), CDDR(list));
	}
    }

    if (!CONSP(list)) {
	if (function == ADD_PROPERTY) {
	    atom->property->properties =
		CONS(key, CONS(NIL, atom->property->properties));
	    result = CDR(atom->property->properties);
	}
    }
    else if (function == REM_PROPERTY)
	result = T;

    return (result);
}

LispObj *
LispGetAtomProperty(LispAtom *atom, LispObj *key)
{
    return (LispAtomPropertyFunction(atom, key, GET_PROPERTY));
}

LispObj *
LispPutAtomProperty(LispAtom *atom, LispObj *key, LispObj *value)
{
    LispObj *result = LispAtomPropertyFunction(atom, key, ADD_PROPERTY);

    RPLACA(result, value);

    return (result);
}

LispObj *
LispRemAtomProperty(LispAtom *atom, LispObj *key)
{
    return (LispAtomPropertyFunction(atom, key, REM_PROPERTY));
}

LispObj *
LispReplaceAtomPropertyList(LispAtom *atom, LispObj *list)
{
    if (atom->property == NOPROPERTY)
	LispAllocAtomProperty(atom);
    if (atom->property->properties == NULL)
	atom->a_property = 1;
    atom->property->properties = list;

    return (list);
}
#undef GET_PROPERTY
#undef ADD_PROPERTY
#undef REM_PROPERTY


/* Used to make sure that when defining a function like:
 *	(defun my-function (... &key key1 key2 key3 ...)
 * key1, key2, and key3 will be in the keyword package
 */
static LispObj *
LispCheckKeyword(LispObj *keyword)
{
    if (KEYWORDP(keyword))
	return (keyword);

    return (KEYWORD(ATOMID(keyword)->value));
}

void
LispUseArgList(LispArgList *alist)
{
    if (alist->normals.num_symbols)
	LispMused(alist->normals.symbols);
    if (alist->optionals.num_symbols) {
	LispMused(alist->optionals.symbols);
	LispMused(alist->optionals.defaults);
	LispMused(alist->optionals.sforms);
    }
    if (alist->keys.num_symbols) {
	LispMused(alist->keys.symbols);
	LispMused(alist->keys.defaults);
	LispMused(alist->keys.sforms);
	LispMused(alist->keys.keys);
    }
    if (alist->auxs.num_symbols) {
	LispMused(alist->auxs.symbols);
	LispMused(alist->auxs.initials);
    }
    LispMused(alist);
}

void
LispFreeArgList(LispArgList *alist)
{
    if (alist->normals.num_symbols)
	LispFree(alist->normals.symbols);
    if (alist->optionals.num_symbols) {
	LispFree(alist->optionals.symbols);
	LispFree(alist->optionals.defaults);
	LispFree(alist->optionals.sforms);
    }
    if (alist->keys.num_symbols) {
	LispFree(alist->keys.symbols);
	LispFree(alist->keys.defaults);
	LispFree(alist->keys.sforms);
	LispFree(alist->keys.keys);
    }
    if (alist->auxs.num_symbols) {
	LispFree(alist->auxs.symbols);
	LispFree(alist->auxs.initials);
    }
    LispFree(alist);
}

static LispObj *
LispCheckNeedProtect(LispObj *object)
{
    if (object) {
	switch (OBJECT_TYPE(object)) {
	    case LispNil_t:
	    case LispAtom_t:
	    case LispFunction_t:
	    case LispFixnum_t:
	    case LispSChar_t:
		return (NULL);
	    default:
		return (object);
	}
    }
    return (NULL);
}

LispObj *
LispListProtectedArguments(LispArgList *alist)
{
    int i;
    GC_ENTER();
    LispObj *arguments, *cons, *obj, *prev;

    arguments = cons = prev = NIL;
    for (i = 0; i < alist->optionals.num_symbols; i++) {
	if ((obj = LispCheckNeedProtect(alist->optionals.defaults[i])) != NULL) {
	    if (arguments == NIL) {
		arguments = cons = prev = CONS(obj, NIL);
		GC_PROTECT(arguments);
	    }
	    else {
		RPLACD(cons, CONS(obj, NIL));
		prev = cons;
		cons = CDR(cons);
	    }
	}
    }
    for (i = 0; i < alist->keys.num_symbols; i++) {
	if ((obj = LispCheckNeedProtect(alist->keys.defaults[i])) != NULL) {
	    if (arguments == NIL) {
		arguments = cons = prev = CONS(obj, NIL);
		GC_PROTECT(arguments);
	    }
	    else {
		RPLACD(cons, CONS(obj, NIL));
		prev = cons;
		cons = CDR(cons);
	    }
	}
    }
    for (i = 0; i < alist->auxs.num_symbols; i++) {
	if ((obj = LispCheckNeedProtect(alist->auxs.initials[i])) != NULL) {
	    if (arguments == NIL) {
		arguments = cons = prev = CONS(obj, NIL);
		GC_PROTECT(arguments);
	    }
	    else {
		RPLACD(cons, CONS(obj, NIL));
		prev = cons;
		cons = CDR(cons);
	    }
	}
    }
    GC_LEAVE();

    /* Don't add a NIL cell at the end, to save some space */
    if (arguments != NIL) {
	if (arguments == cons)
	    arguments = CAR(cons);
	else
	    CDR(prev) = CAR(cons);
    }

    return (arguments);
}

LispArgList *
LispCheckArguments(LispFunType type, LispObj *list, const char *name, int builtin)
{
    static const char *types[4] = {"LAMBDA-LIST", "FUNCTION", "MACRO", "SETF-METHOD"};
    static const char *fnames[4] = {"LAMBDA", "DEFUN", "DEFMACRO", "DEFSETF"};
#define IKEY		0
#define IOPTIONAL	1
#define IREST		2
#define IAUX		3
    static const char *keys[4] = {"&KEY", "&OPTIONAL", "&REST", "&AUX"};
    int rest, optional, key, aux, count;
    LispArgList *alist;
    LispObj *spec, *sform, *defval, *default_value;
    char description[8], *desc;

/* If LispRealloc fails, the previous memory will be released
 * in LispTopLevel, unless LispMused was called on the pointer */
#define REALLOC_OBJECTS(pointer, count)		\
    pointer = LispRealloc(pointer, (count) * sizeof(LispObj*))

    alist = LispCalloc(1, sizeof(LispArgList));
    if (!CONSP(list)) {
	if (list != NIL)
	    LispDestroy("%s %s: %s cannot be a %s argument list",
			fnames[type], name, STROBJ(list), types[type]);
	alist->description = GETATOMID("")->value;

	return (alist);
    }

    default_value = builtin ? UNSPEC : NIL;

    description[0] = '\0';
    desc = description;
    rest = optional = key = aux = 0;
    for (; CONSP(list); list = CDR(list)) {
	spec = CAR(list);

	if (CONSP(spec)) {
	    if (builtin)
		LispDestroy("builtin function argument cannot have default value");
	    if (aux) {
		if (!SYMBOLP(CAR(spec)) ||
		    (CDR(spec) != NIL && CDDR(spec) != NIL))
		    LispDestroy("%s %s: bad &AUX argument %s",
				fnames[type], name, STROBJ(spec));
		defval = CDR(spec) != NIL ? CADR(spec) : NIL;
		count = alist->auxs.num_symbols;
		REALLOC_OBJECTS(alist->auxs.symbols, count + 1);
		REALLOC_OBJECTS(alist->auxs.initials, count + 1);
		alist->auxs.symbols[count] = CAR(spec);
		alist->auxs.initials[count] = defval;
		++alist->auxs.num_symbols;
		if (count == 0)
		    *desc++ = 'a';
		++alist->num_arguments;
	    }
	    else if (rest)
		LispDestroy("%s %s: syntax error parsing %s",
			    fnames[type], name, keys[IREST]);
	    else if (key) {
		LispObj *akey = CAR(spec);

		defval = default_value;
		sform = NULL;
		if (CONSP(akey)) {
		    /* check for special case, as in:
		     *	(defun a (&key ((key name) 'default-value)) name)
		     *	(a 'key 'test)	=> TEST
		     *	(a)		=> DEFAULT-VALUE
		     */
		    if (!SYMBOLP(CAR(akey)) || !CONSP(CDR(akey)) ||
			!SYMBOLP(CADR(akey)) || CDDR(akey) != NIL ||
			(CDR(spec) != NIL && CDDR(spec) != NIL))
			LispDestroy("%s %s: bad special &KEY %s",
				    fnames[type], name, STROBJ(spec));
		    if (CDR(spec) != NIL)
			defval = CADR(spec);
		    spec = CADR(akey);
		    akey = CAR(akey);
		}
		else {
		    akey = NULL;

		    if (!SYMBOLP(CAR(spec)))
			LispDestroy("%s %s: %s cannot be a %s argument name",
				    fnames[type], name,
				    STROBJ(CAR(spec)), types[type]);
		    /* check if default value provided, and optionally a `svar' */
		    else if (CDR(spec) != NIL && (!CONSP(CDR(spec)) ||
			      (CDDR(spec) != NIL &&
			       (!SYMBOLP(CAR(CDDR(spec))) ||
				CDR(CDDR(spec)) != NIL))))
			LispDestroy("%s %s: bad argument specification %s",
				    fnames[type], name, STROBJ(spec));
		    if (CONSP(CDR(spec))) {
			defval = CADR(spec);
			if (CONSP(CDDR(spec)))
			    sform = CAR(CDDR(spec));
		    }
		    /* Add to keyword package, and set the keyword in the
		     * argument list, so that a function argument keyword
		     * will reference the same object, and make comparison
		     * simpler. */
		    spec = LispCheckKeyword(CAR(spec));
		}

		count = alist->keys.num_symbols;
		REALLOC_OBJECTS(alist->keys.keys, count + 1);
		REALLOC_OBJECTS(alist->keys.defaults, count + 1);
		REALLOC_OBJECTS(alist->keys.sforms, count + 1);
		REALLOC_OBJECTS(alist->keys.symbols, count + 1);
		alist->keys.symbols[count] = spec;
		alist->keys.defaults[count] = defval;
		alist->keys.sforms[count] = sform;
		alist->keys.keys[count] = akey;
		++alist->keys.num_symbols;
		if (count == 0)
		    *desc++ = 'k';
		alist->num_arguments += 1 + (sform != NULL);
	    }
	    else if (optional) {
		defval = default_value;
		sform = NULL;

		if (!SYMBOLP(CAR(spec)))
		    LispDestroy("%s %s: %s cannot be a %s argument name",
				fnames[type], name,
				STROBJ(CAR(spec)), types[type]);
		/* check if default value provided, and optionally a `svar' */
		else if (CDR(spec) != NIL && (!CONSP(CDR(spec)) ||
			  (CDDR(spec) != NIL &&
			   (!SYMBOLP(CAR(CDDR(spec))) ||
			    CDR(CDDR(spec)) != NIL))))
		    LispDestroy("%s %s: bad argument specification %s",
				fnames[type], name, STROBJ(spec));
		if (CONSP(CDR(spec))) {
		    defval = CADR(spec);
		    if (CONSP(CDDR(spec)))
			sform = CAR(CDDR(spec));
		}
		spec = CAR(spec);

		count = alist->optionals.num_symbols;
		REALLOC_OBJECTS(alist->optionals.symbols, count + 1);
		REALLOC_OBJECTS(alist->optionals.defaults, count + 1);
		REALLOC_OBJECTS(alist->optionals.sforms, count + 1);
		alist->optionals.symbols[count] = spec;
		alist->optionals.defaults[count] = defval;
		alist->optionals.sforms[count] = sform;
		++alist->optionals.num_symbols;
		if (count == 0)
		    *desc++ = 'o';
		alist->num_arguments += 1 + (sform != NULL);
	    }

	    /* Normal arguments cannot have default value */
	    else
		LispDestroy("%s %s: syntax error parsing %s",
			    fnames[type], name, STROBJ(spec));
	}

	/* spec must be an atom, excluding keywords */
	else if (!SYMBOLP(spec) || KEYWORDP(spec))
	    LispDestroy("%s %s: %s cannot be a %s argument",
			fnames[type], name, STROBJ(spec), types[type]);
	else {
	    Atom_id atom = ATOMID(spec);

	    if (atom->value[0] == '&') {
		if (atom == Srest) {
		    if (rest || aux || CDR(list) == NIL || !SYMBOLP(CADR(list))
			/* only &aux allowed after &rest */
			|| (CDDR(list) != NIL && !SYMBOLP(CAR(CDDR(list))) &&
			    ATOMID(CAR(CDDR(list))) != Saux))
			LispDestroy("%s %s: syntax error parsing %s",
				    fnames[type], name, ATOMID(spec)->value);
		    if (key)
			LispDestroy("%s %s: %s not allowed after %s",
				    fnames[type], name, keys[IREST], keys[IKEY]);
		    rest = 1;
		    continue;
		}

		else if (atom == Skey) {
		    if (rest || aux)
			LispDestroy("%s %s: %s not allowed after %s",
				    fnames[type], name, ATOMID(spec)->value,
				    rest ? keys[IREST] : keys[IAUX]);
		    key = 1;
		    continue;
		}

		else if (atom == Soptional) {
		    if (rest || optional || aux || key)
			LispDestroy("%s %s: %s not allowed after %s",
				    fnames[type], name, ATOMID(spec)->value,
				    rest ? keys[IREST] :
					optional ?
					keys[IOPTIONAL] :
					    aux ? keys[IAUX] : keys[IKEY]);
		    optional = 1;
		    continue;
		}

		else if (atom == Saux) {
		    /* &AUX must be the last keyword parameter */
		    if (aux)
			LispDestroy("%s %s: syntax error parsing %s",
				    fnames[type], name, ATOMID(spec)->value);
		    else if (builtin)
			LispDestroy("builtin function cannot have &AUX arguments");
		    aux = 1;
		    continue;
		}

		/* Untill more lambda-list keywords supported, don't allow
		 * argument names starting with the '&' character */
		else
		    LispDestroy("%s %s: %s not allowed/implemented",
				fnames[type], name, ATOMID(spec)->value);
	    }

	    /* Add argument to alist */
	    if (aux) {
		count = alist->auxs.num_symbols;
		REALLOC_OBJECTS(alist->auxs.symbols, count + 1);
		REALLOC_OBJECTS(alist->auxs.initials, count + 1);
		alist->auxs.symbols[count] = spec;
		alist->auxs.initials[count] = default_value;
		++alist->auxs.num_symbols;
		if (count == 0)
		    *desc++ = 'a';
		++alist->num_arguments;
	    }
	    else if (rest) {
		alist->rest = spec;
		*desc++ = 'r';
		++alist->num_arguments;
	    }
	    else if (key) {
		/* Add to keyword package, and set the keyword in the
		 * argument list, so that a function argument keyword
		 * will reference the same object, and make comparison
		 * simpler. */
		spec = LispCheckKeyword(spec);
		count = alist->keys.num_symbols;
		REALLOC_OBJECTS(alist->keys.keys, count + 1);
		REALLOC_OBJECTS(alist->keys.defaults, count + 1);
		REALLOC_OBJECTS(alist->keys.sforms, count + 1);
		REALLOC_OBJECTS(alist->keys.symbols, count + 1);
		alist->keys.symbols[count] = spec;
		alist->keys.defaults[count] = default_value;
		alist->keys.sforms[count] = NULL;
		alist->keys.keys[count] = NULL;
		++alist->keys.num_symbols;
		if (count == 0)
		    *desc++ = 'k';
		++alist->num_arguments;
	    }
	    else if (optional) {
		count = alist->optionals.num_symbols;
		REALLOC_OBJECTS(alist->optionals.symbols, count + 1);
		REALLOC_OBJECTS(alist->optionals.defaults, count + 1);
		REALLOC_OBJECTS(alist->optionals.sforms, count + 1);
		alist->optionals.symbols[count] = spec;
		alist->optionals.defaults[count] = default_value;
		alist->optionals.sforms[count] = NULL;
		++alist->optionals.num_symbols;
		if (count == 0)
		    *desc++ = 'o';
		++alist->num_arguments;
	    }
	    else {
		count = alist->normals.num_symbols;
		REALLOC_OBJECTS(alist->normals.symbols, count + 1);
		alist->normals.symbols[count] = spec;
		++alist->normals.num_symbols;
		if (count == 0)
		    *desc++ = '.';
		++alist->num_arguments;
	    }
	}
    }

    /* Check for dotted argument list */
    if (list != NIL)
	LispDestroy("%s %s: %s cannot end %s arguments",
		    fnames[type], name, STROBJ(list), types[type]);

    *desc = '\0';
    alist->description = LispGetAtomKey(description, 0)->value;

    return (alist);
}

void
LispAddBuiltinFunction(LispBuiltin *builtin)
{
    static LispObj stream;
    static LispString string;
    static int first = 1;
    LispObj *name, *obj, *list, *cons, *code;
    LispAtom *atom;
    LispArgList *alist;
    int length = lisp__data.protect.length;

    if (first) {
	stream.type = LispStream_t;
	stream.data.stream.source.string = &string;
	stream.data.stream.pathname = NIL;
	stream.data.stream.type = LispStreamString;
	stream.data.stream.readable = 1;
	stream.data.stream.writable = 0;
	string.output = 0;
	first = 0;
    }
    string.string = builtin->declaration;
    string.length = strlen(builtin->declaration);
    string.input = 0;

    code = COD;
    LispPushInput(&stream);
    name = LispRead();
    list = cons = CONS(name, NIL);
    if (length + 1 >= lisp__data.protect.space)
	LispMoreProtects();
    lisp__data.protect.objects[lisp__data.protect.length++] = list;
    while ((obj = LispRead()) != NULL) {
	RPLACD(cons, CONS(obj, NIL));
	cons = CDR(cons);
    }
    LispPopInput(&stream);

    atom = name->data.atom;
    alist = LispCheckArguments(builtin->type, CDR(list), atom->key->value, 1);
    builtin->symbol = CAR(list);
    LispSetAtomBuiltinProperty(atom, builtin, alist);
    LispUseArgList(alist);

    /* Make function a extern symbol, unless told to not do so */
    if (!builtin->internal)
	LispExportSymbol(name);

    lisp__data.protect.length = length;
    COD = code;			/* LispRead protect data in COD */
}

void
LispAllocSeg(LispObjSeg *seg, int cellcount)
{
    unsigned int i;
    LispObj **list, *obj;

    DISABLE_INTERRUPTS();
    while (seg->nfree < cellcount) {
	if ((obj = (LispObj*)calloc(1, sizeof(LispObj) * segsize)) == NULL) {
	    ENABLE_INTERRUPTS();
	    LispDestroy("out of memory");
	}
	if ((list = (LispObj**)realloc(seg->objects,
	    sizeof(LispObj*) * (seg->nsegs + 1))) == NULL) {
	    free(obj);
	    ENABLE_INTERRUPTS();
	    LispDestroy("out of memory");
	}
	seg->objects = list;
	seg->objects[seg->nsegs] = obj;

	seg->nfree += segsize;
	seg->nobjs += segsize;
	for (i = 1; i < segsize; i++, obj++) {
	    /* Objects of type cons are the most used, save some time
	     * by not setting it's type in LispNewCons. */
	    obj->type = LispCons_t;
	    CDR(obj) = obj + 1;
	}
	obj->type = LispCons_t;
	CDR(obj) = seg->freeobj;
	seg->freeobj = seg->objects[seg->nsegs];
	++seg->nsegs;
    }
#ifdef DEBUG
    LispMessage("gc: %d cell(s) allocated at %d segment(s)",
		seg->nobjs, seg->nsegs);
#endif
    ENABLE_INTERRUPTS();
}

static INLINE void
LispMark(register LispObj *object)
{
mark_again:
    switch (OBJECT_TYPE(object)) {
	case LispNil_t:
	case LispAtom_t:
	case LispFixnum_t:
	case LispSChar_t:
	case LispFunction_t:
	    return;
	case LispLambda_t:
	    if (OPAQUEP(object->data.lambda.name))
		object->data.lambda.name->mark = 1;
	    object->mark = 1;
	    LispMark(object->data.lambda.data);
	    object = object->data.lambda.code;
	    goto mark_cons;
	case LispQuote_t:
	case LispBackquote_t:
	case LispFunctionQuote_t:
	    object->mark = 1;
	    object = object->data.quote;
	    goto mark_again;
	case LispPathname_t:
	    object->mark = 1;
	    object = object->data.pathname;
	    goto mark_again;
	case LispComma_t:
	    object->mark = 1;
	    object = object->data.comma.eval;
	    goto mark_again;
	case LispComplex_t:
	    if (POINTERP(object->data.complex.real))
		object->data.complex.real->mark = 1;
	    if (POINTERP(object->data.complex.imag))
		object->data.complex.imag->mark = 1;
	    break;
	case LispCons_t:
mark_cons:
	    for (; CONSP(object) && !object->mark; object = CDR(object)) {
		object->mark = 1;
		switch (OBJECT_TYPE(CAR(object))) {
		    case LispNil_t:
		    case LispAtom_t:
		    case LispFixnum_t:
		    case LispSChar_t:
		    case LispPackage_t:		/* protected in gc */
			break;
		    case LispInteger_t:
		    case LispDFloat_t:
		    case LispString_t:
		    case LispRatio_t:
		    case LispOpaque_t:
		    case LispBignum_t:
		    case LispBigratio_t:
			CAR(object)->mark = 1;
			break;
		    default:
			LispMark(CAR(object));
			break;
		}
	    }
	    if (POINTERP(object) && !object->mark)
		goto mark_again;
	    return;
	case LispArray_t:
	    LispMark(object->data.array.list);
	    object->mark = 1;
	    object = object->data.array.dim;
	    goto mark_cons;
	case LispStruct_t:
	    object->mark = 1;
	    object = object->data.struc.fields;
	    goto mark_cons;
	case LispStream_t:
mark_stream:
	    LispMark(object->data.stream.pathname);
	    if (object->data.stream.type == LispStreamPipe) {
		object->mark = 1;
		object = object->data.stream.source.program->errorp;
		goto mark_stream;
	    }
	    break;
	case LispRegex_t:
	    object->data.regex.pattern->mark = 1;
	    break;
	case LispBytecode_t:
	    object->mark = 1;
	    object = object->data.bytecode.code;
	    goto mark_again;
	case LispHashTable_t: {
	    unsigned long i;
	    LispHashEntry *entry = object->data.hash.table->entries,
			  *last = entry + object->data.hash.table->num_entries;

	    if (object->mark)
		return;
	    object->mark = 1;
	    for (; entry < last; entry++) {
		for (i = 0; i < entry->count; i++) {
		    switch (OBJECT_TYPE(entry->keys[i])) {
			case LispNil_t:
			case LispAtom_t:
			case LispFixnum_t:
			case LispSChar_t:
			case LispFunction_t:
			case LispPackage_t:
			    break;
			case LispInteger_t:
			case LispDFloat_t:
			case LispString_t:
			case LispRatio_t:
			case LispOpaque_t:
			case LispBignum_t:
			case LispBigratio_t:
			    entry->keys[i]->mark = 1;
			    break;
			default:
			    LispMark(entry->keys[i]);
			    break;
		    }
		    switch (OBJECT_TYPE(entry->values[i])) {
			case LispNil_t:
			case LispAtom_t:
			case LispFixnum_t:
			case LispSChar_t:
			case LispFunction_t:
			case LispPackage_t:
			    break;
			case LispInteger_t:
			case LispDFloat_t:
			case LispString_t:
			case LispRatio_t:
			case LispOpaque_t:
			case LispBignum_t:
			case LispBigratio_t:
			    entry->values[i]->mark = 1;
			    break;
			default:
			    LispMark(entry->values[i]);
			    break;
		    }
		}
	    }
	}   return;
	default:
	    break;
    }
    object->mark = 1;
}

static INLINE void
LispProt(register LispObj *object)
{
prot_again:
    switch (OBJECT_TYPE(object)) {
	case LispNil_t:
	case LispAtom_t:
	case LispFixnum_t:
	case LispSChar_t:
	case LispFunction_t:
	    return;
	case LispLambda_t:
	    if (OPAQUEP(object->data.lambda.name))
		object->data.lambda.name->prot = 1;
	    object->prot = 1;
	    LispProt(object->data.lambda.data);
	    object = object->data.lambda.code;
	    goto prot_cons;
	case LispQuote_t:
	case LispBackquote_t:
	case LispFunctionQuote_t:
	    object->prot = 1;
	    object = object->data.quote;
	    goto prot_again;
	case LispPathname_t:
	    object->prot = 1;
	    object = object->data.pathname;
	    goto prot_again;
	case LispComma_t:
	    object->prot = 1;
	    object = object->data.comma.eval;
	    goto prot_again;
	case LispComplex_t:
	    if (POINTERP(object->data.complex.real))
		object->data.complex.real->prot = 1;
	    if (POINTERP(object->data.complex.imag))
		object->data.complex.imag->prot = 1;
	    break;
	case LispCons_t:
prot_cons:
	    for (; CONSP(object) && !object->prot; object = CDR(object)) {
		object->prot = 1;
		switch (OBJECT_TYPE(CAR(object))) {
		    case LispNil_t:
		    case LispAtom_t:
		    case LispFixnum_t:
		    case LispSChar_t:
		    case LispFunction_t:
		    case LispPackage_t:		/* protected in gc */
			break;
		    case LispInteger_t:
		    case LispDFloat_t:
		    case LispString_t:
		    case LispRatio_t:
		    case LispOpaque_t:
		    case LispBignum_t:
		    case LispBigratio_t:
			CAR(object)->prot = 1;
			break;
		    default:
			LispProt(CAR(object));
			break;
		}
	    }
	    if (POINTERP(object) && !object->prot)
		goto prot_again;
	    return;
	case LispArray_t:
	    LispProt(object->data.array.list);
	    object->prot = 1;
	    object = object->data.array.dim;
	    goto prot_cons;
	case LispStruct_t:
	    object->prot = 1;
	    object = object->data.struc.fields;
	    goto prot_cons;
	case LispStream_t:
prot_stream:
	    LispProt(object->data.stream.pathname);
	    if (object->data.stream.type == LispStreamPipe) {
		object->prot = 1;
		object = object->data.stream.source.program->errorp;
		goto prot_stream;
	    }
	    break;
	case LispRegex_t:
	    object->data.regex.pattern->prot = 1;
	    break;
	case LispBytecode_t:
	    object->prot = 1;
	    object = object->data.bytecode.code;
	    goto prot_again;
	case LispHashTable_t: {
	    unsigned long i;
	    LispHashEntry *entry = object->data.hash.table->entries,
			  *last = entry + object->data.hash.table->num_entries;

	    if (object->prot)
		return;
	    object->prot = 1;
	    for (; entry < last; entry++) {
		for (i = 0; i < entry->count; i++) {
		    switch (OBJECT_TYPE(entry->keys[i])) {
			case LispNil_t:
			case LispAtom_t:
			case LispFixnum_t:
			case LispSChar_t:
			case LispFunction_t:
			case LispPackage_t:
			    break;
			case LispInteger_t:
			case LispDFloat_t:
			case LispString_t:
			case LispRatio_t:
			case LispOpaque_t:
			case LispBignum_t:
			case LispBigratio_t:
			    entry->keys[i]->prot = 1;
			    break;
			default:
			    LispProt(entry->keys[i]);
			    break;
		    }
		    switch (OBJECT_TYPE(entry->values[i])) {
			case LispNil_t:
			case LispAtom_t:
			case LispFixnum_t:
			case LispSChar_t:
			case LispFunction_t:
			case LispPackage_t:
			    break;
			case LispInteger_t:
			case LispDFloat_t:
			case LispString_t:
			case LispRatio_t:
			case LispOpaque_t:
			case LispBignum_t:
			case LispBigratio_t:
			    entry->values[i]->prot = 1;
			    break;
			default:
			    LispProt(entry->values[i]);
			    break;
		    }
		}
	    }
	}   return;
	default:
	    break;
    }
    object->prot = 1;
}

void
LispProtect(LispObj *key, LispObj *list)
{
    PRO = CONS(CONS(key, list), PRO);
}

void
LispUProtect(LispObj *key, LispObj *list)
{
    LispObj *prev, *obj;

    for (prev = obj = PRO; obj != NIL; prev = obj, obj = CDR(obj))
	if (CAR(CAR(obj)) == key && CDR(CAR(obj)) == list) {
	    if (obj == PRO)
		PRO = CDR(PRO);
	    else
		CDR(prev) = CDR(obj);
	    return;
	}

    LispDestroy("no match for %s, at UPROTECT", STROBJ(key));
}

static LispObj *
Lisp__New(LispObj *car, LispObj *cdr)
{
    int cellcount;
    LispObj *obj;

    Lisp__GC(car, cdr);
#if 0
    lisp__data.gc.average = (objseg.nfree + lisp__data.gc.average) >> 1;
    if (lisp__data.gc.average < minfree) {
	if (lisp__data.gc.expandbits < 6)
	    ++lisp__data.gc.expandbits;
    }
    else if (lisp__data.gc.expandbits)
	--lisp__data.gc.expandbits;
    /* For 32 bit computers, where sizeof(LispObj) == 16,
     * minfree is set to 1024, and expandbits limited to 6,
     * the maximum extra memory requested here should be 1Mb
     */
    cellcount = minfree << lisp__data.gc.expandbits;
#else
    /* Try to keep at least 3 times more free cells than the de number
     * of used cells in the freelist, to amenize the cost of the gc time,
     * in the, currently, very simple gc strategy code. */
    cellcount = (objseg.nobjs - objseg.nfree) * 3;
    cellcount = cellcount + (minfree - (cellcount % minfree));
#endif

    if (objseg.freeobj == NIL || objseg.nfree < cellcount)
	LispAllocSeg(&objseg, cellcount);

    obj = objseg.freeobj;
    objseg.freeobj = CDR(obj);
    --objseg.nfree;

    return (obj);
}

LispObj *
LispNew(LispObj *car, LispObj *cdr)
{
    LispObj *obj = objseg.freeobj;

    if (obj == NIL)
	obj = Lisp__New(car, cdr);
    else {
	objseg.freeobj = CDR(obj);
	--objseg.nfree;
    }

    return (obj);
}

LispObj *
LispNewAtom(const char *str, int intern)
{
    LispObj *object;
    LispAtom *atom = LispDoGetAtom(str, 0);

    if (atom->object) {
	if (intern && atom->package == NULL)
	    atom->package = PACKAGE;

	return (atom->object);
    }

    if (atomseg.freeobj == NIL)
	LispAllocSeg(&atomseg, pagesize);
    object = atomseg.freeobj;
    atomseg.freeobj = CDR(object);
    --atomseg.nfree;

    object->type = LispAtom_t;
    object->data.atom = atom;
    atom->object = object;
    if (intern)
	atom->package = PACKAGE;

    return (object);
}

LispObj *
LispNewStaticAtom(const char *str)
{
    LispObj *object;
    LispAtom *atom = LispDoGetAtom(str, 1);

    object = LispNewSymbol(atom);

    return (object);
}

LispObj *
LispNewSymbol(LispAtom *atom)
{
    if (atom->object) {
	if (atom->package == NULL)
	    atom->package = PACKAGE;

	return (atom->object);
    }
    else {
	LispObj *symbol;

	if (atomseg.freeobj == NIL)
	    LispAllocSeg(&atomseg, pagesize);
	symbol = atomseg.freeobj;
	atomseg.freeobj = CDR(symbol);
	--atomseg.nfree;

	symbol->type = LispAtom_t;
	symbol->data.atom = atom;
	atom->object = symbol;
	atom->package = PACKAGE;

	return (symbol);
    }
}

/* function representation is created on demand and never released,
 * even if the function is undefined and never defined again */
LispObj *
LispNewFunction(LispObj *symbol)
{
    LispObj *function;

    if (symbol->data.atom->function)
	return (symbol->data.atom->function);

    if (symbol->data.atom->package == NULL)
	symbol->data.atom->package = PACKAGE;

    if (atomseg.freeobj == NIL)
	LispAllocSeg(&atomseg, pagesize);
    function = atomseg.freeobj;
    atomseg.freeobj = CDR(function);
    --atomseg.nfree;

    function->type = LispFunction_t;
    function->data.atom = symbol->data.atom;
    symbol->data.atom->function = function;

    return (function);
}

/* symbol name representation is created on demand and never released */
LispObj *
LispSymbolName(LispObj *symbol)
{
    LispObj *name;
    LispAtom *atom = symbol->data.atom;

    if (atom->name)
	return (atom->name);

    if (atomseg.freeobj == NIL)
	LispAllocSeg(&atomseg, pagesize);
    name = atomseg.freeobj;
    atomseg.freeobj = CDR(name);
    --atomseg.nfree;

    name->type = LispString_t;
    THESTR(name) = atom->key->value;
    STRLEN(name) = atom->key->length;
    name->data.string.writable = 0;
    atom->name = name;

    return (name);
}

LispObj *
LispNewFunctionQuote(LispObj *object)
{
    LispObj *quote = LispNew(object, NIL);

    quote->type = LispFunctionQuote_t;
    quote->data.quote = object;

    return (quote);
}

LispObj *
LispNewDFloat(double value)
{
    LispObj *dfloat = objseg.freeobj;

    if (dfloat == NIL)
	dfloat = Lisp__New(NIL, NIL);
    else {
	objseg.freeobj = CDR(dfloat);
	--objseg.nfree;
    }
    dfloat->type = LispDFloat_t;
    dfloat->data.dfloat = value;

    return (dfloat);
}

LispObj *
LispNewString(const char *str, long length)
{
    char *cstring = LispMalloc(length + 1);
    memcpy(cstring, str, length);
    cstring[length] = '\0';
    return LispNewStringAlloced(cstring, length);
}

LispObj *
LispNewStringAlloced(char *cstring, long length)
{
    LispObj *string = objseg.freeobj;

    if (string == NIL)
	string = Lisp__New(NIL, NIL);
    else {
	objseg.freeobj = CDR(string);
	--objseg.nfree;
    }
    LispMused(cstring);
    string->type = LispString_t;
    THESTR(string) = cstring;
    STRLEN(string) = length;
    string->data.string.writable = 1;

    return (string);
}

LispObj *
LispNewComplex(LispObj *realpart, LispObj *imagpart)
{
    LispObj *complexp = objseg.freeobj;

    if (complexp == NIL)
	complexp = Lisp__New(realpart, imagpart);
    else {
	objseg.freeobj = CDR(complexp);
	--objseg.nfree;
    }
    complexp->type = LispComplex_t;
    complexp->data.complex.real = realpart;
    complexp->data.complex.imag = imagpart;

    return (complexp);
}

LispObj *
LispNewInteger(long integer)
{
    if (integer > MOST_POSITIVE_FIXNUM || integer < MOST_NEGATIVE_FIXNUM) {
	LispObj *object = objseg.freeobj;

	if (object == NIL)
	    object = Lisp__New(NIL, NIL);
	else {
	    objseg.freeobj = CDR(object);
	    --objseg.nfree;
	}
	object->type = LispInteger_t;
	object->data.integer = integer;

	return (object);
    }
    return (FIXNUM(integer));
}

LispObj *
LispNewRatio(long num, long den)
{
    LispObj *ratio = objseg.freeobj;

    if (ratio == NIL)
	ratio = Lisp__New(NIL, NIL);
    else {
	objseg.freeobj = CDR(ratio);
	--objseg.nfree;
    }
    ratio->type = LispRatio_t;
    ratio->data.ratio.numerator = num;
    ratio->data.ratio.denominator = den;

    return (ratio);
}

LispObj *
LispNewVector(LispObj *objects)
{
    GC_ENTER();
    long count;
    LispObj *array, *dimension;

    for (count = 0, array = objects; CONSP(array); count++, array = CDR(array))
	;

    GC_PROTECT(objects);
    dimension = CONS(FIXNUM(count), NIL);
    array = LispNew(objects, dimension);
    array->type = LispArray_t;
    array->data.array.list = objects;
    array->data.array.dim = dimension;
    array->data.array.rank = 1;
    array->data.array.type = LispNil_t;
    array->data.array.zero = count == 0;
    GC_LEAVE();

    return (array);
}

LispObj *
LispNewQuote(LispObj *object)
{
    LispObj *quote = LispNew(object, NIL);

    quote->type = LispQuote_t;
    quote->data.quote = object;

    return (quote);
}

LispObj *
LispNewBackquote(LispObj *object)
{
    LispObj *backquote = LispNew(object, NIL);

    backquote->type = LispBackquote_t;
    backquote->data.quote = object;

    return (backquote);
}

LispObj *
LispNewComma(LispObj *object, int atlist)
{
    LispObj *comma = LispNew(object, NIL);

    comma->type = LispComma_t;
    comma->data.comma.eval = object;
    comma->data.comma.atlist = atlist;

    return (comma);
}

LispObj *
LispNewCons(LispObj *car, LispObj *cdr)
{
    LispObj *cons = objseg.freeobj;

    if (cons == NIL)
	cons = Lisp__New(car, cdr);
    else {
	objseg.freeobj = CDR(cons);
	--objseg.nfree;
    }
    CAR(cons) = car;
    CDR(cons) = cdr;

    return (cons);
}

LispObj *
LispNewLambda(LispObj *name, LispObj *code, LispObj *data, LispFunType type)
{
    LispObj *fun = LispNew(data, code);

    fun->type = LispLambda_t;
    fun->funtype = type;
    fun->data.lambda.name = name;
    fun->data.lambda.code = code;
    fun->data.lambda.data = data;

    return (fun);
}

LispObj *
LispNewStruct(LispObj *fields, LispObj *def)
{
    LispObj *struc = LispNew(fields, def);

    struc->type = LispStruct_t;
    struc->data.struc.fields = fields;
    struc->data.struc.def = def;

    return (struc);
}

LispObj *
LispNewOpaque(void *data, int type)
{
    LispObj *opaque = LispNew(NIL, NIL);

    opaque->type = LispOpaque_t;
    opaque->data.opaque.data = data;
    opaque->data.opaque.type = type;

    return (opaque);
}

/* string argument must be static, or allocated */
LispObj *
LispNewKeyword(const char *string)
{
    LispObj *keyword;

    if (PACKAGE != lisp__data.keyword) {
	LispObj *savepackage;
	LispPackage *savepack;

	/* Save package environment */
	savepackage = PACKAGE;
	savepack = lisp__data.pack;

	/* Change package environment */
	PACKAGE = lisp__data.keyword;
	lisp__data.pack = lisp__data.key;

	/* Create symbol in keyword package */
	keyword = LispNewStaticAtom(string);

	/* Restore package environment */
	PACKAGE = savepackage;
	lisp__data.pack = savepack;
    }
    else
	/* Just create symbol in keyword package */
	keyword = LispNewStaticAtom(string);

    /* Export keyword symbol */
    LispExportSymbol(keyword);

    /* All keywords are constants */
    keyword->data.atom->constant = 1;

    /* XXX maybe should bound the keyword to itself, but that would
     * require allocating a LispProperty structure for every keyword */

    return (keyword);
}

LispObj *
LispNewPathname(LispObj *obj)
{
    LispObj *path = LispNew(obj, NIL);

    path->type = LispPathname_t;
    path->data.pathname = obj;

    return (path);
}

LispObj *
LispNewStringStream(const char *string, int flags, long length)
{
    char *newstring = LispMalloc(length + 1);
    memcpy(newstring, string, length);
    newstring[length] = '\0';

    return LispNewStringStreamAlloced(newstring, flags, length);
}

LispObj *
LispNewStringStreamAlloced(char *string, int flags, long length)
{
    LispObj *stream = LispNew(NIL, NIL);

    SSTREAMP(stream) = LispCalloc(1, sizeof(LispString));
    SSTREAMP(stream)->string = string;

    stream->type = LispStream_t;

    SSTREAMP(stream)->length = length;
    LispMused(SSTREAMP(stream));
    LispMused(SSTREAMP(stream)->string);
    stream->data.stream.type = LispStreamString;
    stream->data.stream.readable = (flags & STREAM_READ) != 0;
    stream->data.stream.writable = (flags & STREAM_WRITE) != 0;
    SSTREAMP(stream)->space = length + 1;

    stream->data.stream.pathname = NIL;

    return (stream);
}

LispObj *
LispNewFileStream(LispFile *file, LispObj *path, int flags)
{
    LispObj *stream = LispNew(NIL, NIL);

    stream->type = LispStream_t;
    FSTREAMP(stream) = file;
    stream->data.stream.pathname = path;
    stream->data.stream.type = LispStreamFile;
    stream->data.stream.readable = (flags & STREAM_READ) != 0;
    stream->data.stream.writable = (flags & STREAM_WRITE) != 0;

    return (stream);
}

LispObj *
LispNewPipeStream(LispPipe *program, LispObj *path, int flags)
{
    LispObj *stream = LispNew(NIL, NIL);

    stream->type = LispStream_t;
    PSTREAMP(stream) = program;
    stream->data.stream.pathname = path;
    stream->data.stream.type = LispStreamPipe;
    stream->data.stream.readable = (flags & STREAM_READ) != 0;
    stream->data.stream.writable = (flags & STREAM_WRITE) != 0;

    return (stream);
}

LispObj *
LispNewStandardStream(LispFile *file, LispObj *description, int flags)
{
    LispObj *stream = LispNew(NIL, NIL);

    stream->type = LispStream_t;
    FSTREAMP(stream) = file;
    stream->data.stream.pathname = description;
    stream->data.stream.type = LispStreamStandard;
    stream->data.stream.readable = (flags & STREAM_READ) != 0;
    stream->data.stream.writable = (flags & STREAM_WRITE) != 0;

    return (stream);
}

LispObj *
LispNewBignum(mpi *bignum)
{
    LispObj *integer = LispNew(NIL, NIL);

    integer->type = LispBignum_t;
    integer->data.mp.integer = bignum;
    LispMused(bignum->digs);
    LispMused(bignum);

    return (integer);
}

LispObj *
LispNewBigratio(mpr *bigratio)
{
    LispObj *ratio = LispNew(NIL, NIL);

    ratio->type = LispBigratio_t;
    ratio->data.mp.ratio = bigratio;
    LispMused(mpr_num(bigratio)->digs);
    LispMused(mpr_den(bigratio)->digs);
    LispMused(bigratio);

    return (ratio);
}

/* name must be of type LispString_t */
LispObj *
LispNewPackage(LispObj *name, LispObj *nicknames)
{
    LispObj *package = LispNew(name, nicknames);
    LispPackage *pack = LispCalloc(1, sizeof(LispPackage));

    package->type = LispPackage_t;
    package->data.package.name = name;
    package->data.package.nicknames = nicknames;
    package->data.package.package = pack;

    package->data.package.package->atoms = hash_new(STRTBLSZ, NULL);

    LispMused(pack);

    return (package);
}

LispObj *
LispSymbolFunction(LispObj *symbol)
{
    LispAtom *atom = symbol->data.atom;

    if ((atom->a_builtin &&
	 atom->property->fun.builtin->type == LispFunction) ||
	(atom->a_function &&
	 atom->property->fun.function->funtype == LispFunction) ||
	(atom->a_defstruct &&
	 atom->property->structure.function != STRUCT_NAME) ||
	/* XXX currently bytecode is only generated for functions */
	atom->a_compiled)
	symbol = FUNCTION(symbol);
    else
	LispDestroy("SYMBOL-FUNCTION: %s is not a function", STROBJ(symbol));

    return (symbol);
}


static INLINE LispObj *
LispGetVarPack(LispObj *symbol)
{
    LispAtom *atom;

    atom = (LispAtom *)hash_get(lisp__data.pack->atoms,
				 symbol->data.atom->key);

    return (atom ? atom->object : NULL);
}

/* package must be of type LispPackage_t */
void
LispUsePackage(LispObj *package)
{
    LispAtom *atom;
    LispPackage *pack;
    LispObj **pentry, **eentry;

    /* Already using its own symbols... */
    if (package == PACKAGE)
	return;

    /* Check if package not already in use-package list */
    for (pentry = lisp__data.pack->use.pairs,
	 eentry = pentry + lisp__data.pack->use.length;
	 pentry < eentry; pentry++)
	if (*pentry == package)
	return;

    /* Remember this package is in the use-package list */
    if (lisp__data.pack->use.length + 1 >= lisp__data.pack->use.space) {
	LispObj **pairs = realloc(lisp__data.pack->use.pairs,
				  (lisp__data.pack->use.space + 1) *
				  sizeof(LispObj*));

	if (pairs == NULL)
	    LispDestroy("out of memory");

	lisp__data.pack->use.pairs = pairs;
	++lisp__data.pack->use.space;
    }
    lisp__data.pack->use.pairs[lisp__data.pack->use.length++] = package;

    /* Import all extern symbols from package */
    pack = package->data.package.package;

    /* Traverse atom list, searching for extern symbols */
    for (atom = (LispAtom *)hash_iter_first(pack->atoms);
	 atom;
	 atom = (LispAtom *)hash_iter_next(pack->atoms)) {
	if (atom->ext)
	    LispImportSymbol(atom->object);
    }
}

/* symbol must be of type LispAtom_t */
void
LispImportSymbol(LispObj *symbol)
{
    int increment;
    LispAtom *atom;
    LispObj *current;

    current = LispGetVarPack(symbol);
    if (current == NULL || current->data.atom->property == NOPROPERTY) {
	/* No conflicts */

	if (symbol->data.atom->a_object) {
	    /* If it is a bounded variable */
	    if (lisp__data.pack->glb.length + 1 >= lisp__data.pack->glb.space)
		LispMoreGlobals(lisp__data.pack);
	    lisp__data.pack->glb.pairs[lisp__data.pack->glb.length++] = symbol;
	}

	/* Create copy of atom in current package */
	atom = LispDoGetAtom(ATOMID(symbol)->value, 0);
	/*   Need to create a copy because if anything new is atached to the
	 * property, the current package is the owner, not the previous one. */

	/* And reference the same properties */
	atom->property = symbol->data.atom->property;

	increment = 1;
    }
    else if (current->data.atom->property != symbol->data.atom->property) {
	/* Symbol already exists in the current package,
	 * but does not reference the same variable */
	LispContinuable("Symbol %s already defined in package %s. Redefine?",
			ATOMID(symbol)->value, THESTR(PACKAGE->data.package.name));

	atom = current->data.atom;

	/* Continued from error, redefine variable */
	LispDecrementAtomReference(atom);
	atom->property = symbol->data.atom->property;

	atom->a_object = atom->a_function = atom->a_builtin =
	    atom->a_property = atom->a_defsetf = atom->a_defstruct = 0;

	increment = 1;
    }
    else {
	/* Symbol is already available in the current package, just update */
	atom = current->data.atom;

	increment = 0;
    }

    /* If importing an important system variable */
    atom->watch = symbol->data.atom->watch;

    /* Update constant flag */
    atom->constant = symbol->data.atom->constant;

    /* Set home-package and unique-atom associated with symbol */
    atom->package = symbol->data.atom->package;
    atom->object = symbol->data.atom->object;

    if (symbol->data.atom->a_object)
	atom->a_object = 1;
    if (symbol->data.atom->a_function)
	atom->a_function = 1;
    else if (symbol->data.atom->a_builtin)
	atom->a_builtin = 1;
    else if (symbol->data.atom->a_compiled)
	atom->a_compiled = 1;
    if (symbol->data.atom->a_property)
	atom->a_property = 1;
    if (symbol->data.atom->a_defsetf)
	atom->a_defsetf = 1;
    if (symbol->data.atom->a_defstruct)
	atom->a_defstruct = 1;

    if (increment)
	/* Increase reference count, more than one package using the symbol */
	LispIncrementAtomReference(symbol->data.atom);
}

/* symbol must be of type LispAtom_t */
void
LispExportSymbol(LispObj *symbol)
{
    /* This does not automatically export symbols to another package using
     * the symbols of the current package */
    symbol->data.atom->ext = 1;
}

#ifdef __GNUC__
LispObj *
LispGetVar(LispObj *atom)
{
    return (LispDoGetVar(atom));
}

static INLINE LispObj *
LispDoGetVar(LispObj *atom)
#else
#define LispDoGetVar LispGetVar
LispObj *
LispGetVar(LispObj *atom)
#endif
{
    LispAtom *name;
    int i, base, offset;
    Atom_id id;

    name = atom->data.atom;
    if (name->constant && name->package == lisp__data.keyword)
	return (atom);

    /* XXX offset should be stored elsewhere, it is unique, like the string
     * pointer. Unless a multi-thread interface is implemented (where
     * multiple stacks would be required, the offset value should be
     * stored with the string, so that a few cpu cicles could be saved
     * by initializing the value to -1, and only searching for the symbol
     * binding if it is not -1, and if no binding is found, because the
     * lexical scope was left, reset offset to -1. */
    offset = name->offset;
    id = name->key;
    base = lisp__data.env.lex;
    i = lisp__data.env.head - 1;

    if (offset <= i && (offset >= base || name->dyn) &&
	lisp__data.env.names[offset] == id)
	return (lisp__data.env.values[offset]);

    for (; i >= base; i--)
	if (lisp__data.env.names[i] == id) {
	    name->offset = i;

	    return (lisp__data.env.values[i]);
	}

    if (name->dyn) {
	/* Keep searching as maybe a rebound dynamic variable */
	for (; i >= 0; i--)
	    if (lisp__data.env.names[i] == id) {
		name->offset = i;

	    return (lisp__data.env.values[i]);
	}

	if (name->a_object) {
	    /* Check for a symbol defined as special, but not yet bound. */
	    if (name->property->value == UNBOUND)
		return (NULL);

	    return (name->property->value);
	}
    }

    return (name->a_object ? name->property->value : NULL);
}

#ifdef DEBUGGER
/* Same code as LispDoGetVar, but returns the address of the pointer to
 * the object value. Used only by the debugger */
void *
LispGetVarAddr(LispObj *atom)
{
    LispAtom *name;
    int i, base;
    Atom_id id;

    name = atom->data.atom;
    if (name->constant && name->package == lisp__data.keyword)
	return (&atom);

    id = name->string;

    i = lisp__data.env.head - 1;
    for (base = lisp__data.env.lex; i >= base; i--)
	if (lisp__data.env.names[i] == id)
	    return (&(lisp__data.env.values[i]));

    if (name->dyn) {
	for (; i >= 0; i--)
	    if (lisp__data.env.names[i] == id)
		return (&(lisp__data.env.values[i]));

	if (name->a_object) {
	    /* Check for a symbol defined as special, but not yet bound */
	    if (name->property->value == UNBOUND)
		return (NULL);

	    return (&(name->property->value));
	}
    }

    return (name->a_object ? &(name->property->value) : NULL);
}
#endif

/* Only removes global variables. To be called by makunbound
 * Local variables are unbounded once their block is closed anyway.
 */
void
LispUnsetVar(LispObj *atom)
{
    LispAtom *name = atom->data.atom;

    if (name->package) {
	int i;
	LispPackage *pack = name->package->data.package.package;

	for (i = pack->glb.length - 1; i > 0; i--)
	    if (pack->glb.pairs[i] == atom) {
		LispRemAtomObjectProperty(name);
		--pack->glb.length;
		if (i < pack->glb.length)
		    memmove(pack->glb.pairs + i, pack->glb.pairs + i + 1,
			    sizeof(LispObj*) * (pack->glb.length - i));

		/* unset hint about dynamically binded variable */
		if (name->dyn)
		    name->dyn = 0;
		break;
	    }
    }
}

LispObj *
LispAddVar(LispObj *atom, LispObj *obj)
{
    if (lisp__data.env.length >= lisp__data.env.space)
	LispMoreEnvironment();

    LispDoAddVar(atom, obj);

    return (obj);
}

static INLINE void
LispDoAddVar(LispObj *symbol, LispObj *value)
{
    LispAtom *atom = symbol->data.atom;

    atom->offset = lisp__data.env.length;
    lisp__data.env.values[lisp__data.env.length] = value;
    lisp__data.env.names[lisp__data.env.length++] = atom->key;
}

LispObj *
LispSetVar(LispObj *atom, LispObj *obj)
{
    LispPackage *pack;
    LispAtom *name;
    int i, base, offset;
    Atom_id id;

    name = atom->data.atom;
    offset = name->offset;
    id = name->key;
    base = lisp__data.env.lex;
    i = lisp__data.env.head - 1;

    if (offset <= i && (offset >= base || name->dyn) &&
	lisp__data.env.names[offset] == id)
	return (lisp__data.env.values[offset] = obj);

    for (; i >= base; i--)
	if (lisp__data.env.names[i] == id) {
	    name->offset = i;

	    return (lisp__data.env.values[i] = obj);
	}

    if (name->dyn) {
	for (; i >= 0; i--)
	    if (lisp__data.env.names[i] == id)
		return (lisp__data.env.values[i] = obj);

	if (name->watch) {
	    LispSetAtomObjectProperty(name, obj);

	    return (obj);
	}

	return (SETVALUE(name, obj));
    }

    if (name->a_object) {
	if (name->watch) {
	    LispSetAtomObjectProperty(name, obj);

	    return (obj);
	}

	return (SETVALUE(name, obj));
    }

    LispSetAtomObjectProperty(name, obj);

    pack = name->package->data.package.package;
    if (pack->glb.length >= pack->glb.space)
	LispMoreGlobals(pack);

    pack->glb.pairs[pack->glb.length++] = atom;

    return (obj);
}

void
LispProclaimSpecial(LispObj *atom, LispObj *value, LispObj *doc)
{
    int i = 0, dyn, glb;
    LispAtom *name;
    LispPackage *pack;

    glb = 0;
    name = atom->data.atom;
    pack = name->package->data.package.package;
    dyn = name->dyn;

    if (!dyn) {
	/* Note: don't check if a local variable already is using the symbol */
	for (i = pack->glb.length - 1; i >= 0; i--)
	    if (pack->glb.pairs[i] == atom) {
		glb = 1;
		break;
	    }
    }

    if (dyn) {
	if (name->property->value == UNBOUND && value)
	    /* if variable was just made special, but not bounded */
	    LispSetAtomObjectProperty(name, value);
    }
    else if (glb)
	/* Already a global variable, but not marked as special.
	 * Set hint about dynamically binded variable. */
	name->dyn = 1;
    else {
	/* create new special variable */
	LispSetAtomObjectProperty(name, value ? value : UNBOUND);

	if (pack->glb.length >= pack->glb.space)
	    LispMoreGlobals(pack);

	pack->glb.pairs[pack->glb.length] = atom;
	++pack->glb.length;
	/* set hint about possibly dynamically binded variable */
	name->dyn = 1;
    }

    if (doc != NIL)
	LispAddDocumentation(atom, doc, LispDocVariable);
}

void
LispDefconstant(LispObj *atom, LispObj *value, LispObj *doc)
{
    int i;
    LispAtom *name = atom->data.atom;
    LispPackage *pack = name->package->data.package.package;

    /* Unset hint about dynamically binded variable, if set. */
    name->dyn = 0;

    /* Check if variable is bounded as a global variable */
    for (i = pack->glb.length - 1; i >= 0; i--)
	if (pack->glb.pairs[i] == atom)
	    break;

    if (i < 0) {
	/* Not a global variable */
	if (pack->glb.length >= pack->glb.space)
	    LispMoreGlobals(pack);

	pack->glb.pairs[pack->glb.length] = atom;
	++pack->glb.length;
    }

    /* If already a constant variable */
    if (name->constant && name->a_object && name->property->value != value)
	LispWarning("constant %s is being redefined", STROBJ(atom));
    else
	name->constant = 1;

    /* Set constant value */
    LispSetAtomObjectProperty(name, value);

    if (doc != NIL)
	LispAddDocumentation(atom, doc, LispDocVariable);
}

void
LispAddDocumentation(LispObj *symbol, LispObj *documentation, LispDocType_t type)
{
    int length;
    char *string;
    LispAtom *atom;
    LispObj *object;

    if (!SYMBOLP(symbol) || !STRINGP(documentation))
	LispDestroy("DOCUMENTATION: invalid argument");

    atom = symbol->data.atom;
    if (atom->documentation[type])
	LispRemDocumentation(symbol, type);

    /* allocate documentation in atomseg */
    if (atomseg.freeobj == NIL)
	LispAllocSeg(&atomseg, pagesize);
    length = STRLEN(documentation);
    string = LispMalloc(length);
    memcpy(string, THESTR(documentation), length);
    string[length] = '\0';
    object = atomseg.freeobj;
    atomseg.freeobj = CDR(object);
    --atomseg.nfree;

    object->type = LispString_t;
    THESTR(object) = string;
    STRLEN(object) = length;
    object->data.string.writable = 0;
    atom->documentation[type] = object;
    LispMused(string);
}

void
LispRemDocumentation(LispObj *symbol, LispDocType_t type)
{
    LispAtom *atom;

    if (!SYMBOLP(symbol))
	LispDestroy("DOCUMENTATION: invalid argument");

    atom = symbol->data.atom;
    if (atom->documentation[type]) {
	/* reclaim object to atomseg */
	free(THESTR(atom->documentation[type]));
	CDR(atom->documentation[type]) = atomseg.freeobj;
	atomseg.freeobj = atom->documentation[type];
	atom->documentation[type] = NULL;
	++atomseg.nfree;
    }
}

LispObj *
LispGetDocumentation(LispObj *symbol, LispDocType_t type)
{
    LispAtom *atom;

    if (!SYMBOLP(symbol))
	LispDestroy("DOCUMENTATION: invalid argument");

    atom = symbol->data.atom;

    return (atom->documentation[type] ? atom->documentation[type] : NIL);
}

LispObj *
LispReverse(LispObj *list)
{
    LispObj *tmp, *res = NIL;

    while (list != NIL) {
	tmp = CDR(list);
	CDR(list) = res;
	res = list;
	list = tmp;
    }

    return (res);
}

LispBlock *
LispBeginBlock(LispObj *tag, LispBlockType type)
{
    LispBlock *block;
    unsigned blevel = lisp__data.block.block_level + 1;

    if (blevel > lisp__data.block.block_size) {
	LispBlock **blk;

	if (blevel > MAX_STACK_DEPTH)
	    LispDestroy("stack overflow");

	DISABLE_INTERRUPTS();
	blk = realloc(lisp__data.block.block, sizeof(LispBlock*) * (blevel + 1));

	block = NULL;
	if (blk == NULL || (block = malloc(sizeof(LispBlock))) == NULL) {
	    ENABLE_INTERRUPTS();
	    LispDestroy("out of memory");
	}
	lisp__data.block.block = blk;
	lisp__data.block.block[lisp__data.block.block_size] = block;
	lisp__data.block.block_size = blevel;
	ENABLE_INTERRUPTS();
    }
    block = lisp__data.block.block[lisp__data.block.block_level];
    if (type == LispBlockCatch && !CONSTANTP(tag)) {
	tag = EVAL(tag);
	lisp__data.protect.objects[lisp__data.protect.length++] = tag;
    }
    block->type = type;
    block->tag = tag;
    block->stack = lisp__data.stack.length;
    block->protect = lisp__data.protect.length;
    block->block_level = lisp__data.block.block_level;

    lisp__data.block.block_level = blevel;

#ifdef DEBUGGER
    if (lisp__data.debugging) {
	block->debug_level = lisp__data.debug_level;
	block->debug_step = lisp__data.debug_step;
    }
#endif

    return (block);
}

void
LispEndBlock(LispBlock *block)
{
    lisp__data.protect.length = block->protect;
    lisp__data.block.block_level = block->block_level;

#ifdef DEBUGGER
    if (lisp__data.debugging) {
	if (lisp__data.debug_level >= block->debug_level) {
	    while (lisp__data.debug_level > block->debug_level) {
		DBG = CDR(DBG);
		--lisp__data.debug_level;
	    }
	}
	lisp__data.debug_step = block->debug_step;
    }
#endif
}

void
LispBlockUnwind(LispBlock *block)
{
    LispBlock *unwind;
    int blevel = lisp__data.block.block_level;

    while (blevel > 0) {
	unwind = lisp__data.block.block[--blevel];
	if (unwind->type == LispBlockProtect) {
	    BLOCKJUMP(unwind);
	}
	if (unwind == block)
	    /* jump above unwind block */
	    break;
    }
}

static LispObj *
LispEvalBackquoteObject(LispObj *argument, int list, int quote)
{
    LispObj *result = argument, *object;

    if (!POINTERP(argument))
	return (argument);

    else if (XCOMMAP(argument)) {
	/* argument may need to be evaluated */

	int atlist;

	if (!list && argument->data.comma.atlist)
	    /* cannot append, not in a list */
	    LispDestroy("EVAL: ,@ only allowed on lists");

	--quote;
	if (quote < 0)
	    LispDestroy("EVAL: comma outside of backquote");

	result = object = argument->data.comma.eval;
	atlist = COMMAP(object) && object->data.comma.atlist;

	if (POINTERP(result) && (XCOMMAP(result) || XBACKQUOTEP(result)))
	    /* nested commas, reduce 1 level, or backquote,
	     * don't call LispEval or quote argument will be reset */
	    result = LispEvalBackquoteObject(object, 0, quote);

	else if (quote == 0)
	   /* just evaluate it */
	    result = EVAL(result);

	if (quote != 0)
	    result = result == object ? argument : COMMA(result, atlist);
    }

    else if (XBACKQUOTEP(argument)) {
	object = argument->data.quote;

	result = LispEvalBackquote(object, quote + 1);
	if (quote)
	    result = result == object ? argument : BACKQUOTE(result);
    }

    else if (XQUOTEP(argument) && POINTERP(argument->data.quote) &&
	     (XCOMMAP(argument->data.quote) ||
	      XBACKQUOTEP(argument->data.quote) ||
	      XCONSP(argument->data.quote))) {
	/* ensures `',sym to be the same as `(quote ,sym) */
	object = argument->data.quote;

	result = LispEvalBackquote(argument->data.quote, quote);
	result = result == object ? argument : QUOTE(result);
    }

    return (result);
}

LispObj *
LispEvalBackquote(LispObj *argument, int quote)
{
    int protect;
    LispObj *result, *object, *cons, *cdr;

    if (!CONSP(argument))
	return (LispEvalBackquoteObject(argument, 0, quote));

    result = cdr = NIL;
    protect = lisp__data.protect.length;

    /* always generate a new list for the result, even if nothing
     * is evaluated. It is not expected to use backqoutes when
     * not required. */

    /* reserve a GC protected slot for the result */
    if (protect + 1 >= lisp__data.protect.space)
	LispMoreProtects();
    lisp__data.protect.objects[lisp__data.protect.length++] = NIL;

    for (cons = argument; ; cons = CDR(cons)) {
	/* if false, last argument, and if cons is not NIL, a dotted list */
	int list = CONSP(cons), insert;

	if (list)
	    object = CAR(cons);
	else
	    object = cons;

	if (COMMAP(object))
	    /* need to insert list elements in result, not just cons it? */
	    insert = object->data.comma.atlist;
	else
	    insert = 0;

	/* evaluate object, if required */
	if (CONSP(object))
	    object = LispEvalBackquote(object, quote);
	else
	    object = LispEvalBackquoteObject(object, insert, quote);

	if (result == NIL) {
	    /* if starting result list */
	    if (!insert) {
		if (list)
		    result = cdr = CONS(object, NIL);
		else
		    result = cdr = object;
		/* gc protect result */
		lisp__data.protect.objects[protect] = result;
	    }
	    else {
		if (!CONSP(object)) {
		    result = cdr = object;
		    /* gc protect result */
		    lisp__data.protect.objects[protect] = result;
		}
		else {
		    result = cdr = CONS(CAR(object), NIL);
		    /* gc protect result */
		    lisp__data.protect.objects[protect] = result;

		    /* add remaining elements to result */
		    for (object = CDR(object);
			 CONSP(object);
			 object = CDR(object)) {
			RPLACD(cdr, CONS(CAR(object), NIL));
			cdr = CDR(cdr);
		    }
		    if (object != NIL) {
			/* object was a dotted list */
			RPLACD(cdr, object);
			cdr = CDR(cdr);
		    }
		}
	    }
	}
	else {
	    if (!CONSP(cdr))
		LispDestroy("EVAL: cannot append to %s", STROBJ(cdr));

	    if (!insert) {
		if (list) {
		    RPLACD(cdr, CONS(object, NIL));
		    cdr = CDR(cdr);
		}
		else {
		    RPLACD(cdr, object);
		    cdr = object;
		}
	    }
	    else {
		if (!CONSP(object)) {
		    RPLACD(cdr, object);
		    /* if object is NIL, it is a empty list appended, not
		     * creating a dotted list. */
		    if (object != NIL)
			cdr = object;
		}
		else {
		    for (; CONSP(object); object = CDR(object)) {
			RPLACD(cdr, CONS(CAR(object), NIL));
			cdr = CDR(cdr);
		    }
		    if (object != NIL) {
			/* object was a dotted list */
			RPLACD(cdr, object);
			cdr = CDR(cdr);
		    }
		}
	    }
	}

	/* if last argument list element processed */
	if (!list)
	    break;
    }

    lisp__data.protect.length = protect;

    return (result);
}

void
LispMoreEnvironment(void)
{
    Atom_id *names;
    LispObj **values;

    DISABLE_INTERRUPTS();
    names = realloc(lisp__data.env.names,
		    (lisp__data.env.space + 256) * sizeof(Atom_id));
    if (names != NULL) {
	values = realloc(lisp__data.env.values,
			 (lisp__data.env.space + 256) * sizeof(LispObj*));
	if (values != NULL) {
	    lisp__data.env.names = names;
	    lisp__data.env.values = values;
	    lisp__data.env.space += 256;
	    ENABLE_INTERRUPTS();
	    return;
	}
	else
	    free(names);
    }
    ENABLE_INTERRUPTS();
    LispDestroy("out of memory");
}

void
LispMoreStack(void)
{
    LispObj **values;

    DISABLE_INTERRUPTS();
    values = realloc(lisp__data.stack.values,
		     (lisp__data.stack.space + 256) * sizeof(LispObj*));
    if (values == NULL) {
	ENABLE_INTERRUPTS();
	LispDestroy("out of memory");
    }
    lisp__data.stack.values = values;
    lisp__data.stack.space += 256;
    ENABLE_INTERRUPTS();
}

void
LispMoreGlobals(LispPackage *pack)
{
    LispObj **pairs;

    DISABLE_INTERRUPTS();
    pairs = realloc(pack->glb.pairs,
		    (pack->glb.space + 256) * sizeof(LispObj*));
    if (pairs == NULL) {
	ENABLE_INTERRUPTS();
	LispDestroy("out of memory");
    }
    pack->glb.pairs = pairs;
    pack->glb.space += 256;
    ENABLE_INTERRUPTS();
}

void
LispMoreProtects(void)
{
    LispObj **objects;

    DISABLE_INTERRUPTS();
    objects = realloc(lisp__data.protect.objects,
		      (lisp__data.protect.space + 256) * sizeof(LispObj*));
    if (objects == NULL) {
	ENABLE_INTERRUPTS();
	LispDestroy("out of memory");
    }
    lisp__data.protect.objects = objects;
    lisp__data.protect.space += 256;
    ENABLE_INTERRUPTS();
}

static int
LispMakeEnvironment(LispArgList *alist, LispObj *values,
		    LispObj *name, int eval, int builtin)
{
    char *desc;
    int i, count, base;
    LispObj **symbols, **defaults, **sforms;

#define BUILTIN_ARGUMENT(value)				\
    lisp__data.stack.values[lisp__data.stack.length++] = value

/* If the index value is from register variables, this
 * can save some cpu time. Useful for normal arguments
 * that are the most common, and thus the ones that
 * consume more time in LispMakeEnvironment. */
#define BUILTIN_NO_EVAL_ARGUMENT(index, value)		\
    lisp__data.stack.values[index] = value

#define NORMAL_ARGUMENT(symbol, value)			\
    LispDoAddVar(symbol, value)

    if (builtin) {
	base = lisp__data.stack.length;
	if (base + alist->num_arguments > lisp__data.stack.space) {
	    do
		LispMoreStack();
	    while (base + alist->num_arguments > lisp__data.stack.space);
	}
    }
    else {
	base = lisp__data.env.length;
	if (base + alist->num_arguments > lisp__data.env.space) {
	    do
		LispMoreEnvironment();
	    while (base + alist->num_arguments > lisp__data.env.space);
	}
    }

    desc = alist->description;
    switch (*desc++) {
	case '.':
	    goto normal_label;
	case 'o':
	    goto optional_label;
	case 'k':
	    goto key_label;
	case 'r':
	    goto rest_label;
	case 'a':
	    goto aux_label;
	default:
	    goto done_label;
    }


    /* Code below is done in several almost identical loops, to avoid
     * checking the value of the arguments eval and builtin too much times */


    /* Normal arguments */
normal_label:
    i = 0;
    count = alist->normals.num_symbols;
    if (builtin) {
	if (eval) {
	    for (; i < count && CONSP(values); i++, values = CDR(values)) {
		BUILTIN_ARGUMENT(EVAL(CAR(values)));
	    }
	}
	else {
	    for (; i < count && CONSP(values); i++, values = CDR(values)) {
		BUILTIN_NO_EVAL_ARGUMENT(base + i, CAR(values));
	    }
	    /* macro BUILTIN_NO_EVAL_ARGUMENT does not update
	     * lisp__data.stack.length, as there is no risk of GC while
	     * adding the arguments. */
	    lisp__data.stack.length += i;
	}
    }
    else {
	symbols = alist->normals.symbols;
	if (eval) {
	    for (; i < count && CONSP(values); i++, values = CDR(values)) {
		NORMAL_ARGUMENT(symbols[i], EVAL(CAR(values)));
	    }
	}
	else {
	    for (; i < count && CONSP(values); i++, values = CDR(values)) {
		NORMAL_ARGUMENT(symbols[i], CAR(values));
	    }
	}
    }
    if (i < count)
	LispDestroy("%s: too few arguments", STROBJ(name));

    switch (*desc++) {
	case 'o':
	    goto optional_label;
	case 'k':
	    goto key_label;
	case 'r':
	    goto rest_label;
	case 'a':
	    goto aux_label;
	default:
	    goto done_label;
    }

    /* &OPTIONAL */
optional_label:
    i = 0;
    count = alist->optionals.num_symbols;
    defaults = alist->optionals.defaults;
    sforms = alist->optionals.sforms;
    if (builtin) {
	if (eval) {
	    for (; i < count && CONSP(values); i++, values = CDR(values))
		BUILTIN_ARGUMENT(EVAL(CAR(values)));
	    for (; i < count; i++)
		BUILTIN_ARGUMENT(UNSPEC);
	}
	else {
	    for (; i < count && CONSP(values); i++, values = CDR(values))
		BUILTIN_ARGUMENT(CAR(values));
	    for (; i < count; i++)
		BUILTIN_ARGUMENT(UNSPEC);
	}
    }
    else {
	symbols = alist->optionals.symbols;
	if (eval) {
	    for (; i < count && CONSP(values); i++, values = CDR(values)) {
		NORMAL_ARGUMENT(symbols[i], EVAL(CAR(values)));
		if (sforms[i]) {
		    NORMAL_ARGUMENT(sforms[i], T);
		}
	    }
	}
	else {
	    for (; i < count && CONSP(values); i++, values = CDR(values)) {
		NORMAL_ARGUMENT(symbols[i], CAR(values));
		if (sforms[i]) {
		    NORMAL_ARGUMENT(sforms[i], T);
		}
	    }
	}

	/* default arguments are evaluated for macros */
	for (; i < count; i++) {
	    if (!CONSTANTP(defaults[i])) {
		int head = lisp__data.env.head;
		int lex = lisp__data.env.lex;

		lisp__data.env.lex = base;
		lisp__data.env.head = lisp__data.env.length;
		NORMAL_ARGUMENT(symbols[i], EVAL(defaults[i]));
		lisp__data.env.head = head;
		lisp__data.env.lex = lex;
	    }
	    else {
		NORMAL_ARGUMENT(symbols[i], defaults[i]);
	    }
	    if (sforms[i]) {
		NORMAL_ARGUMENT(sforms[i], NIL);
	    }
	}
    }
    switch (*desc++) {
	case 'k':
	    goto key_label;
	case 'r':
	    goto rest_label;
	case 'a':
	    goto aux_label;
	default:
	    goto done_label;
    }

    /* &KEY */
key_label:
    {
	int argc, nused;
	LispObj *val, *karg, **keys;

	/* Count number of remaining arguments */
	for (karg = values, argc = 0; CONSP(karg); karg = CDR(karg), argc++) {
	    karg = CDR(karg);
	    if (!CONSP(karg))
		LispDestroy("%s: &KEY needs arguments as pairs",
			    STROBJ(name));
	}


	/* OPTIMIZATION:
	 * Builtin functions require that the keyword be in the keyword package.
	 * User functions don't need the arguments being pushed in the stack
	 * in the declared order (bytecode expects it...).
	 * XXX Error checking should be done elsewhere, code may be looping
	 * and doing error check here may consume too much cpu time.
	 * XXX Would also be good to already have the arguments specified in
	 * the correct order.
	 */


	nused = 0;
	val = NIL;
	count = alist->keys.num_symbols;
	symbols = alist->keys.symbols;
	defaults = alist->keys.defaults;
	sforms = alist->keys.sforms;
	if (builtin) {

	    /* Arguments must be created in the declared order */
	    i = 0;
	    if (eval) {
		for (; i < count; i++) {
		    for (karg = values; CONSP(karg); karg = CDDR(karg)) {
			/* This is only true if both point to the
			 * same symbol in the keyword package. */
			if (symbols[i] == CAR(karg)) {
			    if (karg == values)
				values = CDDR(values);
			    ++nused;
			    BUILTIN_ARGUMENT(EVAL(CADR(karg)));
			    goto keyword_builtin_eval_used_label;
			}
		    }
		    BUILTIN_ARGUMENT(UNSPEC);
keyword_builtin_eval_used_label:;
		}
	    }
	    else {
		for (; i < count; i++) {
		    for (karg = values; CONSP(karg); karg = CDDR(karg)) {
			if (symbols[i] == CAR(karg)) {
			    if (karg == values)
				values = CDDR(values);
			    ++nused;
			    BUILTIN_ARGUMENT(CADR(karg));
			    goto keyword_builtin_used_label;
			}
		    }
		    BUILTIN_ARGUMENT(UNSPEC);
keyword_builtin_used_label:;
		}
	    }

	    if (argc != nused) {
		/* Argument(s) may be incorrectly specified, or specified
		 * twice (what is not an error). */
		for (karg = values; CONSP(karg); karg = CDDR(karg)) {
		    val = CAR(karg);
		    if (KEYWORDP(val)) {
			for (i = 0; i < count; i++)
			    if (symbols[i] == val)
				break;
		    }
		    else
			/* Just make the error test true */
			i = count;

		    if (i == count)
			goto invalid_keyword_label;
		}
	    }
	}

#if 0
	else {
	    /* The base offset of the atom in the stack, to check for
	     * keywords specified twice. */
	    LispObj *symbol;
	    int offset = lisp__data.env.length;

	    keys = alist->keys.keys;
	    for (karg = values; CONSP(karg); karg = CDDR(karg)) {
		symbol = CAR(karg);
		if (SYMBOLP(symbol)) {
		    /* Must be a keyword, but even if it is a keyword, may
		     * be a typo, so assume it is correct. If it is not
		     * in the argument list, it is an error. */
		    for (i = 0; i < count; i++) {
			if (!keys[i] && symbols[i] == symbol) {
			    LispAtom *atom = symbol->data.atom;

			    /* Symbol found in the argument list. */
			    if (atom->offset >= offset &&
				atom->offset < offset + nused &&
				lisp__data.env.names[atom->offset] ==
				atom->string)
				/* Specified more than once... */
				goto keyword_duplicated_label;
			    break;
			}
		    }
		}
		else {
		    Atom_id id;

		    if (!QUOTEP(symbol) || !SYMBOLP(val = symbol->data.quote)) {
			/* Bad argument. */
			val = symbol;
			goto invalid_keyword_label;
		    }

		    id = ATOMID(val);
		    for (i = 0; i < count; i++) {
			if (keys[i] && ATOMID(keys[i]) == id) {
			    LispAtom *atom = val->data.atom;

			    /* Symbol found in the argument list. */
			    if (atom->offset >= offset &&
				atom->offset < offset + nused &&
				lisp__data.env.names[atom->offset] ==
				atom->string)
				/* Specified more than once... */
				goto keyword_duplicated_label;
			    break;
			}
		    }
		}
		if (i == count) {
		    /* Argument specification not found. */
		    val = symbol;
		    goto invalid_keyword_label;
		}
		++nused;
		if (eval) {
		    NORMAL_ARGUMENT(symbols[i], EVAL(CADR(karg)));
		}
		else {
		    NORMAL_ARGUMENT(symbols[i], CADR(karg));
		}
		if (sforms[i]) {
		    NORMAL_ARGUMENT(sforms[i], T);
		}
keyword_duplicated_label:;
	    }

	    /* Add variables that were not specified in the function call. */
	    if (nused < count) {
		int j;

		for (i = 0; i < count; i++) {
		    Atom_id id = ATOMID(symbols[i]);

		    for (j = offset + nused - 1; j >= offset; j--) {
			if (lisp__data.env.names[j] == id)
			    break;
		    }

		    if (j < offset) {
			/* Argument not specified. Use default value */

			/* default arguments are evaluated for macros */
			if (!CONSTANTP(defaults[i])) {
			    int head = lisp__data.env.head;
			    int lex = lisp__data.env.lex;

			    lisp__data.env.lex = base;
			    lisp__data.env.head = lisp__data.env.length;
			    NORMAL_ARGUMENT(symbols[i], EVAL(defaults[i]));
			    lisp__data.env.head = head;
			    lisp__data.env.lex = lex;
			}
			else {
			    NORMAL_ARGUMENT(symbols[i], defaults[i]);
			}
			if (sforms[i]) {
			    NORMAL_ARGUMENT(sforms[i], NIL);
			}
		    }
		}
	    }
	}
#else
	else {
	    int varset;

	    sforms = alist->keys.sforms;
	    keys = alist->keys.keys;

	    /* Add variables */
	    for (i = 0; i < alist->keys.num_symbols; i++) {
		val = defaults[i];
		varset = 0;
		if (keys[i]) {
		    Atom_id atom = ATOMID(keys[i]);

		    /* Special keyword specification, need to compare ATOMID
		     * and keyword specification must be a quoted object */
		    for (karg = values; CONSP(karg); karg = CDR(karg)) {
			val = CAR(karg);
		 	if (QUOTEP(val) && atom == ATOMID(val->data.quote)) {
			    val = CADR(karg);
			    varset = 1;
			    ++nused;
			    break;
			}
			karg = CDR(karg);
		    }
		}

		else {
		    /* Normal keyword specification, can compare object pointers,
		     * as they point to the same object in the keyword package */
		    for (karg = values; CONSP(karg); karg = CDR(karg)) {
			/* Don't check if argument is a valid keyword or
			 * special quoted keyword */
			if (symbols[i] == CAR(karg)) {
			    val = CADR(karg);
			    varset = 1;
			    ++nused;
			    break;
			}
			karg = CDR(karg);
		    }
		}

		/* Add the variable to environment */
		if (varset) {
		    NORMAL_ARGUMENT(symbols[i], eval ? EVAL(val) : val);
		    if (sforms[i]) {
			NORMAL_ARGUMENT(sforms[i], T);
		    }
		}
		else {
		    /* default arguments are evaluated for macros */
		    if (!CONSTANTP(val)) {
			int head = lisp__data.env.head;
			int lex = lisp__data.env.lex;

			lisp__data.env.lex = base;
			lisp__data.env.head = lisp__data.env.length;
			NORMAL_ARGUMENT(symbols[i], EVAL(val));
			lisp__data.env.head = head;
			lisp__data.env.lex = lex;
		    }
		    else {
			NORMAL_ARGUMENT(symbols[i], val);
		    }
		    if (sforms[i]) {
			NORMAL_ARGUMENT(sforms[i], NIL);
		    }
		}
	    }

	    if (argc != nused) {
		/* Argument(s) may be incorrectly specified, or specified
		 * twice (what is not an error). */
		for (karg = values; CONSP(karg); karg = CDDR(karg)) {
		    val = CAR(karg);
		    if (KEYWORDP(val)) {
			for (i = 0; i < count; i++)
			    if (symbols[i] == val)
				break;
		    }
		    else if (QUOTEP(val) && SYMBOLP(val->data.quote)) {
			Atom_id atom = ATOMID(val->data.quote);

			for (i = 0; i < count; i++)
			    if (ATOMID(keys[i]) == atom)
				break;
		    }
		    else
			/* Just make the error test true */
			i = count;

		    if (i == count)
			goto invalid_keyword_label;
		}
	    }
	}
#endif
	goto check_aux_label;

invalid_keyword_label:
	{
	    /* If not in argument specification list... */
	    char function_name[36];

	    strcpy(function_name, STROBJ(name));
	    LispDestroy("%s: %s is an invalid keyword",
			function_name, STROBJ(val));
	}
    }

check_aux_label:
    if (*desc == 'a') {
	/* &KEY uses all remaining arguments */
	values = NIL;
	goto aux_label;
    }
    goto finished_label;

    /* &REST */
rest_label:
    if (!CONSP(values)) {
	if (builtin) {
	    BUILTIN_ARGUMENT(values);
	}
	else {
	    NORMAL_ARGUMENT(alist->rest, values);
	}
	values = NIL;
    }
    /* always allocate a new list, don't know if it will be retained */
    else if (eval) {
	LispObj *cons;

	cons = CONS(EVAL(CAR(values)), NIL);
	if (builtin) {
	    BUILTIN_ARGUMENT(cons);
	}
	else {
	    NORMAL_ARGUMENT(alist->rest, cons);
	}
	values = CDR(values);
	for (; CONSP(values); values = CDR(values)) {
	    RPLACD(cons, CONS(EVAL(CAR(values)), NIL));
	    cons = CDR(cons);
	}
    }
    else {
	LispObj *cons;

	cons = CONS(CAR(values), NIL);
	if (builtin) {
	    BUILTIN_ARGUMENT(cons);
	}
	else {
	    NORMAL_ARGUMENT(alist->rest, cons);
	}
	values = CDR(values);
	for (; CONSP(values); values = CDR(values)) {
	    RPLACD(cons, CONS(CAR(values), NIL));
	    cons = CDR(cons);
	}
    }
    if (*desc != 'a')
	goto finished_label;

    /* &AUX */
aux_label:
    i = 0;
    count = alist->auxs.num_symbols;
    defaults = alist->auxs.initials;
    symbols = alist->auxs.symbols;
    {
	int lex = lisp__data.env.lex;

	lisp__data.env.lex = base;
	lisp__data.env.head = lisp__data.env.length;
	for (; i < count; i++) {
	    NORMAL_ARGUMENT(symbols[i], EVAL(defaults[i]));
	    ++lisp__data.env.head;
	}
	lisp__data.env.lex = lex;
    }

done_label:
    if (CONSP(values))
	LispDestroy("%s: too many arguments", STROBJ(name));

finished_label:
    if (builtin)
	lisp__data.stack.base = base;
    else {
	lisp__data.env.head = lisp__data.env.length;
    }
#undef BULTIN_ARGUMENT
#undef NORMAL_ARGUMENT
#undef BUILTIN_NO_EVAL_ARGUMENT

    return (base);
}

LispObj *
LispFuncall(LispObj *function, LispObj *arguments, int eval)
{
    LispAtom *atom;
    LispArgList *alist;
    LispBuiltin *builtin;
    LispObj *lambda, *result;
    int macro, base;

#ifdef DEBUGGER
    if (lisp__data.debugging)
	LispDebugger(LispDebugCallBegin, function, arguments);
#endif

    switch (OBJECT_TYPE(function)) {
	case LispFunction_t:
	    function = function->data.atom->object;
	case LispAtom_t:
	    atom = function->data.atom;
	    if (atom->a_builtin) {
		builtin = atom->property->fun.builtin;

		if (eval)
		    eval = builtin->type != LispMacro;
		base = LispMakeEnvironment(atom->property->alist,
					   arguments, function, eval, 1);
		if (builtin->multiple_values) {
		    RETURN_COUNT = 0;
		    result = builtin->function(builtin);
		}
		else {
		    result = builtin->function(builtin);
		    RETURN_COUNT = 0;
		}
		lisp__data.stack.base = lisp__data.stack.length = base;
	    }
	    else if (atom->a_compiled) {
		int lex = lisp__data.env.lex;
		lambda = atom->property->fun.function;
		alist = atom->property->alist;

		base = LispMakeEnvironment(alist, arguments, function, eval, 0);
		lisp__data.env.lex = base;
		result = LispExecuteBytecode(lambda);
		lisp__data.env.lex = lex;
		lisp__data.env.head = lisp__data.env.length = base;
	    }
	    else if (atom->a_function) {
		lambda = atom->property->fun.function;
		macro = lambda->funtype == LispMacro;
		alist = atom->property->alist;

		lambda = lambda->data.lambda.code;
		if (eval)
		    eval = !macro;
		base = LispMakeEnvironment(alist, arguments, function, eval, 0);
		result = LispRunFunMac(function, lambda, macro, base);
	    }
	    else if (atom->a_defstruct &&
		     atom->property->structure.function != STRUCT_NAME) {
		LispObj cons;

		if (atom->property->structure.function == STRUCT_CONSTRUCTOR)
		    atom = Omake_struct->data.atom;
		else if (atom->property->structure.function == STRUCT_CHECK)
		    atom = Ostruct_type->data.atom;
		else
		    atom = Ostruct_access->data.atom;
		builtin = atom->property->fun.builtin;

		cons.type = LispCons_t;
		cons.data.cons.cdr = arguments;
		if (eval) {
		    LispObj quote;

		    quote.type = LispQuote_t;
		    quote.data.quote = function;
		    cons.data.cons.car = &quote;
		    base = LispMakeEnvironment(atom->property->alist,
					       &cons, function, 1, 1);
		}
		else {
		    cons.data.cons.car = function;
		    base = LispMakeEnvironment(atom->property->alist,
					       &cons, function, 0, 1);
		}
		result = builtin->function(builtin);
		RETURN_COUNT = 0;
		lisp__data.stack.length = base;
	    }
	    else {
		LispDestroy("EVAL: the function %s is not defined",
			    STROBJ(function));
		/*NOTREACHED*/
		result = NIL;
	    }
	    break;
	case LispLambda_t:
	    lambda = function->data.lambda.code;
	    alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
	    base = LispMakeEnvironment(alist, arguments, function, eval, 0);
	    result = LispRunFunMac(function, lambda, 0, base);
	    break;
	case LispCons_t:
	    if (CAR(function) == Olambda) {
		function = EVAL(function);
		if (LAMBDAP(function)) {
		    GC_ENTER();

		    GC_PROTECT(function);
		    lambda = function->data.lambda.code;
		    alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
		    base = LispMakeEnvironment(alist, arguments, NIL, eval, 0);
		    result = LispRunFunMac(NIL, lambda, 0, base);
		    GC_LEAVE();
		    break;
		}
	    }
	default:
	    LispDestroy("EVAL: %s is invalid as a function",
			STROBJ(function));
	    /*NOTREACHED*/
	    result = NIL;
	    break;
    }

#ifdef DEBUGGER
    if (lisp__data.debugging)
	LispDebugger(LispDebugCallEnd, function, result);
#endif

    return (result);
}

LispObj *
LispEval(LispObj *object)
{
    LispObj *result;

    switch (OBJECT_TYPE(object)) {
	case LispAtom_t:
	    if ((result = LispDoGetVar(object)) == NULL)
		LispDestroy("EVAL: the variable %s is unbound", STROBJ(object));
	    break;
	case LispCons_t:
	    result = LispFuncall(CAR(object), CDR(object), 1);
	    break;
	case LispQuote_t:
	    result = object->data.quote;
	    break;
	case LispFunctionQuote_t:
	    result = object->data.quote;
	    if (SYMBOLP(result))
		result = LispSymbolFunction(result);
	    else if (CONSP(result) && CAR(result) == Olambda)
		result = EVAL(result);
	    else
		LispDestroy("FUNCTION: %s is not a function", STROBJ(result));
	    break;
	case LispBackquote_t:
	    result = LispEvalBackquote(object->data.quote, 1);
	    break;
	case LispComma_t:
	    LispDestroy("EVAL: comma outside of backquote");
	default:
	    result = object;
	    break;
    }

    return (result);
}

LispObj *
LispApply1(LispObj *function, LispObj *argument)
{
    LispObj arguments;

    arguments.type = LispCons_t;
    arguments.data.cons.car = argument;
    arguments.data.cons.cdr = NIL;

    return (LispFuncall(function, &arguments, 0));
}

LispObj *
LispApply2(LispObj *function, LispObj *argument1, LispObj *argument2)
{
    LispObj arguments, cdr;

    arguments.type = cdr.type = LispCons_t;
    arguments.data.cons.car = argument1;
    arguments.data.cons.cdr = &cdr;
    cdr.data.cons.car = argument2;
    cdr.data.cons.cdr = NIL;

    return (LispFuncall(function, &arguments, 0));
}

LispObj *
LispApply3(LispObj *function, LispObj *arg1, LispObj *arg2, LispObj *arg3)
{
    LispObj arguments, car, cdr;

    arguments.type = car.type = cdr.type = LispCons_t;
    arguments.data.cons.car = arg1;
    arguments.data.cons.cdr = &car;
    car.data.cons.car = arg2;
    car.data.cons.cdr = &cdr;
    cdr.data.cons.car = arg3;
    cdr.data.cons.cdr = NIL;

    return (LispFuncall(function, &arguments, 0));
}

static LispObj *
LispRunFunMac(LispObj *name, LispObj *code, int macro, int base)
{
    LispObj *result = NIL;

    if (!macro) {
	int lex = lisp__data.env.lex;
	int did_jump = 1;
	LispBlock *block;

	block = LispBeginBlock(name, LispBlockClosure);
	lisp__data.env.lex = base;
	if (setjmp(block->jmp) == 0) {
	    for (; CONSP(code); code = CDR(code))
		result = EVAL(CAR(code));
	    did_jump = 0;
	}
	LispEndBlock(block);
	if (did_jump)
	    result = lisp__data.block.block_ret;
	lisp__data.env.lex = lex;
	lisp__data.env.head = lisp__data.env.length = base;
    }
    else {
	GC_ENTER();

	for (; CONSP(code); code = CDR(code))
	    result = EVAL(CAR(code));
	/* FIXME this does not work if macro has &aux variables,
	 * but there are several other missing features, like
	 * destructuring and more lambda list keywords still missing.
	 * TODO later.
	 */
	lisp__data.env.head = lisp__data.env.length = base;

	GC_PROTECT(result);
	result = EVAL(result);
	GC_LEAVE();
    }

    return (result);
}

LispObj *
LispRunSetf(LispArgList *alist, LispObj *setf, LispObj *place, LispObj *value)
{
    GC_ENTER();
    LispObj *store, *code, *expression, *result, quote;
    int base;

    code = setf->data.lambda.code;
    store = setf->data.lambda.data;

    quote.type = LispQuote_t;
    quote.data.quote = value;
    LispDoAddVar(CAR(store), &quote);
    ++lisp__data.env.head;
    base = LispMakeEnvironment(alist, place, Oexpand_setf_method, 0, 0);

    /* build expansion macro */
    expression = NIL;
    for (; CONSP(code); code = CDR(code))
	expression = EVAL(CAR(code));

    /* Minus 1 to pop the added variable */
    lisp__data.env.head = lisp__data.env.length = base - 1;

    /* protect expansion, and executes it */
    GC_PROTECT(expression);
    result = EVAL(expression);
    GC_LEAVE();

    return (result);
}

LispObj *
LispRunSetfMacro(LispAtom *atom, LispObj *arguments, LispObj *value)
{
    int base;
    GC_ENTER();
    LispObj *place, *body, *result, quote;

    place = NIL;
    base = LispMakeEnvironment(atom->property->alist,
			       arguments, atom->object, 0, 0);
    body = atom->property->fun.function->data.lambda.code;

    /* expand macro body */
    for (; CONSP(body); body = CDR(body))
	place = EVAL(CAR(body));

    /* protect expansion */
    GC_PROTECT(place);

    /* restore environment */
    lisp__data.env.head = lisp__data.env.length = base;

    /* value is already evaluated */
    quote.type = LispQuote_t;
    quote.data.quote = value;

    /* call setf again */
    result = APPLY2(Osetf, place, &quote);

    GC_LEAVE();

    return (result);
}

char *
LispStrObj(LispObj *object)
{
    static int first = 1;
    static char buffer[34];
    static LispObj stream;
    static LispString string;

    if (first) {
	stream.type = LispStream_t;
	stream.data.stream.source.string = &string;
	stream.data.stream.pathname = NIL;
	stream.data.stream.type = LispStreamString;
	stream.data.stream.readable = 0;
	stream.data.stream.writable = 1;

	string.string = buffer;
	string.fixed = 1;
	string.space = sizeof(buffer) - 1;
	first = 0;
    }

    string.length = string.output = 0;

    LispWriteObject(&stream, object);

    /* make sure string is nul terminated */
    string.string[string.length] = '\0';
    if (string.length >= 32) {
	if (buffer[0] == '(')
	    strcpy(buffer + 27, "...)");
	else
	    strcpy(buffer + 28, "...");
    }

    return (buffer);
}

void
LispPrint(LispObj *object, LispObj *stream, int newline)
{
    if (stream != NIL && !STREAMP(stream)) {
	LispDestroy("PRINT: %s is not a stream", STROBJ(stream));
    }
    if (newline && LispGetColumn(stream))
	LispWriteChar(stream, '\n');
    LispWriteObject(stream, object);
    if (stream == NIL || (stream->data.stream.type == LispStreamStandard &&
	stream->data.stream.source.file == Stdout))
	LispFflush(Stdout);
}

void
LispUpdateResults(LispObj *cod, LispObj *res)
{
    LispSetVar(RUN[2], LispGetVar(RUN[1]));
    LispSetVar(RUN[1], LispGetVar(RUN[0]));
    LispSetVar(RUN[0], cod);

    LispSetVar(RES[2], LispGetVar(RES[1]));
    LispSetVar(RES[1], LispGetVar(RES[0]));
    LispSetVar(RES[0], res);
}

void
LispSignalHandler(int signum)
{
    LispSignal(signum);
}

void
LispSignal(int signum)
{
    const char *errstr;
    char buffer[32];

    if (lisp__disable_int) {
	lisp__interrupted = signum;
	return;
    }
    switch (signum) {
	case SIGINT:
	    errstr = "interrupted";
	    break;
	case SIGFPE:
	    errstr = "floating point exception";
	    break;
	default:
	    sprintf(buffer, "signal %d received", signum);
	    errstr = buffer;
	    break;
    }
    LispDestroy("%s", errstr);
}

void
LispDisableInterrupts(void)
{
    ++lisp__disable_int;
}

void
LispEnableInterrupts(void)
{
    --lisp__disable_int;
    if (lisp__disable_int <= 0 && lisp__interrupted)
	LispSignal(lisp__interrupted);
}

void
LispMachine(void)
{
    LispObj *cod, *obj;

    lisp__data.sigint = signal(SIGINT, LispSignalHandler);
    lisp__data.sigfpe = signal(SIGFPE, LispSignalHandler);

    /*CONSTCOND*/
    while (1) {
	if (sigsetjmp(lisp__data.jmp, 1) == 0) {
	    lisp__data.running = 1;
	    if (lisp__data.interactive && lisp__data.prompt) {
		LispFputs(Stdout, lisp__data.prompt);
		LispFflush(Stdout);
	    }
	    if ((cod = LispRead()) != NULL) {
		obj = EVAL(cod);
		if (lisp__data.interactive) {
		    if (RETURN_COUNT >= 0)
			LispPrint(obj, NIL, 1);
		    if (RETURN_COUNT > 0) {
			int i;

			for (i = 0; i < RETURN_COUNT; i++)
			    LispPrint(RETURN(i), NIL, 1);
		    }
		    LispUpdateResults(cod, obj);
		    if (LispGetColumn(NIL))
			LispWriteChar(NIL, '\n');
		}
	    }
	    LispTopLevel();
	}
	if (lisp__data.eof)
	    break;
    }

    signal(SIGINT, lisp__data.sigint);
    signal(SIGFPE, lisp__data.sigfpe);

    lisp__data.running = 0;
}

void *
LispExecute(char *str)
{
    static LispObj stream;
    static LispString string;
    static int first = 1;

    int running = lisp__data.running;
    LispObj *result, *cod, *obj, **presult = &result;

    if (str == NULL || *str == '\0')
	return (NIL);

    *presult = NIL;

    if (first) {
	stream.type = LispStream_t;
	stream.data.stream.source.string = &string;
	stream.data.stream.pathname = NIL;
	stream.data.stream.type = LispStreamString;
	stream.data.stream.readable = 1;
	stream.data.stream.writable = 0;
	string.output = 0;
	first = 0;
    }
    string.string = str;
    string.length = strlen(str);
    string.input = 0;

    LispPushInput(&stream);
    if (!running) {
	lisp__data.running = 1;
	if (sigsetjmp(lisp__data.jmp, 1) != 0)
	    return (NULL);
    }

    cod = COD;
    /*CONSTCOND*/
    while (1) {
	if ((obj = LispRead()) != NULL) {
	    result = EVAL(obj);
	    COD = cod;
	}
	if (lisp__data.eof)
	    break;
    }
    LispPopInput(&stream);

    lisp__data.running = running;

    return (result);
}

void
LispBegin(void)
{
    int i;
    LispAtom *atom;
    char results[4];
    LispObj *object, *path, *ext;

    pagesize = LispGetPageSize();
    segsize = pagesize / sizeof(LispObj);

    lisp__data.strings = hash_new(STRTBLSZ, NULL);
    lisp__data.opqs = hash_new(STRTBLSZ, NULL);

    /* Initialize memory management */
    lisp__data.mem.mem = (void**)calloc(lisp__data.mem.space = 16,
					sizeof(void*));
    lisp__data.mem.index = lisp__data.mem.level = 0;

    /* Allow LispGetVar to check ATOMID() of unbound symbols */
    UNBOUND->data.atom = (LispAtom*)LispCalloc(1, sizeof(LispAtom));
    LispMused(UNBOUND->data.atom);
    noproperty.value = UNBOUND;

    if (Stdin == NULL)
	Stdin = LispFdopen(0, FILE_READ);
    if (Stdout == NULL)
	Stdout = LispFdopen(1, FILE_WRITE | FILE_BUFFERED);
    if (Stderr == NULL)
	Stderr = LispFdopen(2, FILE_WRITE);

    /* minimum number of free cells after GC
     * if sizeof(LispObj) == 16, than a minfree of 1024 would try to keep
     * at least 16Kb of free cells.
     */
    minfree = 1024;

    MOD = COD = PRO = NIL;
#ifdef DEBUGGER
    DBG = BRK = NIL;
#endif

    /* allocate initial object cells */
    LispAllocSeg(&objseg, minfree);
    LispAllocSeg(&atomseg, pagesize);
    lisp__data.gc.average = segsize;

    /* Don't allow gc in initialization */
    GCDisable();

    /* Initialize package system, the current package is LISP. Order of
     * initialization is very important here */
    lisp__data.lisp = LispNewPackage(STRING("LISP"),
				     CONS(STRING("COMMON-LISP"), NIL));

    /* Make LISP package the current one */
    lisp__data.pack = lisp__data.savepack =
	lisp__data.lisp->data.package.package;

    /* Allocate space in LISP package */
    LispMoreGlobals(lisp__data.pack);

    /* Allocate  space for multiple value return values */
    lisp__data.returns.values = malloc(MULTIPLE_VALUES_LIMIT *
				       (sizeof(LispObj*)));

    /*  Create the first atom, do it "by hand" because macro "PACKAGE"
     * cannot yet be used. */
    atom = LispGetPermAtom("*PACKAGE*");
    lisp__data.package = atomseg.freeobj;
    atomseg.freeobj = CDR(atomseg.freeobj);
    --atomseg.nfree;
    lisp__data.package->type = LispAtom_t;
    lisp__data.package->data.atom = atom;
    atom->object = lisp__data.package;
    atom->package = lisp__data.lisp;

    /* Set package list, to be used by (gc) and (list-all-packages) */
    PACK = CONS(lisp__data.lisp, NIL);

    /* Make *PACKAGE* a special variable */
    LispProclaimSpecial(lisp__data.package, lisp__data.lisp, NIL);

	/* Value of macro "PACKAGE" is now properly available */

    /* Changing *PACKAGE* is like calling (in-package) */
    lisp__data.package->data.atom->watch = 1;

    /* And available to other packages */
    LispExportSymbol(lisp__data.package);

    /* Initialize stacks */
    LispMoreEnvironment();
    LispMoreStack();

    /* Create the KEYWORD package */
    Skeyword = GETATOMID("KEYWORD");
    object = LispNewPackage(STRING(Skeyword->value),
			    CONS(STRING(""), NIL));

    /* Update list of packages */
    PACK = CONS(object, PACK);

    /* Allow easy access to the keyword package */
    lisp__data.keyword = object;
    lisp__data.key = object->data.package.package;

    /* Initialize some static important symbols */
    Olambda		= STATIC_ATOM("LAMBDA");
    LispExportSymbol(Olambda);
    Okey		= STATIC_ATOM("&KEY");
    LispExportSymbol(Okey);
    Orest		= STATIC_ATOM("&REST");
    LispExportSymbol(Orest);
    Ooptional		= STATIC_ATOM("&OPTIONAL");
    LispExportSymbol(Ooptional);
    Oaux		= STATIC_ATOM("&AUX");
    LispExportSymbol(Oaux);
    Kunspecific		= KEYWORD("UNSPECIFIC");
    Oformat		= STATIC_ATOM("FORMAT");
    Oexpand_setf_method	= STATIC_ATOM("EXPAND-SETF-METHOD");

    Omake_struct	= STATIC_ATOM("MAKE-STRUCT");
    Ostruct_access	= STATIC_ATOM("STRUCT-ACCESS");
    Ostruct_store	= STATIC_ATOM("STRUCT-STORE");
    Ostruct_type	= STATIC_ATOM("STRUCT-TYPE");
    Smake_struct	= ATOMID(Omake_struct);
    Sstruct_access	= ATOMID(Ostruct_access);
    Sstruct_store	= ATOMID(Ostruct_store);
    Sstruct_type	= ATOMID(Ostruct_type);

    /* Initialize some static atom ids */
    Snil		= GETATOMID("NIL");
    St			= GETATOMID("T");
    Saux		= ATOMID(Oaux);
    Skey		= ATOMID(Okey);
    Soptional		= ATOMID(Ooptional);
    Srest		= ATOMID(Orest);
    Sand		= GETATOMID("AND");
    Sor			= GETATOMID("OR");
    Snot		= GETATOMID("NOT");
    Satom		= GETATOMID("ATOM");
    Ssymbol		= GETATOMID("SYMBOL");
    Sinteger		= GETATOMID("INTEGER");
    Scharacter		= GETATOMID("CHARACTER");
    Sstring		= GETATOMID("STRING");
    Slist		= GETATOMID("LIST");
    Scons		= GETATOMID("CONS");
    Svector		= GETATOMID("VECTOR");
    Sarray		= GETATOMID("ARRAY");
    Sstruct		= GETATOMID("STRUCT");
    Sfunction		= GETATOMID("FUNCTION");
    Spathname		= GETATOMID("PATHNAME");
    Srational		= GETATOMID("RATIONAL");
    Sfloat		= GETATOMID("FLOAT");
    Scomplex		= GETATOMID("COMPLEX");
    Sopaque		= GETATOMID("OPAQUE");
    Sdefault		= GETATOMID("DEFAULT");

    LispArgList_t	= LispRegisterOpaqueType("LispArgList*");

    lisp__data.unget = malloc(sizeof(LispUngetInfo*));
    lisp__data.unget[0] = calloc(1, sizeof(LispUngetInfo));
    lisp__data.nunget = 1;

    lisp__data.standard_input = ATOM2("*STANDARD-INPUT*");
    SINPUT = STANDARDSTREAM(Stdin, lisp__data.standard_input, STREAM_READ);
    lisp__data.interactive = 1;
    LispProclaimSpecial(lisp__data.standard_input,
			lisp__data.input_list = SINPUT, NIL);
    LispExportSymbol(lisp__data.standard_input);

    lisp__data.standard_output = ATOM2("*STANDARD-OUTPUT*");
    SOUTPUT = STANDARDSTREAM(Stdout, lisp__data.standard_output, STREAM_WRITE);
    LispProclaimSpecial(lisp__data.standard_output,
			lisp__data.output_list = SOUTPUT, NIL);
    LispExportSymbol(lisp__data.standard_output);

    object = ATOM2("*STANDARD-ERROR*");
    lisp__data.error_stream = STANDARDSTREAM(Stderr, object, STREAM_WRITE);
    LispProclaimSpecial(object, lisp__data.error_stream, NIL);
    LispExportSymbol(object);

    lisp__data.modules = ATOM2("*MODULES*");
    LispProclaimSpecial(lisp__data.modules, MOD, NIL);
    LispExportSymbol(lisp__data.modules);

    object = CONS(KEYWORD("UNIX"), CONS(KEYWORD("XEDIT"), NIL));
    lisp__data.features = ATOM2("*FEATURES*");
    LispProclaimSpecial(lisp__data.features, object, NIL);
    LispExportSymbol(lisp__data.features);

    object = ATOM2("MULTIPLE-VALUES-LIMIT");
    LispDefconstant(object, FIXNUM(MULTIPLE_VALUES_LIMIT + 1), NIL);
    LispExportSymbol(object);

    /* Reenable gc */
    GCEnable();

    LispBytecodeInit();
    LispPackageInit();
    LispCoreInit();
    LispMathInit();
    LispPathnameInit();
    LispStreamInit();
    LispRegexInit();
    LispWriteInit();

    lisp__data.prompt = isatty(0) ? "> " : NULL;

    lisp__data.errexit = !lisp__data.interactive;

    if (lisp__data.interactive) {
	/* add +, ++, +++, *, **, and *** */
	for (i = 0; i < 3; i++) {
	    results[i] = '+';
	    results[i + 1] = '\0';
	    RUN[i] = ATOM(results);
	    LispSetVar(RUN[i], NIL);
	    LispExportSymbol(RUN[i]);
	}
	for (i = 0; i < 3; i++) {
	    results[i] = '*';
	    results[i + 1] = '\0';
	    RES[i] = ATOM(results);
	    LispSetVar(RES[i], NIL);
	    LispExportSymbol(RES[i]);
	}
    }
    else
	RUN[0] = RUN[1] = RUN[2] = RES[0] = RES[1] = RES[2] = NIL;

    /* Add LISP builtin functions */
    for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++)
	LispAddBuiltinFunction(&lispbuiltins[i]);

    EXECUTE("(require \"lisp\")");

    object = ATOM2("*DEFAULT-PATHNAME-DEFAULTS*");
#ifdef LISPDIR
    {
	int length;
	const char *pathname = LISPDIR;

	length = strlen(pathname);
	if (length && pathname[length - 1] != '/') {
	    char *fixed_pathname = LispMalloc(length + 2);

	    strcpy(fixed_pathname, LISPDIR);
	    strcpy(fixed_pathname + length, "/");
	    path = LSTRING2(fixed_pathname, length + 1);
	}
	else
	    path = LSTRING(pathname, length);
    }
#else
    path = STRING("");
#endif
    GCDisable();
    LispProclaimSpecial(object, APPLY1(Oparse_namestring, path), NIL);
    LispExportSymbol(object);
    GCEnable();

    /* Create and make EXT the current package */
    PACKAGE = ext = LispNewPackage(STRING("EXT"), NIL);
    lisp__data.pack = lisp__data.savepack = PACKAGE->data.package.package;

    /* Update list of packages */
    PACK = CONS(ext, PACK);

    /* Import LISP external symbols in EXT package */
    LispUsePackage(lisp__data.lisp);

    /* Add EXT non standard builtin functions */
    for (i = 0; i < sizeof(extbuiltins) / sizeof(extbuiltins[0]); i++)
	LispAddBuiltinFunction(&extbuiltins[i]);

    /* Create and make USER the current package */
    GCDisable();
    PACKAGE = LispNewPackage(STRING("USER"),
			     CONS(STRING("COMMON-LISP-USER"), NIL));
    GCEnable();
    lisp__data.pack = lisp__data.savepack = PACKAGE->data.package.package;

    /* Update list of packages */
    PACK = CONS(PACKAGE, PACK);

    /* USER package inherits all LISP external symbols */
    LispUsePackage(lisp__data.lisp);
    /* And all EXT external symbols */
    LispUsePackage(ext);

    LispTopLevel();
}

void
LispEnd(void)
{
    /* XXX needs to free all used memory, not just close file descriptors */
}

void
LispSetPrompt(const char *prompt)
{
    lisp__data.prompt = prompt;
}

void
LispSetInteractive(int interactive)
{
    lisp__data.interactive = !!interactive;
}

void
LispSetExitOnError(int errexit)
{
    lisp__data.errexit = !!errexit;
}

void
LispDebug(int enable)
{
    lisp__data.debugging = !!enable;

#ifdef DEBUGGER
    /* assumes we are at the toplevel */
    DBG = BRK = NIL;
    lisp__data.debug_level = -1;
    lisp__data.debug_step = 0;
#endif
}