diff options
Diffstat (limited to 'lisp/lisp.c')
| -rw-r--r-- | lisp/lisp.c | 5507 |
1 files changed, 5507 insertions, 0 deletions
diff --git a/lisp/lisp.c b/lisp/lisp.c new file mode 100644 index 0000000..cda8c14 --- /dev/null +++ b/lisp/lisp.c @@ -0,0 +1,5507 @@ +/* + * 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.85 2003/01/29 03:05:53 paulo Exp $ */ + +#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 + +#if defined(linux) +#include <asm/page.h> /* for PAGE_SIZE */ +#define HAS_GETPAGESIZE +#define HAS_SC_PAGESIZE /* _SC_PAGESIZE may be an enum for Linux */ +#endif + +#if defined(CSRG_BASED) +#define HAS_GETPAGESIZE +#endif + +#if defined(sun) +#define HAS_GETPAGESIZE +#endif + +#if defined(QNX4) +#define HAS_GETPAGESIZE +#endif + +#if defined(__QNXNTO__) +#define HAS_SC_PAGESIZE +#endif + +#include "bytecode.h" + +#include "read.h" +#include "format.h" +#include "math.h" +#include "hash.h" +#include "package.h" +#include "pathname.h" +#include "regex.h" +#include "require.h" +#include "stream.h" +#include "struct.h" +#include "time.h" +#include "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 +#ifdef SIGNALRETURNSINT +int +#else +void +#endif +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(HAS_SC_PAGESIZE) + pagesize = sysconf(_SC_PAGESIZE); +#endif + +#ifdef _SC_PAGE_SIZE + if (pagesize == -1) + pagesize = sysconf(_SC_PAGE_SIZE); +#endif + +#ifdef HAS_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(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 char Fatal[] = "*** Fatal: nowhere to longjmp.\n"; + + LispFputs(Stderr, Fatal); + LispFflush(Stderr); + abort(); + } + + siglongjmp(lisp__data.jmp, 1); +} + +void +LispContinuable(char *fmt, ...) +{ + va_list ap; + char string[128]; + static 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(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(char *fmt, ...) +{ + va_list ap; + char string[128]; + static 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 (i = 0; i < STRTBLSZ; i++) { + atom = pack->atoms[i]; + while (atom) { + 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); + } + } + atom = atom->next; + } + } + } + + /* 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(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, 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(char *desc) +{ + LispOpaque *opaque; + int ii = STRHASH(desc); + + for (opaque = lisp__data.opqs[ii]; opaque; opaque = opaque->next) + if (strcmp(opaque->desc, desc) == 0) + return (opaque->type); + opaque = (LispOpaque*)LispMalloc(sizeof(LispOpaque)); + opaque->desc = LispStrdup(desc); + opaque->next = lisp__data.opqs[ii]; + lisp__data.opqs[ii] = opaque; + LispMused(opaque->desc); + LispMused(opaque); + + return (opaque->type = ++lisp__data.opaque); +} + +char * +LispIntToOpaqueType(int type) +{ + int i; + LispOpaque *opaque; + + if (type) { + for (i = 0; i < STRTBLSZ; i++) { + opaque = lisp__data.opqs[i]; + while (opaque) { + if (opaque->type == type) + return (opaque->desc); + opaque = opaque->next; + } + } + LispDestroy("Opaque type %d not registered", type); + } + + return (Snil); +} + +int +LispDoHashString(char *string) +{ + char *pp; + int ii, count; + + for (pp = string, ii = count = 0; *pp && count < 32; pp++, count++) + ii = (ii << 1) ^ *pp; + if (ii < 0) + ii = -ii; + + return (ii % STRTBLSZ); +} + +char * +LispGetAtomString(char *string, int perm) +{ + LispStringHash *entry; + int ii = STRHASH(string); + + for (entry = lisp__data.strings[ii]; entry != NULL; entry = entry->next) + if (strcmp(entry->string, string) == 0) + return (entry->string); + + entry = (LispStringHash*)LispCalloc(1, sizeof(LispStringHash)); + if (perm) + entry->string = string; + else + entry->string = LispStrdup(string); + LispMused(entry); + if (!perm) + LispMused(entry->string); + entry->next = lisp__data.strings[ii]; + lisp__data.strings[ii] = entry; + + return (entry->string); +} + +LispAtom * +LispDoGetAtom(char *str, int perm) +{ + LispAtom *atom; + int ii = STRHASH(str); + + for (atom = lisp__data.pack->atoms[ii]; atom; atom = atom->next) + if (strcmp(atom->string, str) == 0) + return (atom); + + atom = (LispAtom*)LispCalloc(1, sizeof(LispAtom)); + atom->string = LispGetAtomString(str, perm); + LispMused(atom); + atom->next = lisp__data.pack->atoms[ii]; + lisp__data.pack->atoms[ii] = atom; + atom->property = NOPROPERTY; + + 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; + + --atom->property->refcount; + + if (atom->property->refcount < 0) + LispDestroy("internal error at DECREMENT-ATOM-REFERENCE"); + + 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), 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(char *str) +{ + return (LispDoGetAtom(str, 0)); +} + +LispAtom * +LispGetPermAtom(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))); +} + +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, char *name, int builtin) +{ + static char *types[4] = {"LAMBDA-LIST", "FUNCTION", "MACRO", "SETF-METHOD"}; + static char *fnames[4] = {"LAMBDA", "DEFUN", "DEFMACRO", "DEFSETF"}; +#define IKEY 0 +#define IOPTIONAL 1 +#define IREST 2 +#define IAUX 3 + static 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(""); + + 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[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)); + 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), + 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), + 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)); + 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)); + } + + /* 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 = LispGetAtomString(description, 0); + + 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->string, 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); + + 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); + + return (obj); +} + +LispObj * +LispNewAtom(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(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->string; + STRLEN(name) = strlen(atom->string); + 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); + + dfloat->type = LispDFloat_t; + dfloat->data.dfloat = value; + + return (dfloat); +} + +LispObj * +LispNewString(char *str, long length, int alloced) +{ + char *cstring; + LispObj *string = objseg.freeobj; + + if (string == NIL) + string = Lisp__New(NIL, NIL); + else + objseg.freeobj = CDR(string); + + if (alloced) + cstring = str; + else { + cstring = LispMalloc(length + 1); + memcpy(cstring, str, length); + cstring[length] = '\0'; + } + 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); + + 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); + + 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); + + 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); + + 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(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(char *string, int flags, long length, int alloced) +{ + LispObj *stream = LispNew(NIL, NIL); + + SSTREAMP(stream) = LispCalloc(1, sizeof(LispString)); + if (alloced) + SSTREAMP(stream)->string = string; + else { + SSTREAMP(stream)->string = LispMalloc(length + 1); + memcpy(SSTREAMP(stream)->string, string, length); + SSTREAMP(stream)->string[length] = '\0'; + } + + 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; + + 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) +{ + int ii; + char *string; + LispAtom *atom; + LispProperty *property; + + string = ATOMID(symbol); + property = symbol->data.atom->property; + ii = STRHASH(string); + + atom = lisp__data.pack->atoms[ii]; + while (atom) { + if (strcmp(atom->string, string) == 0) + return (atom->object); + + atom = atom->next; + } + + /* Symbol not found, just import it */ + return (NULL); +} + +/* package must be of type LispPackage_t */ +void +LispUsePackage(LispObj *package) +{ + unsigned i; + 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 (i = 0; i < STRTBLSZ; i++) { + atom = pack->atoms[i]; + while (atom) { + if (atom->ext) + LispImportSymbol(atom->object); + atom = atom->next; + } + } +} + +/* 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), 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), 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->string; + 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->string; +} + +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->string; + 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 = "e; + 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, *pdid_jump; + LispObj **pcode, **presult; + LispBlock *block; + + block = LispBeginBlock(name, LispBlockClosure); + lisp__data.env.lex = base; + if (setjmp(block->jmp) == 0) { + for (pcode = &code, presult = &result, pdid_jump = &did_jump; + 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), "e); + ++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, "e); + + 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); +} + +#ifdef SIGNALRETURNSINT +int +#else +void +#endif +LispSignalHandler(int signum) +{ + LispSignal(signum); +#ifdef SIGNALRETURNSINT + return (0); +#endif +} + +void +LispSignal(int signum) +{ + 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(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); + + /* 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), + 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; + char *pathname = LISPDIR; + + length = strlen(pathname); + if (length && pathname[length - 1] != '/') { + pathname = LispMalloc(length + 2); + + strcpy(pathname, LISPDIR); + strcpy(pathname + length, "/"); + path = LSTRING2(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() +{ + /* XXX needs to free all used memory, not just close file descriptors */ +} + +void +LispSetPrompt(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 +} |