diff options
Diffstat (limited to 'lisp')
89 files changed, 69922 insertions, 0 deletions
diff --git a/lisp/README b/lisp/README new file mode 100644 index 0000000..b375d86 --- /dev/null +++ b/lisp/README @@ -0,0 +1,195 @@ +$XFree86: xc/programs/xedit/lisp/README,v 1.13 2002/12/16 03:59:27 paulo Exp $ + +LAST UPDATED: $Date$ + + + SUMMARY + + This is a small lisp interpreter for xedit. It implements a subset of +Common Lisp and the xedit package implements several of the basic Emacs +lisp functions. + +(shared modules not broken, but needs a redesign for better performance, + but won't be made available in the default build probably for a long time, + it would be really better to generate the interface dinamically, and/or just + link agains't the required libraries and use a ffi interface) ++------------------------------------------------------------------------ +| It has a very simple method for loading shared modules, slightly based on +| the XFree86 loader code, that is currently disabled by default. To enable it, +| edit lisp.cf and change BuildSharedLispModules to YES. +| +| Assuming you have built it with BuildSharedLispModules enabled, you can build +| a small test application can be built in this directory running "make lsp". +| Two lisp programs are available in the test directory. To test the programs +| run "./lsp test/hello.lsp" or "./lsp test/widgets.lsp". ++------------------------------------------------------------------------ + + Currently, it should be used as an helper and/or a small calculator embedded +in xedit. For the future it should be possible to write entire interfaces +in the xedit text buffers. + + + USAGE SUMMARY + + To evaluate lisp expressions, put the text cursor just after the +lisp expression and press: +C-x,C-e - will evaluate it, and print the result to the message window +C-j - will evaluate it, and print the result to the edit window, any + errors are printed to the message window. +C-g - will send an SIGINT to the lisp process, and that process will + stop whatever it was processing and jump to the toplevel, + to wait for more input. + +Note that C-j will only work in the *scratch* buffer. + + + NOTES + + The improvements to xedit including the several possibilites to extend +the editor using Lisp are expected to allow making of xedit a versatile +text editor for programming, but there is code being (slowly) developed +that should also make it useable as a small word processor, for things +like WYSIWYG html, etc. + The xedit development is being done very slowly, maybe it will get +somewhere someday, but it is a pet/hobby project, there is no intention +of making of it an end user editor (the idea is to make it an useful +development tool). + In some aspects the development is trying to mimic several Emacs +features, but there is no intention of competition (if xedit ever get +something better than Emacs, I hope that it serves as a motivation to +make of Emacs an even better editor), actually it is expected to explore +different areas and use alternate solutions for the implementation. + Most work in a computer is done in a text editor and the more the editor +can help the user the better. + + +(debugger is broken and very slow, no prevision for fixing it, but is + expected to work correctly for interpreted only code) ++------------------------------------------------------------------------ +| DEBUGGER +| +| There is a, currently, very simple debugger implement in the interpreter. +| The debugger is now optional, and off by default. To make it available, +| you need to recompile with -DDEBUGGER. +| To use the debugger, run the lsp sample program as "./lsp -d", and optionally +| pass a second parameter, for the file to be interpreted. Once the debugger +| prompt is visible, type "help" for a summary of options. To leave the debugger +| type "continue". +| Note that the debugger is still very simple, it won't work from xedit, and +| won't drop to the debugger on "fatal errors". It allows adding breakpoints to +| functions and watchpoints to variables. Support for changing data and going to +| the debugger on fatal errors should be added at some time. ++------------------------------------------------------------------------ + + + COMPILER + + Now there is a very simple bytecode compiler. It is far from finished, but +for simple code can show significant better performance. + There is not yet an interface to compile entire files and no interface to +store the generated bytecode in disk. There is an interface to bytecode +compile toplevel forms as a LAMBDA NIL, but it is not yet exported. + If your code needs to call GO/RETURN/RETURN-FROM as the result of an EVAL, +it must jump to code in the interpreter, after compiling all calls to +GO/RETURN/RETURN-FROM are just stack adjusting and jumps in the bytecode. +CATCH/THROW and UNWIND-PROTECT are running as interpreted code for now, so it +is safe to use these, but code in such blocks is not compiled/optimized +(not even macro expansion is done, as it understands that while not compiled, +everything is candidate to redefinition at any time). + To compile the code, just write a function, and compile it, example: + + (defun fact (n) + (if (< n 2) + 1 + (* n (fact (1- n))) + ) + ) + FACT + + (compile 'fact) + FACT + NIL + NIL + + (disassemble 'fact) + Function FACT: + 1 required argument: N + 0 optional arguments + 0 keyword parameters + No rest argument + + Bytecode header: + 1 element used in the stack + 2 elements used in the builtin stack + 0 elements used in the protected stack + Constant 0 = 1 + Constant 1 = (2) + Symbol 0 = N + Builtin 0 = * + Builtin 1 = 1- + Builtin 2 = < + + Initial stack: + 0 = N + + Bytecode stream: + 0 LOAD&PUSH (0) + 2 LOADCON&PUSH [1] ; (2) + 4 CALL 2 [2] ; < + 7 JUMPNIL 8 + 10 LOADCON [0] ; 1 + 12 NOOP + 13 JUMP 19 + 16 LOAD&PUSH (0) + 18 LOAD&PUSH (0) + 20 CALL 1 [1] ; 1- + 23 LET* [0] ; N + 25 LETREC 1 + 27 UNLET 1 + 29 BCONS1 + 30 CALL 1 [0] ; * + 33 RETURN + FACT + + + There are several optimizations that should be done at some time, I don't +think adding NOOP opcodes will help everywhere to make aligned memory reads +of shorts and ints. + It should have explicitly visible registers, not the abstraction of "the +current value", so the code generator can choose register allocation for +loop control variables, commonly used variables, etc, for example. Jumps +should have 3 types: byte relative, 2 bytes relative and 4 bytes relative. +For now there is only 2 byte relative jumps, byte relative jumps +can show a significant performance increase, but they are disable until +it is decided how inlined functions will work, if it just updates the bytecode +header and cut&past the bytecode, jumps must be updated, and some jumps +may not fit anymore in a byte. + + + OPTIMIZATION + + There are plenty of possibilities to make the interpreter run faster. Some +optimizations that can make it run quite faster in certain cases are: + o Better object memory layout and gc. The current memory allocation code + is very bad, it try to keep 3 times more free objects than the currently + used number, this can consume a lot of memory. The reason is to reduce + the gc time cost so that it will in average miss only one in every 4 + collect tries. + o Implement real vectors, currently they are just a list, so it cannot + just deference a given index, and gc time is very long also. + o Most lists are never changed once created, it could somehow add an index + field in the cons cell, so that NTH/NTHCDR/LENGTH like code could just + deference the correct object, instead of traversing the CDR of every + cons. This would probably require implementing lists as vectors, while + making it easy to deference would make life harder when deleting/inserting + sublists in a list. It should also better be done in a way that does + not require a lot of objects allocated linearly. + + + HELPING + + Send comments and code to me (paulo@XFree86.Org) or to the XFree86 +mailing/patch lists. + +-- +Paulo diff --git a/lisp/TODO b/lisp/TODO new file mode 100644 index 0000000..01babd6 --- /dev/null +++ b/lisp/TODO @@ -0,0 +1,81 @@ +$XFree86: xc/programs/xedit/lisp/TODO,v 1.9 2002/12/16 03:59:27 paulo Exp $ + +LAST UPDATED: $Date$ + + Small todo list + +o Change function/macro body to know if a &key or &optional argument was not + provided, and initialize to the default value in the function, for + interpreted and builtin functions it is better done before the function is + called, but for bytecode it is better in the function. +o Following the previous idea, change function definitions in the format: + (defun afun (a &aux b (c (some-code))) ...) + to + (defun afun (a) (let* ((b (c (some-code)))) ...)) + This can significatively reduce bytecode size, and also simplify function + calls. +o Optimize text redisplay in Xaw, instead of allocating a copy of the buffer + for the paint-list, should use the text in place, and only allocate small + buffers when required, i.e. displaying control characters, etc. +o Add an interface to create new object types dinamically. +o Add a special string object to simplify and avoid too many copies of + portions of the text buffers. This special string should be read-only + and not gc-collected. +o Make the bytecode compiler smarter to detect some constructs like: + (builtin-or-bytecode-function-call arg1 arg2 (return)) + this will not properly restore the internal stacks. + +o When an Init function is present in every file, call LispAddBuiltin from + that initialization function. +o Cleanup the code, make it optional to build some uncommon features (as well + as the entire interpreter?). Implement more functions directly in lisp. +o Finish an "specification" for loadable modules. Write a FFI interface. + Without the possibility of using already existing libraries, the interpreter + won't be too much useful due to a poor library. It is very desirable to + "auto-generate" directly from C header files the interface to the lisp + code, and from that, dlload a shared library. In some cases, it is required + to link statically with a new interpreter binary, make it easy. +o Implement a better string type. That should support characters larger than + 8 bits, and that should allow embeded nuls. +o Implement a richer set of math functions. This, if properly done can be + made a loadable module. +o Optmize mathimp.c, comparing a double with a bignum should never cause an + error. Implement mp?_initsetXXX functions? +o Finish missing features in read.c, and simplify it. +o (close) probably should not send a signal when closing a pipe. +o Implement "real" vectors, they exist to make access to field elements + at constant time, implementing vectors as lists may be very slow. +o Use float and double as floating points formats. +o Implement support for vectors of "atomic" types. Vectors of floats would + be useful for example if a OpenGL binding is done. +o Implement a multiple precision floating point format. Either a 128 bits + (or configurable length?) IEEE 754 like number, or some format using + ratios, a epsilon for rouding, rounding modes, exact/inexact flag, a good + amount of guard digits, etc. +o Write more functions and optimization for bignums. Try to make the code + as reusable as possible, either by other software or at least by the + different number types. +o Instead of using mathimp.c for a large amount of functions, implement a + "generic number" type and implement the calculations directly in the + mp library. +o Add more missing Common Lisp features, like &allow-other-keys for function + definitions, the missing structure features, CLOS etc. +o Fix the Postgresql module, make it compile everywhere. +o Add support for multi-threaded applications? +o Make it possible to know if a object has only one reference, this is + required to make "inplace" changes of variables. Very useful for things + like (incf) and (decf), and also when dealing with bignums. +o Maybe have a freelist for objects depending on the type. Bignums can be + reused, and having some large ones expecting to be freed by the gc can + consume a lot of memory. +o Internationalization. Support ',' in floats? Correctly treat characters + for {up,down}-casing. +o Synch the Xaw text code for supporting tables, text alignment/paragraphs, + etc, and add bindings to the interpreter. Add support for incremental + changes of those properties, currently it is "read-only". +o Write some type of "hyperlinks", this is the only feature missing to even + allow writting a web browser inside xedit. +o Write some "demos" (maybe a file manager or a simple mail reader) using the + Xt/Xaw bindings (needs modules working in all systems). +o Remove all calls to the macros GCDisable and GCEnable. This is unsafe + and should be removed. diff --git a/lisp/bytecode.c b/lisp/bytecode.c new file mode 100644 index 0000000..39667b0 --- /dev/null +++ b/lisp/bytecode.c @@ -0,0 +1,3707 @@ +/* + * Copyright (c) 2002 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/bytecode.c,v 1.15 2003/01/29 03:05:53 paulo Exp $ */ + + +/* +somethings TODO: + + o Write code for allowing storing the bytecode on disk. Basically + write a section of the bytecode with the package name of the symbol + pointers, and after that, the symbols used. At load time just put + the pointers in the bytecode. Constants can be stored as the string + representation. Probably just storing the gc protected code as a + string is enough to rebuild it. + + o Write code to store tags of BLOCK/CATCH and setjump buffer stacks, + and, only keep track of this if non byte-compiled code is called, + as after byte-compilation RETURN and THROW are just jumps. + + o Remove not reliable "optmization code" code from Com_XXX functions + and do it later, removing dead code, tests with a constant argument, + etc, in the "link time". Frequently joining sequential opcodes to a + compound version. + + o Write an optimizer to do code transformation. + + o Write code to know when variables can be changed in place, this + can save a huge time in loop counters. + + o Write code for fast garbage collection of objects that can be + safely collected. + + o Cleanup of interpreted code. Having bytecode mean that the interpreter + now is better having a clean and small code. If speed is important, + it should be byte compiled. + + o Limit the stacks length. So that instead of using an index, use the + pointer where an object value should be read/stored as the stack address + would not change during the program execution. + + o Optimize jump to jump. Common in code like: + (IF test + (GO somewhere) + (GO elsewhere) + ) + (GO there) + that generates a bytecode like: + <code to evaluate test> + JUMPNIL :NIL-RESULT + :T-RESULT + JUMP :SOMEWHERE + JUMP :END-OF-IF ;; <- this is not required, or even + :NIL-RESULT ;; better, notice the jump after + JUMP :ELSEWHERE ;; the if and transform it into + :END-OF-IF ;; a JUMP :THERE (assuming there + JUMP :THERE ;; (was no jump in the T code). + + o Optimize variables that are known to not change it's value, i.e. pseudo + constants. Loading the value of a constant should be faster than loading + the current value of a variable; the constant table could fit in the + processor cache line and needs less calculation to find the object address. + + o Fix some known problems, like when calling return or return-from while + building the argument list to a builtin function, or inline of recursive + functions. + */ + + +#include "bytecode.h" +#include "write.h" + +#define SYMBOL_KEYWORD -1 /* A keyword, load as constant */ +#define SYMBOL_CONSTANT -2 /* Defined as constant at compile time */ +#define SYMBOL_UNBOUND -3 /* Not a local variable */ + +#define NEW_TREE(type) CompileNewTree(com, type) + +/* If in tagbody, ignore anything that is not code */ +#define IN_TAGBODY() (com->block->type == LispBlockBody && \ + com->level == com->tagbody) +#define FORM_ENTER() ++com->level +#define FORM_LEAVE() --com->level + +#define COMPILE_FAILURE(message) \ + LispMessage("COMPILE: %s", message); \ + longjmp(com->jmp, 1) + +/* + * Types + */ +typedef struct _CodeTree CodeTree; +typedef struct _CodeBlock CodeBlock; + +typedef enum { + CodeTreeBytecode, + CodeTreeLabel, + CodeTreeGo, + CodeTreeJump, + CodeTreeJumpIf, + CodeTreeCond, + CodeTreeBlock, + CodeTreeReturn +} CodeTreeType; + +struct _CodeTree { + CodeTreeType type; + + /* Resolved when linking, may be adjusted while optimizing */ + long offset; + + LispByteOpcode code; + + union { + signed char signed_char; + signed short signed_short; + signed int signed_int; + LispAtom *atom; + LispObj *object; + CodeTree *tree; + CodeBlock *block; + struct { + unsigned char num_arguments; + LispBuiltin *builtin; + signed short offset; /* Used if opcode is XBC_CALL_SET */ + } builtin; + struct { + unsigned char num_arguments; + LispObj *name; + LispObj *lambda; + } call; + struct { + unsigned char num_arguments; + LispObj *code; + } bytecall; + struct { + short offset; + LispAtom *name; + } let; + struct { + LispAtom *symbol; + LispAtom *name; + } let_sym; + struct { + LispObj *object; + LispAtom *name; + } let_con; + struct { + signed short load; + signed short set; + } load_set; + struct { + LispObj *object; + signed short offset; + } load_con_set; + struct { + LispObj *car; + LispObj *cdr; + } cons; + struct { + short offset; + LispObj *definition; + } struc; + } data; + + CodeTree *next; + CodeTree *group; + CodeBlock *block; +}; + +struct _CodeBlock { + LispBlockType type; + LispObj *tag; + + struct { + LispObj **labels; + CodeTree **codes; /* Filled at link time */ + int length; + int space; + } tagbody; + + struct { + LispAtom **symbols; /* Identifiers of variables in a block */ + int *flags; /* Information about usage of the variable */ + int length; + } variables; + + int bind; /* Used in case of RETURN from LET */ + int level; /* Nesting level block was created */ + + CodeTree *tree, *tail; + CodeBlock *prev; /* Linked list as a stack */ + CodeTree *parent; /* Back reference */ +}; + +struct _LispCom { + unsigned char *bytecode; /* Bytecode generated so far */ + long length; + + CodeBlock *block, *toplevel; + + int tagbody; /* Inside a tagbody block? */ + int level; /* Nesting level */ + int macro; /* Expanding a macro? */ + + int lex; + + int warnings; + + LispObj *form, *plist; + + jmp_buf jmp; /* Used if compilation cannot be finished */ + + struct { + int cstack; /* Current number of objects in forms evaluation */ + int cbstack; + int cpstack; + int stack; /* max number of objects will be loaded in stack */ + int bstack; + int pstack; + } stack; + + struct { + /* Constant table */ + LispObj **constants; + int num_constants; + /* Symbol table */ + LispAtom **symbols; + int num_symbols; + /* Builtin table */ + LispBuiltin **builtins; + int num_builtins; + /* Bytecode table */ + LispObj **bytecodes; + int num_bytecodes; + } table; +}; + +/* + * Prototypes + */ +static LispObj *MakeBytecodeObject(LispCom*, LispObj*, LispObj*); + +static CodeTree *CompileNewTree(LispCom*, CodeTreeType); +static void CompileFreeState(LispCom*); +static void CompileFreeBlock(CodeBlock*); +static void CompileFreeTree(CodeTree*); + +static void CompileIniBlock(LispCom*, LispBlockType, LispObj*); +static void CompileFiniBlock(LispCom*); + +static void com_BytecodeChar(LispCom*, LispByteOpcode, char); +static void com_BytecodeShort(LispCom*, LispByteOpcode, short); +static void com_BytecodeObject(LispCom*, LispByteOpcode, LispObj*); +static void com_BytecodeCons(LispCom*, LispByteOpcode, LispObj*, LispObj*); + +static void com_BytecodeAtom(LispCom*, LispByteOpcode, LispAtom*); + +static void com_Bytecode(LispCom*, LispByteOpcode); + +static void com_Load(LispCom*, short); +static void com_LoadLet(LispCom*, short, LispAtom*); +static void com_LoadPush(LispCom*, short); + +static void com_Let(LispCom*, LispAtom*); + +static void com_Bind(LispCom*, short); +static void com_Unbind(LispCom*, short); + +static void com_LoadSym(LispCom*, LispAtom*); +static void com_LoadSymLet(LispCom*, LispAtom*, LispAtom*); +static void com_LoadSymPush(LispCom*, LispAtom*); + +static void com_LoadCon(LispCom*, LispObj*); +static void com_LoadConLet(LispCom*, LispObj*, LispAtom*); +static void com_LoadConPush(LispCom*, LispObj*); + +static void com_Set(LispCom*, short); +static void com_SetSym(LispCom*, LispAtom*); + +static void com_Struct(LispCom*, short, LispObj*); +static void com_Structp(LispCom*, LispObj*); + +static void com_Call(LispCom*, unsigned char, LispBuiltin*); +static void com_Bytecall(LispCom*, unsigned char, LispObj*); +static void com_Funcall(LispCom*, LispObj*, LispObj*); + +static void CompileStackEnter(LispCom*, int, int); +static void CompileStackLeave(LispCom*, int, int); + +static void LinkBytecode(LispCom*); + +static LispObj *ExecuteBytecode(unsigned char*); + + +/* Defined in lisp.c */ +void LispMoreStack(void); +void LispMoreEnvironment(void); +void LispMoreGlobals(LispPackage*); +LispObj *LispEvalBackquote(LispObj*, int); +void LispSetAtomObjectProperty(LispAtom*, LispObj*); + +/* + * Initialization + */ +extern int pagesize; + +LispObj x_cons[8]; +static LispObj *cons, *cons1, *cons2, *cons3, *cons4, *cons5, *cons6, *cons7; + +/* + * Implementation + */ +#include "compile.c" + +void +LispBytecodeInit(void) +{ + cons = &x_cons[7]; + cons->type = LispCons_t; + CDR(cons) = NIL; + cons1 = &x_cons[6]; + cons1->type = LispCons_t; + CDR(cons1) = cons; + cons2 = &x_cons[5]; + cons2->type = LispCons_t; + CDR(cons2) = cons1; + cons3 = &x_cons[4]; + cons3->type = LispCons_t; + CDR(cons3) = cons2; + cons4 = &x_cons[3]; + cons4->type = LispCons_t; + CDR(cons4) = cons3; + cons5 = &x_cons[2]; + cons5->type = LispCons_t; + CDR(cons5) = cons4; + cons6 = &x_cons[1]; + cons6->type = LispCons_t; + CDR(cons6) = cons5; + cons7 = &x_cons[0]; + cons7->type = LispCons_t; + CDR(cons7) = cons6; +} + +LispObj * +Lisp_Compile(LispBuiltin *builtin) +/* + compile name &optional definition + */ +{ + GC_ENTER(); + LispObj *result, *warnings_p, *failure_p; + + LispObj *name, *definition; + + definition = ARGUMENT(1); + name = ARGUMENT(0); + + result = name; + warnings_p = NIL; + failure_p = T; + + if (name != NIL) { + LispAtom *atom; + + CHECK_SYMBOL(name); + atom = name->data.atom; + if (atom->a_builtin || atom->a_compiled) + goto finished_compilation; + else if (atom->a_function) { + LispCom com; + int failed, *pfailed; + int lex, base, *plex, *pbase; + LispArgList *alist; + LispObj *lambda, *form, *arguments, **parguments; + LispObj **presult, **pwarnings_p, **pfailure_p, **pform; + + lambda = atom->property->fun.function; + if (definition != UNSPEC || lambda->funtype != LispFunction) + /* XXX TODO replace definition etc. */ + goto finished_compilation; + alist = atom->property->alist; + + memset(&com, 0, sizeof(LispCom)); + com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock)); + com.block->type = LispBlockClosure; + com.block->tag = name; + + /* Create a fake argument list to avoid yet another flag + * for ComCall. The value does not matter, just the fact + * that the symbol will be bound or not in the implicit + * PROGN of the function body. */ + base = alist->num_arguments - alist->auxs.num_symbols; + if (base) { + LispObj *argument; + int i, sforms; + + for (i = sforms = 0; i < alist->optionals.num_symbols; i++) + if (alist->optionals.sforms[i]) + ++sforms; + + arguments = form = NIL; + i = sforms + + alist->normals.num_symbols + alist->optionals.num_symbols; + + if (i) { + arguments = form = CONS(NIL, NIL); + GC_PROTECT(arguments); + for (--i; i > 0; i--) { + RPLACD(form, CONS(NIL, NIL)); + form = CDR(form); + } + } + + for (i = 0; i < alist->keys.num_symbols; i++) { + /* key symbol */ + if (alist->keys.keys[i]) + argument = QUOTE(alist->keys.keys[i]); + else + argument = alist->keys.symbols[i]; + + /* add key */ + if (arguments == NIL) { + arguments = form = CONS(argument, NIL); + GC_PROTECT(arguments); + } + else { + RPLACD(form, CONS(argument, NIL)); + form = CDR(form); + } + + /* add value */ + RPLACD(form, CONS(NIL, NIL)); + form = CDR(form); + + if (alist->keys.sforms[i]) { + RPLACD(form, CONS(NIL, NIL)); + form = CDR(form); + } + } + + if (alist->rest) { + if (arguments == NIL) { + arguments = form = CONS(NIL, NIL); + GC_PROTECT(arguments); + } + else { + RPLACD(form, CONS(NIL, NIL)); + form = CDR(form); + } + } + } + else + arguments = NIL; + + form = CONS(lambda->data.lambda.code, NIL); + GC_PROTECT(form); + com.form = form; + com.plist = CONS(NIL, NIL); + GC_PROTECT(com.plist); + + pfailed = &failed; + plex = &lex; + pbase = &base; + pform = &form; + presult = &result; + pwarnings_p = &warnings_p; + pfailure_p = &failure_p; + parguments = &arguments; + failed = 1; + if (setjmp(com.jmp) == 0) { + /* Save interpreter state */ + lex = com.lex = lisp__data.env.lex; + base = ComCall(&com, alist, name, arguments, 1, 0, 1); + + /* Generate code tree */ + lisp__data.env.lex = base; + ComProgn(&com, CAR(form)); + failed = 0; + } + + /* Restore interpreter state */ + lisp__data.env.lex = lex; + lisp__data.env.head = lisp__data.env.length = base; + + if (!failed) { + failure_p = NIL; + result = MakeBytecodeObject(&com, name, + lambda->data.lambda.data); + LispSetAtomCompiledProperty(atom, result); + result = name; + } + if (com.warnings) + warnings_p = FIXNUM(com.warnings); + goto finished_compilation; + } + else + goto undefined_function; + } + +undefined_function: + LispDestroy("%s: the function %s is undefined", + STRFUN(builtin), STROBJ(name)); + +finished_compilation: + RETURN(0) = warnings_p; + RETURN(1) = failure_p; + RETURN_COUNT = 2; + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Disassemble(LispBuiltin *builtin) +/* + disassemble function + */ +{ + int macro; + char buffer[128]; + LispAtom *atom; + LispArgList *alist; + LispBuiltin *xbuiltin; + LispObj *name, *lambda, *bytecode; + + LispObj *function; + + function = ARGUMENT(0); + + macro = 0; + alist = NULL; + xbuiltin = NULL; + name = bytecode = NULL; + + switch (OBJECT_TYPE(function)) { + case LispAtom_t: + name = function; + atom = function->data.atom; + alist = atom->property->alist; + if (atom->a_builtin) { + xbuiltin = atom->property->fun.builtin; + macro = xbuiltin->type == LispMacro; + } + else if (atom->a_compiled) + bytecode = atom->property->fun.function; + else if (atom->a_function) { + lambda = atom->property->fun.function; + macro = lambda->funtype == LispMacro; + } + else if (atom->a_defstruct && + atom->property->structure.function != STRUCT_NAME) { + 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; + xbuiltin = atom->property->fun.builtin; + } + else + LispDestroy("%s: the function %s is not defined", + STRFUN(builtin), STROBJ(function)); + break; + case LispBytecode_t: + name = Olambda; + bytecode = function; + break; + case LispLambda_t: + name = Olambda; + alist = (LispArgList*)function->data.lambda.name->data.opaque.data; + break; + case LispCons_t: + if (CAR(function) == Olambda) { + function = EVAL(function); + if (OBJECT_TYPE(function) == LispLambda_t) { + name = Olambda; + alist = (LispArgList*) + function->data.lambda.name->data.opaque.data; + break; + } + } + default: + LispDestroy("%s: %s is not a function", + STRFUN(builtin), STROBJ(function)); + break; + } + + if (xbuiltin) { + LispWriteStr(NIL, "Builtin ", 8); + if (macro) + LispWriteStr(NIL, "macro ", 6); + else + LispWriteStr(NIL, "function ", 9); + } + else if (macro) + LispWriteStr(NIL, "Macro ", 6); + else + LispWriteStr(NIL, "Function ", 9); + LispWriteObject(NIL, name); + LispWriteStr(NIL, ":\n", 2); + + if (alist) { + int i; + + sprintf(buffer, "%d required argument%s", + alist->normals.num_symbols, + alist->normals.num_symbols != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + for (i = 0; i < alist->normals.num_symbols; i++) { + LispWriteChar(NIL, i ? ',' : ':'); + LispWriteChar(NIL, ' '); + LispWriteStr(NIL, ATOMID(alist->normals.symbols[i]), + strlen(ATOMID(alist->normals.symbols[i]))); + } + LispWriteChar(NIL, '\n'); + + sprintf(buffer, "%d optional argument%s", + alist->optionals.num_symbols, + alist->optionals.num_symbols != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + for (i = 0; i < alist->optionals.num_symbols; i++) { + LispWriteChar(NIL, i ? ',' : ':'); + LispWriteChar(NIL, ' '); + LispWriteStr(NIL, ATOMID(alist->optionals.symbols[i]), + strlen(ATOMID(alist->optionals.symbols[i]))); + } + LispWriteChar(NIL, '\n'); + + sprintf(buffer, "%d keyword parameter%s", + alist->keys.num_symbols, + alist->keys.num_symbols != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + for (i = 0; i < alist->keys.num_symbols; i++) { + LispWriteChar(NIL, i ? ',' : ':'); + LispWriteChar(NIL, ' '); + LispWriteObject(NIL, alist->keys.symbols[i]); + } + LispWriteChar(NIL, '\n'); + + if (alist->rest) { + LispWriteStr(NIL, "Rest argument: ", 15); + LispWriteStr(NIL, ATOMID(alist->rest), + strlen(ATOMID(alist->rest))); + LispWriteChar(NIL, '\n'); + } + else + LispWriteStr(NIL, "No rest argument\n", 17); + } + + if (bytecode) { + char *ptr; + int *offsets[4]; + int i, done, j, sym0, sym1, con0, con1, bui0, byt0, strd, strf; + LispObj **constants; + LispAtom **symbols; + LispBuiltin **builtins; + unsigned char **codes; + LispObj **names; + short stack, num_constants, num_symbols, num_builtins, num_bytecodes; + unsigned char *base, *stream = bytecode->data.bytecode.bytecode->code; + + LispWriteStr(NIL, "\nBytecode header:\n", 18); + + /* Header information */ + stack = *(short*)stream; + stream += sizeof(short); + sprintf(buffer, "%d element%s used in the stack\n", + stack, stack != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + stack = *(short*)stream; + stream += sizeof(short); + sprintf(buffer, "%d element%s used in the builtin stack\n", + stack, stack != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + stack = *(short*)stream; + stream += sizeof(short); + sprintf(buffer, "%d element%s used in the protected stack\n", + stack, stack != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + + num_constants = *(short*)stream; + stream += sizeof(short); + num_symbols = *(short*)stream; + stream += sizeof(short); + num_builtins = *(short*)stream; + stream += sizeof(short); + num_bytecodes = *(short*)stream; + stream += sizeof(short); + + constants = (LispObj**)stream; + stream += num_constants * sizeof(LispObj*); + symbols = (LispAtom**)stream; + stream += num_symbols * sizeof(LispAtom*); + builtins = (LispBuiltin**)stream; + stream += num_builtins * sizeof(LispBuiltin*); + codes = (unsigned char**)stream; + stream += num_bytecodes * sizeof(unsigned char*); + names = (LispObj**)stream; + stream += num_bytecodes * sizeof(LispObj*); + + for (i = 0; i < num_constants; i++) { + sprintf(buffer, "Constant %d = %s\n", i, STROBJ(constants[i])); + LispWriteStr(NIL, buffer, strlen(buffer)); + } + +/* Macro XSTRING avoids some noisy in the output, if it were defined as + * #define XSTRING(object) object ? STROBJ(object) : #<UNBOUND> + * and called as XSTRING(atom->object) + * it would also print the package name were the symbol was first defined, + * but for local variables, only the symbol string is important. */ +#define XSTRING(string) string ? string : "#<UNBOUND>" + + for (i = 0; i < num_symbols; i++) { + sprintf(buffer, "Symbol %d = %s\n", + i, XSTRING(symbols[i]->string)); + LispWriteStr(NIL, buffer, strlen(buffer)); + } + for (i = 0; i < num_builtins; i++) { + sprintf(buffer, "Builtin %d = %s\n", + i, STROBJ(builtins[i]->symbol)); + LispWriteStr(NIL, buffer, strlen(buffer)); + } + for (i = 0; i < num_bytecodes; i++) { + sprintf(buffer, "Bytecode %d = %s\n", + i, STROBJ(names[i])); + LispWriteStr(NIL, buffer, strlen(buffer)); + } + + /* Make readability slightly easier printing the names of local + * variables where it's offset is known, i.e. function arguments. */ + if (alist) { + if (alist->num_arguments == 0) + LispWriteStr(NIL, "\nNo initial stack\n", 18); + else { + int len1, len2; + + j = 0; + LispWriteStr(NIL, "\nInitial stack:\n", 16); + + for (i = 0; i < alist->normals.num_symbols; i++, j++) { + sprintf(buffer, "%d = ", j); + LispWriteStr(NIL, buffer, strlen(buffer)); + ptr = alist->normals.symbols[i]->data.atom->string; + LispWriteStr(NIL, ptr, strlen(ptr)); + LispWriteChar(NIL, '\n'); + } + + for (i = 0; i < alist->optionals.num_symbols; i++, j++) { + sprintf(buffer, "%d = ", j); + LispWriteStr(NIL, buffer, strlen(buffer)); + ptr = alist->optionals.symbols[i]->data.atom->string; + LispWriteStr(NIL, ptr, strlen(ptr)); + LispWriteChar(NIL, '\n'); + if (alist->optionals.sforms[i]) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + ptr = alist->optionals.sforms[i]->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, len2); + LispWriteChars(NIL, ' ', 28 - (len1 + len2)); + LispWriteStr(NIL, "; sform\n", 9); + j++; + } + } + + for (i = 0; i < alist->keys.num_symbols; i++, j++) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + if (alist->keys.keys[i]) { + ptr = alist->keys.keys[i]->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, strlen(ptr)); + LispWriteChars(NIL, ' ', 28 - (len1 + len2)); + LispWriteStr(NIL, "; special key", 14); + } + else { + ptr = alist->keys.symbols[i]->data.atom->string; + LispWriteStr(NIL, ptr, strlen(ptr)); + } + LispWriteChar(NIL, '\n'); + if (alist->keys.sforms[i]) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + ptr = alist->keys.sforms[i]->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, len2); + LispWriteChars(NIL, ' ', 28 - (len1 + len2)); + LispWriteStr(NIL, "; sform\n", 9); + j++; + } + } + + if (alist->rest) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + ptr = alist->rest->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, len2); + LispWriteChar(NIL, '\n'); + j++; + } + + for (i = 0; i < alist->auxs.num_symbols; i++, j++) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + ptr = alist->auxs.symbols[i]->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, len2); + LispWriteChars(NIL, ' ', 28 - (len1 + len2)); + LispWriteStr(NIL, "; aux\n", 7); + } + } + } + + LispWriteStr(NIL, "\nBytecode stream:\n", 18); + + base = stream; + for (done = j = 0; !done; j = 0) { + sym0 = sym1 = con0 = con1 = bui0 = byt0 = strd = strf = -1; + sprintf(buffer, "%4ld ", (long)(stream - base)); + ptr = buffer + strlen(buffer); + switch (*stream++) { + case XBC_NOOP: strcpy(ptr, "NOOP"); break; + case XBC_PRED: + strcpy(ptr, "PRED:"); + ptr += strlen(ptr); + goto predicate; + case XBC_INV: strcpy(ptr, "INV"); break; + case XBC_NIL: strcpy(ptr, "NIL"); break; + case XBC_T: strcpy(ptr, "T"); break; + case XBC_CAR: strcpy(ptr, "CAR"); break; + case XBC_CDR: strcpy(ptr, "CDR"); break; + case XBC_RPLACA:strcpy(ptr, "RPLACA"); break; + case XBC_RPLACD:strcpy(ptr, "RPLACD"); break; + case XBC_EQ: strcpy(ptr, "EQ"); break; + case XBC_EQL: strcpy(ptr, "EQL"); break; + case XBC_EQUAL: strcpy(ptr, "EQUAL"); break; + case XBC_EQUALP:strcpy(ptr, "EQUALP"); break; + case XBC_LENGTH:strcpy(ptr, "LENGTH"); break; + case XBC_LAST: strcpy(ptr, "LAST"); break; + case XBC_NTHCDR:strcpy(ptr, "NTHCDR"); break; + case XBC_PUSH: strcpy(ptr, "PUSH"); break; + case XBC_CAR_PUSH: + strcpy(ptr, "CAR&PUSH"); + break; + case XBC_CDR_PUSH: + strcpy(ptr, "CDR&PUSH"); + break; + case XBC_PUSH_NIL: + strcpy(ptr, "PUSH NIL"); + break; + case XBC_PUSH_UNSPEC: + strcpy(ptr, "PUSH #<UNSPEC>"); + break; + case XBC_PUSH_T: + strcpy(ptr, "PUSH T"); + break; + case XBC_PUSH_NIL_N: + strcpy(ptr, "PUSH NIL "); + ptr += strlen(ptr); + sprintf(ptr, "%d", (int)(*stream++)); + break; + case XBC_PUSH_UNSPEC_N: + strcpy(ptr, "PUSH #<UNSPEC> "); + ptr += strlen(ptr); + sprintf(ptr, "%d", (int)(*stream++)); + break; + case XBC_LET: + strcpy(ptr, "LET"); +/* update sym0 */ +symbol: + offsets[j++] = &sym0; +/* update <offsets> - print [byte] */ +offset: + ptr += strlen(ptr); + i = *stream++; + *(offsets[j - 1]) = i; + sprintf(ptr, " [%d]", i); + break; + case XBC_LETX: + strcpy(ptr, "LET*"); + goto symbol; + case XBC_LET_NIL: + strcpy(ptr, "LET NIL"); + goto symbol; + case XBC_LETX_NIL: + strcpy(ptr, "LET* NIL"); + goto symbol; + case XBC_LETBIND: + strcpy(ptr, "LETBIND"); +/* print byte */ +value: + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)(*stream++)); + break; + case XBC_UNLET:strcpy(ptr, "UNLET"); goto value; + case XBC_LOAD: + strcpy(ptr, "LOAD"); +/* print (byte) */ +reference: + ptr += strlen(ptr); + i = *stream++; + sprintf(ptr, " (%d)", i); + break; + case XBC_LOAD_CAR: + strcpy(ptr, "LOAD&CAR"); + goto reference; + case XBC_LOAD_CDR: + strcpy(ptr, "LOAD&CDR"); + goto reference; + case XBC_LOAD_CAR_STORE: + strcpy(ptr, "LOAD&CAR&STORE"); + goto reference; + case XBC_LOAD_CDR_STORE: + strcpy(ptr, "LOAD&CDR&STORE"); + goto reference; + case XBC_LOAD_LET: + strcpy(ptr, "LOAD&LET"); +load_let: + offsets[j++] = &sym0; + i = *stream++; + ptr += strlen(ptr); + sprintf(ptr, " (%d)", i); + goto offset; + case XBC_LOAD_LETX: + strcpy(ptr, "LOAD&LET*"); + goto load_let; + case XBC_STRUCT: + strcpy(ptr, "STRUCT"); + offsets[j++] = &strf; + offsets[j++] = &strd; +/* update <offsets> - print [byte] - update <offsets> - print [byte] */ +offset_offset: + ptr += strlen(ptr); + i = *stream++; + *(offsets[j - 2]) = i; + sprintf(ptr, " [%d]", i); + goto offset; + case XBC_LOAD_PUSH: + strcpy(ptr, "LOAD&PUSH"); + goto reference; + case XBC_LOADCON: + strcpy(ptr, "LOADCON"); +constant: + offsets[j++] = &con0; + goto offset; + case XBC_LOADCON_SET: + strcpy(ptr, "LOADCON&SET"); + offsets[j++] = &con0; +/* update <offsets> - print [byte] - print (byte) */ +offset_reference: + i = *stream++; + *(offsets[j - 1]) = i; + ptr += strlen(ptr); + sprintf(ptr, " [%d]", i); + goto reference; + case XBC_STRUCTP: + strcpy(ptr, "STRUCTP"); + offsets[j++] = &strd; + goto offset; + case XBC_LOADCON_LET: + strcpy(ptr, "LOADCON&LET"); +loadcon_let: + offsets[j++] = &con0; + offsets[j++] = &sym0; + goto offset_offset; + case XBC_LOADCON_LETX: + strcpy(ptr, "LOADCON&LET*"); + goto loadcon_let; + case XBC_LOADCON_PUSH: + strcpy(ptr, "LOADCON&PUSH"); + goto constant; + case XBC_LOADSYM: + strcpy(ptr, "LOADSYM"); + goto symbol; + case XBC_LOADSYM_LET: + strcpy(ptr, "LOADSYM&LET"); +loadsym_let: + offsets[j++] = &sym0; + offsets[j++] = &sym1; + goto offset_offset; + case XBC_LOADSYM_LETX: + strcpy(ptr, "LOADSYM&LET*"); + goto loadsym_let; + case XBC_LOADSYM_PUSH: + strcpy(ptr, "LOADSYM&PUSH"); + goto symbol; + case XBC_LOAD_SET: + strcpy(ptr, "LOAD&SET"); +/* print (byte) - print (byte) */ +reference_reference: + ptr += strlen(ptr); + i = *stream++; + sprintf(ptr, " (%d)", i); + goto reference; + case XBC_LOAD_CAR_SET: + strcpy(ptr, "LOAD&CAR&SET"); + goto reference_reference; + case XBC_LOAD_CDR_SET: + strcpy(ptr, "LOAD&CDR&SET"); + goto reference_reference; + case XBC_CAR_SET: + strcpy(ptr, "CAR&SET"); + goto reference; + case XBC_CDR_SET: + strcpy(ptr, "CDR&SET"); + goto reference; + case XBC_SET: + strcpy(ptr, "SET"); + goto reference; + case XBC_SETSYM: + strcpy(ptr, "SETSYM"); + goto symbol; + case XBC_SET_NIL: + strcpy(ptr, "SET NIL"); + goto reference; + case XBC_CALL: + strcpy(ptr, "CALL"); + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)(*stream++)); + offsets[j++] = &bui0; + goto offset; + case XBC_CALL_SET: + strcpy(ptr, "CALL&SET"); + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)(*stream++)); + offsets[j++] = &bui0; + goto offset_reference; + case XBC_BYTECALL: + strcpy(ptr, "BYTECALL"); + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)(*stream++)); + offsets[j++] = &byt0; + goto offset; + case XBC_FUNCALL: + strcpy(ptr, "FUNCALL"); +constant_constant: + offsets[j++] = &con0; + offsets[j++] = &con1; + goto offset_offset; + case XBC_CCONS: + strcpy(ptr, "CCONS"); + goto constant_constant; + case XBC_CSTAR: strcpy(ptr, "CSTAR"); break; + case XBC_CFINI: strcpy(ptr, "CFINI"); break; + case XBC_LSTAR: strcpy(ptr, "LSTAR"); break; + case XBC_LCONS: strcpy(ptr, "LCONS"); break; + case XBC_LFINI: strcpy(ptr, "LFINI"); break; + case XBC_BCONS: strcpy(ptr, "BCONS"); break; + case XBC_BCONS1: case XBC_BCONS2: case XBC_BCONS3: + case XBC_BCONS4: case XBC_BCONS5: case XBC_BCONS6: + case XBC_BCONS7: + strcpy(ptr, "BCONS"); + ptr += strlen(ptr); + sprintf(ptr, "%d", (int)(stream[-1] - XBC_BCONS)); + break; + case XBC_JUMP: + strcpy(ptr, "JUMP"); +integer: + ptr += strlen(ptr); + sprintf(ptr, " %d", *(signed short*)stream); + stream += sizeof(short); + break; + case XBC_JUMPT: + strcpy(ptr, "JUMPT"); + goto integer; + case XBC_JUMPNIL: + strcpy(ptr, "JUMPNIL"); + goto integer; + case XBC_LETREC: + strcpy(ptr, "LETREC"); + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)*stream++); + break; + case XBC_RETURN: + strcpy(ptr, "RETURN"); + done = 1; + break; + } + i = ptr - buffer + strlen(ptr); + LispWriteStr(NIL, buffer, i); + if (j) { + + /* Pad */ + LispWriteChars(NIL, ' ', 28 - i); + LispWriteChar(NIL, ';'); + + ptr = buffer; + + /* Structure */ + if (strf >= 0) { + /* strd is valid if strf set */ + LispObj *fields = constants[strd]; + + for (; strf >= 0; strf--) + fields = CDR(fields); + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, CAR(fields)->data.atom->string); + ptr += strlen(ptr); + } + if (strd >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(CAR(constants[strd]))); + ptr += strlen(ptr); + } + + /* Constants */ + if (con0 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(constants[con0])); + ptr += strlen(ptr); + if (con1 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(constants[con1])); + ptr += strlen(ptr); + } + } + + /* Builtin */ + if (bui0 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(builtins[bui0]->symbol)); + ptr += strlen(ptr); + } + + /* Bytecode */ + if (byt0 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(names[byt0])); + ptr += strlen(ptr); + } + + /* Symbols */ + if (sym0 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, XSTRING(symbols[sym0]->string)); + ptr += strlen(ptr); + if (sym1 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, XSTRING(symbols[sym1]->string)); + ptr += strlen(ptr); + } + } + + i = ptr - buffer; + LispWriteStr(NIL, buffer, i); + } + LispWriteChar(NIL, '\n'); + continue; +predicate: + switch (*stream++) { + case XBP_CONSP: strcpy(ptr, "CONSP"); break; + case XBP_LISTP: strcpy(ptr, "LISTP"); break; + case XBP_NUMBERP: strcpy(ptr, "NUMBERP"); break; + } + LispWriteStr(NIL, buffer, ptr - buffer + strlen(ptr)); + LispWriteChar(NIL, '\n'); + } +#undef XSTRING + } + + return (function); +} + + + +LispObj * +LispCompileForm(LispObj *form) +{ + GC_ENTER(); + int failed, *pfailed; + LispCom com; + LispObj *code, **pform; + + if (!CONSP(form)) + /* Incorrect call or NIL */ + return (form); + + memset(&com, 0, sizeof(LispCom)); + + com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock)); + com.block->type = LispBlockNone; + com.lex = lisp__data.env.lex; + + com.plist = CONS(NIL, NIL); + GC_PROTECT(com.plist); + + pfailed = &failed; + pform = &form; + failed = 1; + if (setjmp(com.jmp) == 0) { + for (code = form; CONSP(form); form = CDR(form)) { + com.form = form; + ComEval(&com, CAR(form)); + } + failed = 0; + } + GC_LEAVE(); + + return (failed ? NIL : MakeBytecodeObject(&com, NIL, NIL)); +} + +LispObj * +LispExecuteBytecode(LispObj *object) +{ + if (!BYTECODEP(object)) + return (EVAL(object)); + + return (ExecuteBytecode(object->data.bytecode.bytecode->code)); +} + +static LispObj * +MakeBytecodeObject(LispCom *com, LispObj *name, LispObj *plist) +{ + LispObj *object; + LispBytecode *bytecode; + + GC_ENTER(); + unsigned char *stream; + short i, num_constants; + LispObj **constants, *code, *cons, *prev; + + /* Resolve dependencies, optimize and create byte stream */ + LinkBytecode(com); + + object = LispNew(NIL, NIL); + GC_PROTECT(object); + bytecode = LispMalloc(sizeof(LispBytecode)); + bytecode->code = com->bytecode; + bytecode->length = com->length; + + + stream = bytecode->code; + + /* Skip stack information */ + stream += sizeof(short) * 3; + + /* Get information */ + num_constants = *(short*)stream; + stream += sizeof(short) * 4; + constants = (LispObj**)stream; + + GC_PROTECT(plist); + code = cons = prev = NIL; + for (i = 0; i < num_constants; i++) { + if (POINTERP(constants[i]) && !XSYMBOLP(constants[i])) { + if (code == NIL) { + code = cons = prev = CONS(constants[i], NIL); + GC_PROTECT(code); + } + else { + RPLACD(cons, CONS(constants[i], NIL)); + prev = cons; + cons = CDR(cons); + } + } + } + + /* Protect this in case the function is redefined */ + for (i = 0; i < com->table.num_bytecodes; i++) { + if (code == NIL) { + code = cons = prev = CONS(com->table.bytecodes[i], NIL); + GC_PROTECT(code); + } + else { + RPLACD(cons, CONS(com->table.bytecodes[i], NIL)); + prev = cons; + cons = CDR(cons); + } + } + + /* Free everything, but the LispCom structure and the generated bytecode */ + CompileFreeState(com); + + /* Allocate the minimum required number of cons cells to protect objects */ + if (!CONSP(code)) + code = plist; + else if (CONSP(plist)) { + if (code == cons) + RPLACD(code, plist); + else + RPLACD(cons, plist); + } + else { + if (code == cons) + code = CAR(code); + else + CDR(prev) = CAR(cons); + } + + object->data.bytecode.bytecode = bytecode; + /* Byte code references this object, so it cannot be garbage collected */ + object->data.bytecode.code = code; + object->data.bytecode.name = name; + object->type = LispBytecode_t; + + LispMused(bytecode); + LispMused(bytecode->code); + GC_LEAVE(); + + return (object); +} + +static void +CompileFreeTree(CodeTree *tree) +{ + if (tree->type == CodeTreeBlock) + CompileFreeBlock(tree->data.block); + LispFree(tree); +} + +static void +CompileFreeBlock(CodeBlock *block) +{ + CodeTree *tree = block->tree, *next; + + while (tree) { + next = tree->next; + CompileFreeTree(tree); + tree = next; + } + if (block->type == LispBlockBody) { + LispFree(block->tagbody.labels); + LispFree(block->tagbody.codes); + } + LispFree(block->variables.symbols); + LispFree(block->variables.flags); + LispFree(block); +} + +static void +CompileFreeState(LispCom *com) +{ + CompileFreeBlock(com->block); + LispFree(com->table.constants); + LispFree(com->table.symbols); + LispFree(com->table.builtins); + LispFree(com->table.bytecodes); +} + +/* XXX Put a breakpoint here when changing the macro expansion code. + * No opcodes should be generated during macro expansion. */ +static CodeTree * +CompileNewTree(LispCom *com, CodeTreeType type) +{ + CodeTree *tree = LispMalloc(sizeof(CodeTree)); + + tree->type = type; + tree->next = NULL; + tree->block = com->block; + if (com->block->tree == NULL) + com->block->tree = tree; + else + com->block->tail->next = tree; + com->block->tail = tree; + + return (tree); +} + +static void +CompileIniBlock(LispCom *com, LispBlockType type, LispObj *tag) +{ + CodeTree *tree = NEW_TREE(CodeTreeBlock); + CodeBlock *block = LispCalloc(1, sizeof(CodeBlock)); + + tree->data.block = block; + + block->type = type; + block->tag = tag; + block->prev = com->block; + block->parent = tree; + block->level = com->level; + com->block = block; + + if (type == LispBlockBody) + com->tagbody = com->level; +} + +static void +CompileFiniBlock(LispCom *com) +{ + com->block = com->block->prev; + if (com->block && com->block->type == LispBlockBody) + com->tagbody = com->block->level; +} + +static void +com_BytecodeChar(LispCom *com, LispByteOpcode code, char value) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.signed_char = value; +} + +static void +com_BytecodeShort(LispCom *com, LispByteOpcode code, short value) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.signed_short = value; +} + +static void +com_BytecodeAtom(LispCom *com, LispByteOpcode code, LispAtom *atom) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.atom = atom; +} + +static void +com_BytecodeObject(LispCom *com, LispByteOpcode code, LispObj *object) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.object = object; +} + +static void +com_BytecodeCons(LispCom *com, LispByteOpcode code, LispObj *car, LispObj *cdr) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.cons.car = car; + tree->data.cons.cdr = cdr; +} + +static void +com_Bytecode(LispCom *com, LispByteOpcode code) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; +} + +static void +com_Load(LispCom *com, short offset) +{ + com_BytecodeShort(com, XBC_LOAD, offset); +} + +static void +com_LoadLet(LispCom *com, short offset, LispAtom *name) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_LOAD_LET; + tree->data.let.offset = offset; + tree->data.let.name = name; +} + +static void +com_LoadPush(LispCom *com, short offset) +{ + com_BytecodeShort(com, XBC_LOAD_PUSH, offset); +} + +static void +com_Let(LispCom *com, LispAtom *name) +{ + com_BytecodeAtom(com, XBC_LET, name); +} + +static void +com_Bind(LispCom *com, short count) +{ + if (count) + com_BytecodeShort(com, XBC_LETBIND, count); +} + +static void +com_Unbind(LispCom *com, short count) +{ + if (count) + com_BytecodeShort(com, XBC_UNLET, count); +} + +static void +com_LoadSym(LispCom *com, LispAtom *atom) +{ + com_BytecodeAtom(com, XBC_LOADSYM, atom); +} + +static void +com_LoadSymLet(LispCom *com, LispAtom *symbol, LispAtom *name) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_LOADSYM_LET; + tree->data.let_sym.symbol = symbol; + tree->data.let_sym.name = name; +} + +static void +com_LoadSymPush(LispCom *com, LispAtom *name) +{ + com_BytecodeAtom(com, XBC_LOADSYM_PUSH, name); +} + +static void +com_LoadCon(LispCom *com, LispObj *constant) +{ + if (constant == NIL) + com_Bytecode(com, XBC_NIL); + else if (constant == T) + com_Bytecode(com, XBC_T); + else if (constant == UNSPEC) { + COMPILE_FAILURE("internal error: loading #<UNSPEC>"); + } + else + com_BytecodeObject(com, XBC_LOADCON, constant); +} + +static void +com_LoadConLet(LispCom *com, LispObj *constant, LispAtom *name) +{ + if (constant == NIL) + com_BytecodeAtom(com, XBC_LET_NIL, name); + else { + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_LOADCON_LET; + tree->data.let_con.object = constant; + tree->data.let_con.name = name; + } +} + +static void +com_LoadConPush(LispCom *com, LispObj *constant) +{ + if (constant == NIL) + com_Bytecode(com, XBC_PUSH_NIL); + else if (constant == T) + com_Bytecode(com, XBC_PUSH_T); + else if (constant == UNSPEC) + com_Bytecode(com, XBC_PUSH_UNSPEC); + else + com_BytecodeObject(com, XBC_LOADCON_PUSH, constant); +} + +static void +com_Set(LispCom *com, short offset) +{ + com_BytecodeShort(com, XBC_SET, offset); +} + +static void +com_SetSym(LispCom *com, LispAtom *symbol) +{ + com_BytecodeAtom(com, XBC_SETSYM, symbol); +} + +static void +com_Struct(LispCom *com, short offset, LispObj *definition) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_STRUCT; + tree->data.struc.offset = offset; + tree->data.struc.definition = definition; +} + +static void +com_Structp(LispCom *com, LispObj *definition) +{ + com_BytecodeObject(com, XBC_STRUCTP, definition); +} + +static void +com_Call(LispCom *com, unsigned char num_arguments, LispBuiltin *builtin) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_CALL; + tree->data.builtin.num_arguments = num_arguments; + tree->data.builtin.builtin = builtin; +} + +static void +com_Bytecall(LispCom *com, unsigned char num_arguments, LispObj *code) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_BYTECALL; + tree->data.bytecall.num_arguments = num_arguments; + tree->data.bytecall.code = code; +} + +static void +com_Funcall(LispCom *com, LispObj *function, LispObj *arguments) +{ + com_BytecodeCons(com, XBC_FUNCALL, function, arguments); +} + +static void +CompileStackEnter(LispCom *com, int count, int builtin) +{ + if (!com->macro) { + if (builtin) { + com->stack.cbstack += count; + if (com->stack.bstack < com->stack.cbstack) + com->stack.bstack = com->stack.cbstack; + } + else { + com->stack.cstack += count; + if (com->stack.stack < com->stack.cstack) + com->stack.stack = com->stack.cstack; + } + } +} + +static void +CompileStackLeave(LispCom *com, int count, int builtin) +{ + if (!com->macro) { + if (builtin) + com->stack.cbstack -= count; + else + com->stack.cstack -= count; + } +} + +static void +LinkWarnUnused(LispCom *com, CodeBlock *block) +{ + int i; + CodeTree *tree; + + for (tree = block->tree; tree; tree = tree->next) { + if (tree->type == CodeTreeBlock) + LinkWarnUnused(com, tree->data.block); + } + + for (i = 0; i < block->variables.length; i++) + if (!(block->variables.flags[i] & (VARIABLE_USED | VARIABLE_ARGUMENT))) { + ++com->warnings; + LispWarning("the variable %s is unused", + block->variables.symbols[i]->string); + } +} + +#define INTERNAL_ERROR_STRING "COMPILE: internal error #%d" +#define INTERNAL_ERROR(value) LispDestroy(INTERNAL_ERROR_STRING, value) +static long +LinkBuildOffsets(LispCom *com, CodeTree *tree, long offset) +{ + for (; tree; tree = tree->next) { + tree->offset = offset; + switch (tree->type) { + case CodeTreeBytecode: + switch (tree->code) { + case XBC_NOOP: + INTERNAL_ERROR(__LINE__); + break; + + /* byte */ + case XBC_BCONS: + case XBC_BCONS1: + case XBC_BCONS2: + case XBC_BCONS3: + case XBC_BCONS4: + case XBC_BCONS5: + case XBC_BCONS6: + case XBC_BCONS7: + case XBC_INV: + case XBC_NIL: + case XBC_T: + case XBC_PUSH: + case XBC_CAR_PUSH: + case XBC_CDR_PUSH: + case XBC_PUSH_NIL: + case XBC_PUSH_UNSPEC: + case XBC_PUSH_T: + case XBC_LSTAR: + case XBC_LCONS: + case XBC_LFINI: + case XBC_RETURN: + case XBC_CSTAR: + case XBC_CFINI: + case XBC_CAR: + case XBC_CDR: + case XBC_RPLACA: + case XBC_RPLACD: + case XBC_EQ: + case XBC_EQL: + case XBC_EQUAL: + case XBC_EQUALP: + case XBC_LENGTH: + case XBC_LAST: + case XBC_NTHCDR: + ++offset; + break; + + /* byte + byte */ + case XBC_PUSH_NIL_N: + case XBC_PUSH_UNSPEC_N: + case XBC_PRED: + case XBC_LETREC: + case XBC_LOAD_PUSH: + case XBC_CAR_SET: + case XBC_CDR_SET: + case XBC_SET: + case XBC_SET_NIL: + case XBC_LETBIND: + case XBC_UNLET: + case XBC_LOAD: + case XBC_LOAD_CAR: + case XBC_LOAD_CDR: + case XBC_LOAD_CAR_STORE: + case XBC_LOAD_CDR_STORE: + case XBC_LET: + case XBC_LETX: + case XBC_LET_NIL: + case XBC_LETX_NIL: + case XBC_STRUCTP: + case XBC_SETSYM: + case XBC_LOADCON_PUSH: + case XBC_LOADSYM_PUSH: + case XBC_LOADCON: + case XBC_LOADSYM: + offset += 2; + break; + + /* byte + byte + byte */ + case XBC_CALL: + case XBC_BYTECALL: + case XBC_LOAD_SET: + case XBC_LOAD_CAR_SET: + case XBC_LOAD_CDR_SET: + case XBC_LOADCON_SET: + case XBC_LOAD_LET: + case XBC_LOAD_LETX: + case XBC_STRUCT: + case XBC_LOADCON_LET: + case XBC_LOADCON_LETX: + case XBC_LOADSYM_LET: + case XBC_LOADSYM_LETX: + case XBC_CCONS: + case XBC_FUNCALL: + offset += 3; + break; + + /* byte + short */ + case XBC_JUMP: + case XBC_JUMPT: + case XBC_JUMPNIL: + /* XXX this is likely a jump to random address here */ + INTERNAL_ERROR(__LINE__); + offset += sizeof(short) + 1; + break; + + /* byte + byte + byte + byte */ + case XBC_CALL_SET: + offset += 4; + break; + } + break; + case CodeTreeLabel: + /* Labels are not loaded */ + break; + case CodeTreeJump: + case CodeTreeJumpIf: + case CodeTreeCond: + /* If not the point where the conditional block finishes */ + if (tree->code != XBC_NOOP) + /* Reserve space for the jump opcode */ + offset += sizeof(short) + 1; + break; + case CodeTreeGo: + case CodeTreeReturn: + /* Reserve space for the jump opcode */ + offset += sizeof(short) + 1; + break; + case CodeTreeBlock: + offset = LinkBuildOffsets(com, tree->data.block->tree, offset); + break; + } + } + + return (offset); +} + +static void +LinkDoOptimize_0(LispCom *com, CodeBlock *block) +{ + CodeTree *tree, *prev, *next; + + /* Remove redundant or join opcodes that can be joined. Do it here + * because some of these are hard to detect earlier, and/or would + * require a lot of duplicated code or more time. */ + tree = prev = block->tree; + while (tree) { + next = tree->next; + + /* LET -> LET* */ + if (next && + next->type == CodeTreeBytecode && + next->code == XBC_LETBIND && + next->data.signed_short == 1) { + switch (tree->code) { + case XBC_LET: + tree->code = XBC_LETX; + goto remove_next_label; + case XBC_LET_NIL: + tree->code = XBC_LETX_NIL; + goto remove_next_label; + case XBC_LOAD_LET: + tree->code = XBC_LOAD_LETX; + goto remove_next_label; + case XBC_LOADCON_LET: + tree->code = XBC_LOADCON_LETX; + goto remove_next_label; + case XBC_LOADSYM_LET: + tree->code = XBC_LOADSYM_LETX; + goto remove_next_label; + default: + break; + } + } + + switch (tree->type) { + case CodeTreeBytecode: + switch (tree->code) { + case XBC_LOADCON: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_LET: + next->code = XBC_LOADCON_LET; + next->data.let_con.name = + next->data.atom; + next->data.let_con.object = + tree->data.object; + goto remove_label; + case XBC_PUSH: + next->code = XBC_LOADCON_PUSH; + next->data.object = tree->data.object; + goto remove_label; + case XBC_CAR: + if (tree->data.object != NIL) { + if (!CONSP(tree->data.object)) + LispDestroy("CAR: %s is not a list", + STROBJ( + tree->data.object)); + next->code = XBC_LOADCON; + next->data.object = + CAR(tree->data.object); + } + goto remove_label; + case XBC_CDR: + if (tree->data.object != NIL) { + if (!CONSP(tree->data.object)) + LispDestroy("CAR: %s is not a list", + STROBJ( + tree->data.object)); + next->code = XBC_LOADCON; + next->data.object = + CDR(tree->data.object); + } + goto remove_label; + case XBC_SET: + next->code = XBC_LOADCON_SET; + next->data.load_con_set.offset = + next->data.signed_short; + next->data.load_con_set.object = + tree->data.object; + goto remove_label; + default: + break; + } + } + break; + case XBC_LOADSYM: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_LET: + next->code = XBC_LOADSYM_LET; + next->data.let_sym.name = + next->data.atom; + next->data.let_sym.symbol = + tree->data.atom; + goto remove_label; + case XBC_PUSH: + next->code = XBC_LOADSYM_PUSH; + next->data.atom = tree->data.atom; + goto remove_label; + default: + break; + } + } + break; + case XBC_LOAD: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_LOAD_SET; + next->data.load_set.set = + next->data.signed_short; + next->data.load_set.load = + tree->data.signed_short; + goto remove_label; + /* TODO add XBC_LOAD_SETSYM */ + case XBC_CAR: + next->code = XBC_LOAD_CAR; + next->data.signed_short = + tree->data.signed_short; + goto remove_label; + case XBC_CDR: + next->code = XBC_LOAD_CDR; + next->data.signed_short = + tree->data.signed_short; + goto remove_label; + case XBC_PUSH: + tree->code = XBC_LOAD_PUSH; + goto remove_next_label; + case XBC_LET: + next->code = XBC_LOAD_LET; + next->data.let.name = next->data.atom; + next->data.let.offset = + tree->data.signed_short; + goto remove_label; + default: + break; + } + } + break; + case XBC_LOAD_CAR: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_SET) { + if (next->data.signed_short == + tree->data.signed_short) + next->code = XBC_LOAD_CAR_STORE; + else { + next->code = XBC_LOAD_CAR_SET; + next->data.load_set.set = + next->data.signed_short; + next->data.load_set.load = + tree->data.signed_short; + } + goto remove_label; + } + break; + case XBC_LOAD_CDR: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_SET) { + if (next->data.signed_short == + tree->data.signed_short) + next->code = XBC_LOAD_CDR_STORE; + else { + next->code = XBC_LOAD_CDR_SET; + next->data.load_set.set = + next->data.signed_short; + next->data.load_set.load = + tree->data.signed_short; + } + goto remove_label; + } + break; + case XBC_CALL: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_CALL_SET; + next->data.builtin.offset = + next->data.signed_short; + next->data.builtin.num_arguments = + tree->data.builtin.num_arguments; + next->data.builtin.builtin = + tree->data.builtin.builtin; + goto remove_label; + /* TODO add XBC_CALL_SETSYM */ + default: + break; + } + } + break; + case XBC_CAR: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_CAR_SET; + goto remove_label; + /* TODO add XBC_CAR_SETSYM */ + case XBC_PUSH: + next->code = XBC_CAR_PUSH; + goto remove_label; + default: + break; + } + } + break; + case XBC_CDR: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_CDR_SET; + goto remove_label; + /* TODO add XBC_CDR_SETSYM */ + case XBC_PUSH: + next->code = XBC_CDR_PUSH; + goto remove_label; + default: + break; + } + } + break; + case XBC_NIL: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_SET_NIL; + goto remove_label; + /* TODO add XBC_SETSYM_NIL */ + default: + break; + } + } + break; + case XBC_PUSH_NIL: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_PUSH_NIL) { + next->code = XBC_PUSH_NIL_N; + next->data.signed_char = 2; + goto remove_label; + } + break; + case XBC_PUSH_NIL_N: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_PUSH_NIL) { + next->code = XBC_PUSH_NIL_N; + next->data.signed_char = tree->data.signed_char + 1; + goto remove_label; + } + break; + case XBC_PUSH_UNSPEC: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_PUSH_UNSPEC) { + next->code = XBC_PUSH_UNSPEC_N; + next->data.signed_char = 2; + goto remove_label; + } + break; + case XBC_PUSH_UNSPEC_N: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_PUSH_UNSPEC) { + next->code = XBC_PUSH_UNSPEC_N; + next->data.signed_char = tree->data.signed_char + 1; + goto remove_label; + } + break; + default: + break; + } + break; + case CodeTreeBlock: + LinkDoOptimize_0(com, tree->data.block); + break; + default: + break; + } + goto update_label; +remove_label: + if (tree == block->tree) { + block->tree = prev = next; + if (tree == block->tail) + block->tail = tree; + } + else + prev->next = next; + CompileFreeTree(tree); + tree = next; + continue; +remove_next_label: + tree->next = next->next; + CompileFreeTree(next); + continue; +update_label: + prev = tree; + tree = tree->next; + } +} + +static void +LinkOptimize_0(LispCom *com) +{ + /* Recursive */ + LinkDoOptimize_0(com, com->block); +} + +static void +LinkResolveLabels(LispCom *com, CodeBlock *block) +{ + int i; + CodeTree *tree = block->tree; + + for (; tree; tree = tree->next) { + if (tree->type == CodeTreeBlock) + LinkResolveLabels(com, tree->data.block); + else if (tree->type == CodeTreeLabel) { + for (i = 0; i < block->tagbody.length; i++) + if (tree->data.object == block->tagbody.labels[i]) { + block->tagbody.codes[i] = tree; + break; + } + } + } +} + +static void +LinkResolveJumps(LispCom *com, CodeBlock *block) +{ + int i; + CodeBlock *body = block; + CodeTree *ptr, *tree = block->tree; + + /* Check if there is a tagbody. Error checking already done */ + while (body && body->type != LispBlockBody) + body = body->prev; + + for (; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + case CodeTreeLabel: + break; + + case CodeTreeBlock: + LinkResolveJumps(com, tree->data.block); + break; + + case CodeTreeGo: + for (i = 0; i < body->tagbody.length; i++) + if (tree->data.object == body->tagbody.labels[i]) + break; + if (i == body->tagbody.length) + LispDestroy("COMPILE: no visible tag %s to GO", + STROBJ(tree->data.object)); + /* Now the jump code is known */ + tree->data.tree = body->tagbody.codes[i]; + break; + + case CodeTreeCond: + if (tree->code == XBC_JUMPNIL) + /* If test is NIL, go to next test */ + tree->data.tree = tree->group->next; + else if (tree->code == XBC_JUMPT) { + /* After executing code, test was T */ + for (ptr = tree->group; + ptr->code != XBC_NOOP; + ptr = ptr->group) + ; + tree->data.tree = ptr; + } + break; + + case CodeTreeJumpIf: + if (tree->code != XBC_NOOP) { + for (ptr = tree->group; + ptr->code != XBC_NOOP; + ptr = ptr->group) { + if (ptr->type == CodeTreeJump) { + /* ELSE code of IF */ + ptr = ptr->next; + /* Skip inconditional jump node */ + break; + } + } + tree->data.tree = ptr; + } + break; + + case CodeTreeJump: + if (tree->code != XBC_NOOP) + tree->data.tree = tree->group; + break; + + case CodeTreeReturn: + /* One bytecode is guaranteed to exist in the code tree */ + if (tree->data.block->parent == NULL) + /* Returning from the function or toplevel form */ + tree->data.tree = tree->data.block->tail; + else { + for (;;) { + ptr = tree->data.block->parent->next; + if (ptr) { + tree->data.tree = ptr; + break; + } + else + /* Move one BLOCK up */ + tree->data.block = tree->data.block->prev; + } + } + break; + } + } +} + +static long +LinkPad(long offset, long adjust, int preffix, int datalen) +{ + /* If byte or aligned data */ + if (datalen <= preffix || ((offset + adjust + preffix) % datalen) == 0) + return (adjust); + + return (adjust + (datalen - ((offset + adjust + preffix) % datalen))); +} + +static long +LinkFixupOffsets(LispCom *com, CodeTree *tree, long adjust) +{ + for (; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + switch (tree->code) { + /* byte + short */ + case XBC_JUMP: + case XBC_JUMPT: + case XBC_JUMPNIL: + adjust = LinkPad(tree->offset, adjust, 1, + sizeof(short)); + /*FALLTROUGH*/ + default: + tree->offset += adjust; + break; + } + break; + case CodeTreeLabel: + /* Labels are not loaded, just adjust offset */ + tree->offset += adjust; + break; + case CodeTreeJump: + case CodeTreeCond: + case CodeTreeJumpIf: + /* If an opcode will be generated. */ + if (tree->code != XBC_NOOP) + adjust = LinkPad(tree->offset, adjust, 1, sizeof(short)); + tree->offset += adjust; + break; + case CodeTreeGo: + case CodeTreeReturn: + adjust = LinkPad(tree->offset, adjust, 1, sizeof(short)); + tree->offset += adjust; + break; + case CodeTreeBlock: + adjust = LinkFixupOffsets(com, tree->data.block->tree, adjust); + break; + } + } + + return (adjust); +} + +static void +LinkSkipPadding(LispCom *com, CodeTree *tree) +{ + int found; + CodeTree *ptr; + + /* Recurse to adjust forward jumps or jumps to the start of the block */ + for (ptr = tree; ptr; ptr = ptr->next) { + if (ptr->type == CodeTreeBlock) { + LinkSkipPadding(com, ptr->data.block->tree); + ptr->offset = ptr->data.block->tree->offset; + } + } + + /* Adjust the nodes offsets */ + for (; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + case CodeTreeBlock: + case CodeTreeGo: + case CodeTreeReturn: + break; + case CodeTreeJump: + case CodeTreeCond: + case CodeTreeJumpIf: + if (tree->code != XBC_NOOP) + /* If code will be generated */ + break; + case CodeTreeLabel: + /* This should be done in reversed order, but to avoid + * the requirement of a prev pointer, do the job in a + * harder way here. */ + for (found = 0, ptr = tree->next; ptr; ptr = ptr->next) { + switch (ptr->type) { + case CodeTreeBytecode: + case CodeTreeBlock: + case CodeTreeGo: + case CodeTreeReturn: + found = 1; + break; + case CodeTreeJump: + case CodeTreeCond: + case CodeTreeJumpIf: + if (ptr->code != XBC_NOOP) + found = 1; + break; + case CodeTreeLabel: + break; + } + if (found) + break; + } + if (found) + tree->offset = ptr->offset; + break; + } + } +} + +static void +LinkCalculateJump(LispCom *com, CodeTree *tree, LispByteOpcode code) +{ + long jumpto, offset, distance; + + tree->type = CodeTreeBytecode; + /* After the opcode */ + offset = tree->offset + 1; + jumpto = tree->data.tree->offset; + /* Effective distance */ + distance = jumpto - offset; + tree->code = code; + if (distance < -32768 || distance > 32767) { + COMPILE_FAILURE("jump too long"); + } + tree->data.signed_int = distance; +} + +static void +LinkFixupJumps(LispCom *com, CodeTree *tree) +{ + for (; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + case CodeTreeLabel: + break; + case CodeTreeCond: + if (tree->code == XBC_JUMPNIL) + /* Go to next test if NIL */ + LinkCalculateJump(com, tree, XBC_JUMPNIL); + else if (tree->code == XBC_JUMPT) + /* After executing T code */ + LinkCalculateJump(com, tree, XBC_JUMP); + break; + case CodeTreeJumpIf: + if (tree->code != XBC_NOOP) + LinkCalculateJump(com, tree, tree->code); + break; + case CodeTreeGo: + /* Inconditional jump */ + LinkCalculateJump(com, tree, XBC_JUMP); + break; + case CodeTreeReturn: + /* Inconditional jump */ + if (tree->data.tree != tree) + /* If need to skip something */ + LinkCalculateJump(com, tree, XBC_JUMP); + break; + case CodeTreeBlock: + LinkFixupJumps(com, tree->data.block->tree); + break; + case CodeTreeJump: + if (tree->code != XBC_NOOP) + LinkCalculateJump(com, tree, tree->code); + } + } +} + +static void +LinkBuildTableSymbol(LispCom *com, LispAtom *symbol) +{ + if (BuildTablePointer(symbol, (void***)&com->table.symbols, + &com->table.num_symbols) > 0xff) { + COMPILE_FAILURE("more than 256 symbols"); + } +} + +static void +LinkBuildTableConstant(LispCom *com, LispObj *constant) +{ + if (BuildTablePointer(constant, (void***)&com->table.constants, + &com->table.num_constants) > 0xff) { + COMPILE_FAILURE("more than 256 constants"); + } +} + +static void +LinkBuildTableBuiltin(LispCom *com, LispBuiltin *builtin) +{ + if (BuildTablePointer(builtin, (void***)&com->table.builtins, + &com->table.num_builtins) > 0xff) { + COMPILE_FAILURE("more than 256 functions"); + } +} + +static void +LinkBuildTableBytecode(LispCom *com, LispObj *bytecode) +{ + if (BuildTablePointer(bytecode, (void***)&com->table.bytecodes, + &com->table.num_bytecodes) > 0xff) { + COMPILE_FAILURE("more than 256 bytecode functions"); + } +} + +static void +LinkBuildTables(LispCom *com, CodeBlock *block) +{ + CodeTree *tree; + + for (tree = block->tree; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + switch (tree->code) { + case XBC_LET: + case XBC_LETX: + case XBC_LET_NIL: + case XBC_LETX_NIL: + case XBC_SETSYM: + case XBC_LOADSYM: + case XBC_LOADSYM_PUSH: + LinkBuildTableSymbol(com, tree->data.atom); + break; + case XBC_STRUCTP: + case XBC_LOADCON: + case XBC_LOADCON_PUSH: + LinkBuildTableConstant(com, tree->data.object); + break; + case XBC_LOADCON_SET: + LinkBuildTableConstant(com, tree->data.load_con_set.object); + break; + case XBC_CALL: + case XBC_CALL_SET: + LinkBuildTableBuiltin(com, tree->data.builtin.builtin); + break; + case XBC_BYTECALL: + LinkBuildTableBytecode(com, tree->data.bytecall.code); + break; + case XBC_LOAD_LET: + case XBC_LOAD_LETX: + LinkBuildTableSymbol(com, tree->data.let.name); + break; + case XBC_STRUCT: + LinkBuildTableConstant(com, tree->data.struc.definition); + break; + case XBC_LOADSYM_LET: + case XBC_LOADSYM_LETX: + LinkBuildTableSymbol(com, tree->data.let_sym.symbol); + LinkBuildTableSymbol(com, tree->data.let_sym.name); + break; + case XBC_LOADCON_LET: + case XBC_LOADCON_LETX: + LinkBuildTableConstant(com, tree->data.let_con.object); + LinkBuildTableSymbol(com, tree->data.let_con.name); + break; + case XBC_CCONS: + case XBC_FUNCALL: + LinkBuildTableConstant(com, tree->data.cons.car); + LinkBuildTableConstant(com, tree->data.cons.cdr); + break; + default: + break; + } + break; + case CodeTreeBlock: + LinkBuildTables(com, tree->data.block); + break; + default: + break; + } + } +} + +static long +LinkEmmitBytecode(LispCom *com, CodeTree *tree, + unsigned char *bytecode, long offset) +{ + short i; + + for (; tree; tree = tree->next) { + /* Fill padding */ + while (offset < tree->offset) + bytecode[offset++] = XBC_NOOP; + + switch (tree->type) { + case CodeTreeBytecode: + bytecode[offset++] = tree->code; + switch (tree->code) { + /* Noop should not enter the CodeTree */ + case XBC_NOOP: + INTERNAL_ERROR(__LINE__); + break; + + /* byte */ + case XBC_BCONS: + case XBC_BCONS1: + case XBC_BCONS2: + case XBC_BCONS3: + case XBC_BCONS4: + case XBC_BCONS5: + case XBC_BCONS6: + case XBC_BCONS7: + case XBC_INV: + case XBC_NIL: + case XBC_T: + case XBC_PUSH_NIL: + case XBC_PUSH_UNSPEC: + case XBC_PUSH_T: + case XBC_CAR_PUSH: + case XBC_CDR_PUSH: + case XBC_PUSH: + case XBC_LSTAR: + case XBC_LCONS: + case XBC_LFINI: + case XBC_RETURN: + case XBC_CSTAR: + case XBC_CFINI: + case XBC_CAR: + case XBC_CDR: + case XBC_RPLACA: + case XBC_RPLACD: + case XBC_EQ: + case XBC_EQL: + case XBC_EQUAL: + case XBC_EQUALP: + case XBC_LENGTH: + case XBC_LAST: + case XBC_NTHCDR: + break; + + /* byte + byte */ + case XBC_LETREC: + case XBC_PRED: + case XBC_PUSH_NIL_N: + case XBC_PUSH_UNSPEC_N: + bytecode[offset++] = tree->data.signed_char; + break; + + /* byte + byte */ + case XBC_CAR_SET: + case XBC_CDR_SET: + case XBC_SET: + case XBC_SET_NIL: + case XBC_LETBIND: + case XBC_UNLET: + case XBC_LOAD_PUSH: + case XBC_LOAD: + case XBC_LOAD_CAR: + case XBC_LOAD_CDR: + case XBC_LOAD_CAR_STORE: + case XBC_LOAD_CDR_STORE: + bytecode[offset++] = tree->data.signed_short; + break; + + /* byte + byte + byte */ + case XBC_LOAD_SET: + case XBC_LOAD_CAR_SET: + case XBC_LOAD_CDR_SET: + bytecode[offset++] = tree->data.load_set.load; + bytecode[offset++] = tree->data.load_set.set; + break; + + /* byte + short */ + case XBC_JUMP: + case XBC_JUMPT: + case XBC_JUMPNIL: + *(short*)(bytecode + offset) = tree->data.signed_int; + offset += sizeof(short); + break; + + /* byte + byte */ + case XBC_LET: + case XBC_LETX: + case XBC_LET_NIL: + case XBC_LETX_NIL: + case XBC_SETSYM: + case XBC_LOADSYM: + case XBC_LOADSYM_PUSH: + i = FindIndex(tree->data.atom, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + break; + + /* byte + byte */ + case XBC_STRUCTP: + case XBC_LOADCON: + case XBC_LOADCON_PUSH: + i = FindIndex(tree->data.object, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_LOADCON_SET: + i = FindIndex(tree->data.load_con_set.object, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + bytecode[offset++] = tree->data.load_con_set.offset; + break; + + /* byte + byte + byte */ + case XBC_CALL: + bytecode[offset++] = tree->data.builtin.num_arguments; + i = FindIndex(tree->data.builtin.builtin, + (void**)com->table.builtins, + com->table.num_builtins); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_BYTECALL: + bytecode[offset++] = tree->data.bytecall.num_arguments; + i = FindIndex(tree->data.bytecall.code, + (void**)com->table.bytecodes, + com->table.num_bytecodes); + bytecode[offset++] = i; + break; + + /* byte + byte + byte + byte */ + case XBC_CALL_SET: + bytecode[offset++] = tree->data.builtin.num_arguments; + i = FindIndex(tree->data.builtin.builtin, + (void**)com->table.builtins, + com->table.num_builtins); + bytecode[offset++] = i; + bytecode[offset++] = tree->data.builtin.offset; + break; + + /* byte + byte + byte */ + case XBC_LOAD_LET: + case XBC_LOAD_LETX: + bytecode[offset++] = tree->data.let.offset; + i = FindIndex(tree->data.let.name, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_STRUCT: + bytecode[offset++] = tree->data.struc.offset; + i = FindIndex(tree->data.struc.definition, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_LOADSYM_LET: + case XBC_LOADSYM_LETX: + i = FindIndex(tree->data.let_sym.symbol, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + i = FindIndex(tree->data.let_sym.name, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_LOADCON_LET: + case XBC_LOADCON_LETX: + i = FindIndex(tree->data.let_con.object, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + i = FindIndex(tree->data.let_con.name, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_CCONS: + case XBC_FUNCALL: + i = FindIndex(tree->data.cons.car, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + i = FindIndex(tree->data.cons.cdr, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + break; + } + break; + case CodeTreeLabel: + /* Labels are not loaded */ + break; + case CodeTreeCond: + case CodeTreeJump: + case CodeTreeJumpIf: + if (tree->code != XBC_NOOP) + INTERNAL_ERROR(__LINE__); + break; + case CodeTreeGo: + INTERNAL_ERROR(__LINE__); + break; + case CodeTreeReturn: + if (tree->data.tree != tree) + INTERNAL_ERROR(__LINE__); + break; + case CodeTreeBlock: + offset = LinkEmmitBytecode(com, tree->data.block->tree, + bytecode, offset); + break; + } + } + + return (offset); +} + +static void +LinkBytecode(LispCom *com) +{ + long offset, count; + unsigned char **codes; + LispObj **names; + + /* Close bytecode */ + com_Bytecode(com, XBC_RETURN); + + /* The only usage of this information for now, and still may generate + * false positives because arguments to unamed functions are not being + * parsed as well as arguments to yet undefined function/maros. + * XXX should also add declaim/declare to let the code specify that + * the argument is unused */ + LinkWarnUnused(com, com->block); + + /* First level optimization */ + LinkOptimize_0(com); + + /* Resolve tagbody labels */ + LinkResolveLabels(com, com->block); + + /* Resolve any pending jumps */ + LinkResolveJumps(com, com->block); + + /* Calculate unpadded offsets */ + LinkBuildOffsets(com, com->block->tree, 0); + + /* Do padding for aligned memory reads */ + LinkFixupOffsets(com, com->block->tree, 0); + + /* Jumps normally are to a node that does not generate code, + * and due to padding, the jump may go to a address with a + * XBC_NOOP, so adjust the jump to the next useful opcode. */ + LinkSkipPadding(com, com->block->tree); + + /* Now addresses are known */ + LinkFixupJumps(com, com->block->tree); + + /* Build symbol, constant and builtin tables */ + LinkBuildTables(com, com->block); + + /* Stack info */ + com->length = sizeof(short) * 3; + /* Tables info */ + com->length += sizeof(short) * 4; + com->length += com->table.num_constants * sizeof(LispObj*); + com->length += com->table.num_symbols * sizeof(LispAtom*); + com->length += com->table.num_builtins * sizeof(LispBuiltin*); + com->length += com->table.num_bytecodes * sizeof(unsigned char*); + com->length += com->table.num_bytecodes * sizeof(LispObj*); + + /* Allocate space for the bytecode stream */ + com->length += com->block->tail->offset + 1; + com->bytecode = LispMalloc(com->length); + + /* Add header */ + offset = 0; + *(short*)(com->bytecode + offset) = com->stack.stack; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->stack.bstack; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->stack.pstack; + offset += sizeof(short); + + *(short*)(com->bytecode + offset) = com->table.num_constants; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->table.num_symbols; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->table.num_builtins; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->table.num_bytecodes; + offset += sizeof(short); + + count = sizeof(LispObj*) * com->table.num_constants; + memcpy(com->bytecode + offset, com->table.constants, count); + offset += count; + count = sizeof(LispAtom*) * com->table.num_symbols; + memcpy(com->bytecode + offset, com->table.symbols, count); + offset += count; + count = sizeof(LispBuiltin*) * com->table.num_builtins; + memcpy(com->bytecode + offset, com->table.builtins, count); + offset += count; + + /* Store bytecode information */ + for (count = 0, codes = (unsigned char**)(com->bytecode + offset); + count < com->table.num_bytecodes; count++, codes++) + *codes = com->table.bytecodes[count]->data.bytecode.bytecode->code; + offset += com->table.num_bytecodes * sizeof(unsigned char*); + /* Store names, only useful for disassemble but may also be used + * to check if a function was redefined, and the bytecode is referencing + * the older version, the current version can be checked looking at + * <name>->data.atom */ + for (count = 0, names = (LispObj**)(com->bytecode + offset); + count < com->table.num_bytecodes; count++, names++) + *names = com->table.bytecodes[count]->data.bytecode.name; + offset += com->table.num_bytecodes * sizeof(LispObj*); + + /* Generate it */ + LinkEmmitBytecode(com, com->block->tree, com->bytecode + offset, 0); +} + +static LispObj * +ExecuteBytecode(register unsigned char *stream) +{ + register LispObj *reg0; + register LispAtom *atom; + register short offset; + LispObj *reg1; + LispBuiltin *builtin; + LispObj *lambda; + LispObj *arguments; + unsigned char *bytecode; + + LispObj **constants; + LispAtom **symbols; + LispBuiltin **builtins; + unsigned char **codes; + short num_constants, num_symbols, num_builtins, num_codes; + + int lex, len; + + /* To control gc protected slots */ + int phead, pbase; + + long fixnum = 0; + +#if defined(__GNUC__) && !defined(ANSI_SOURCE) +#define ALLOW_GOTO_ADDRESS +#endif + +#ifdef ALLOW_GOTO_ADDRESS +#define JUMP_ADDRESS(label) &&label + static const void *opcode_labels[] = { + JUMP_ADDRESS(XBC_NOOP), + JUMP_ADDRESS(XBC_INV), + JUMP_ADDRESS(XBC_NIL), + JUMP_ADDRESS(XBC_T), + JUMP_ADDRESS(XBC_PRED), + JUMP_ADDRESS(XBC_CAR), + JUMP_ADDRESS(XBC_CDR), + JUMP_ADDRESS(XBC_CAR_SET), + JUMP_ADDRESS(XBC_CDR_SET), + JUMP_ADDRESS(XBC_RPLACA), + JUMP_ADDRESS(XBC_RPLACD), + JUMP_ADDRESS(XBC_EQ), + JUMP_ADDRESS(XBC_EQL), + JUMP_ADDRESS(XBC_EQUAL), + JUMP_ADDRESS(XBC_EQUALP), + JUMP_ADDRESS(XBC_LENGTH), + JUMP_ADDRESS(XBC_LAST), + JUMP_ADDRESS(XBC_NTHCDR), + JUMP_ADDRESS(XBC_CAR_PUSH), + JUMP_ADDRESS(XBC_CDR_PUSH), + JUMP_ADDRESS(XBC_PUSH), + JUMP_ADDRESS(XBC_PUSH_NIL), + JUMP_ADDRESS(XBC_PUSH_UNSPEC), + JUMP_ADDRESS(XBC_PUSH_T), + JUMP_ADDRESS(XBC_PUSH_NIL_N), + JUMP_ADDRESS(XBC_PUSH_UNSPEC_N), + JUMP_ADDRESS(XBC_LET), + JUMP_ADDRESS(XBC_LETX), + JUMP_ADDRESS(XBC_LET_NIL), + JUMP_ADDRESS(XBC_LETX_NIL), + JUMP_ADDRESS(XBC_LETBIND), + JUMP_ADDRESS(XBC_UNLET), + JUMP_ADDRESS(XBC_LOAD), + JUMP_ADDRESS(XBC_LOAD_LET), + JUMP_ADDRESS(XBC_LOAD_LETX), + JUMP_ADDRESS(XBC_LOAD_PUSH), + JUMP_ADDRESS(XBC_LOADCON), + JUMP_ADDRESS(XBC_LOADCON_LET), + JUMP_ADDRESS(XBC_LOADCON_LETX), + JUMP_ADDRESS(XBC_LOADCON_PUSH), + JUMP_ADDRESS(XBC_LOAD_CAR), + JUMP_ADDRESS(XBC_LOAD_CDR), + JUMP_ADDRESS(XBC_LOAD_CAR_STORE), + JUMP_ADDRESS(XBC_LOAD_CDR_STORE), + JUMP_ADDRESS(XBC_LOADCON_SET), + JUMP_ADDRESS(XBC_LOADSYM), + JUMP_ADDRESS(XBC_LOADSYM_LET), + JUMP_ADDRESS(XBC_LOADSYM_LETX), + JUMP_ADDRESS(XBC_LOADSYM_PUSH), + JUMP_ADDRESS(XBC_LOAD_SET), + JUMP_ADDRESS(XBC_LOAD_CAR_SET), + JUMP_ADDRESS(XBC_LOAD_CDR_SET), + JUMP_ADDRESS(XBC_SET), + JUMP_ADDRESS(XBC_SETSYM), + JUMP_ADDRESS(XBC_SET_NIL), + JUMP_ADDRESS(XBC_CALL), + JUMP_ADDRESS(XBC_CALL_SET), + JUMP_ADDRESS(XBC_BYTECALL), + JUMP_ADDRESS(XBC_FUNCALL), + JUMP_ADDRESS(XBC_LETREC), + JUMP_ADDRESS(XBC_BCONS), + JUMP_ADDRESS(XBC_BCONS1), + JUMP_ADDRESS(XBC_BCONS2), + JUMP_ADDRESS(XBC_BCONS3), + JUMP_ADDRESS(XBC_BCONS4), + JUMP_ADDRESS(XBC_BCONS5), + JUMP_ADDRESS(XBC_BCONS6), + JUMP_ADDRESS(XBC_BCONS7), + JUMP_ADDRESS(XBC_CCONS), + JUMP_ADDRESS(XBC_CSTAR), + JUMP_ADDRESS(XBC_CFINI), + JUMP_ADDRESS(XBC_LSTAR), + JUMP_ADDRESS(XBC_LCONS), + JUMP_ADDRESS(XBC_LFINI), + JUMP_ADDRESS(XBC_JUMP), + JUMP_ADDRESS(XBC_JUMPT), + JUMP_ADDRESS(XBC_JUMPNIL), + JUMP_ADDRESS(XBC_STRUCT), + JUMP_ADDRESS(XBC_STRUCTP), + JUMP_ADDRESS(XBC_RETURN) + }; + static const void *predicate_opcode_labels[] = { + JUMP_ADDRESS(XBP_CONSP), + JUMP_ADDRESS(XBP_LISTP), + JUMP_ADDRESS(XBP_NUMBERP) + }; +#endif + + reg0 = NIL; + + bytecode = stream; + pbase = lisp__data.protect.length; + + /* stack */ + offset = *(short*)stream; + stream += sizeof(short); + if (lisp__data.env.length + offset > lisp__data.env.space) { + do + LispMoreEnvironment(); + while (lisp__data.env.length + offset >= lisp__data.env.space); + } + /* builtin stack */ + offset = *(short*)stream; + stream += sizeof(short); + if (lisp__data.stack.length + offset >= lisp__data.stack.space) { + do + LispMoreStack(); + while (lisp__data.stack.length + offset >= lisp__data.stack.space); + } + /* protect stack */ + phead = *(short*)stream; + stream += sizeof(short); + if (lisp__data.protect.length + phead > lisp__data.protect.space) { + do + LispMoreProtects(); + while (lisp__data.protect.length + phead >= lisp__data.protect.space); + } + + num_constants = *(short*)stream; + stream += sizeof(short); + num_symbols = *(short*)stream; + stream += sizeof(short); + num_builtins = *(short*)stream; + stream += sizeof(short); + num_codes = *(short*)stream; + stream += sizeof(short); + + constants = (LispObj**)stream; + stream += num_constants * sizeof(LispObj*); + symbols = (LispAtom**)stream; + stream += num_symbols * sizeof(LispAtom*); + builtins = (LispBuiltin**)stream; + stream += num_builtins * sizeof(LispBuiltin*); + codes = (unsigned char**)stream; + stream += num_codes * (sizeof(unsigned char*) + sizeof(LispObj*)); + + for (; phead > 0; phead--) + lisp__data.protect.objects[lisp__data.protect.length++] = NIL; + phead = pbase; + +#ifdef ALLOW_GOTO_ADDRESS +#define OPCODE_LABEL(label) label +#define NEXT_OPCODE() goto *opcode_labels[*stream++] +#define GOTO_PREDICATE() goto *predicate_opcode_labels[*stream++] +#else +#define OPCODE_LABEL(label) case label +#define NEXT_OPCODE() goto next_opcode +#define GOTO_PREDICATE() goto predicate_label + for (;;) { +next_opcode: + switch (*stream++) { +#endif /* ALLOW_GOTO_ADDRESS */ + +OPCODE_LABEL(XBC_NOOP): + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PRED): + GOTO_PREDICATE(); + +OPCODE_LABEL(XBC_INV): + reg0 = reg0 == NIL ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_NIL): + reg0 = NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_T): + reg0 = T; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_CAR): +car: + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CAR: %s is not a list", STROBJ(reg0)); + reg0 = CAR(reg0); + } + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_CDR): +cdr: + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CDR: %s is not a list", STROBJ(reg0)); + reg0 = CDR(reg0); + } + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_RPLACA): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + if (!CONSP(reg1)) + LispDestroy("RPLACA: %s is not a cons", STROBJ(reg1)); + RPLACA(reg1, reg0); + reg0 = reg1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_RPLACD): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + if (!CONSP(reg1)) + LispDestroy("RPLACD: %s is not a cons", STROBJ(reg1)); + RPLACD(reg1, reg0); + reg0 = reg1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS): + CAR(cons) = reg0; + lisp__data.stack.values[lisp__data.stack.length++] = cons; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS1): + offset = lisp__data.stack.length - 1; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[offset]; + lisp__data.stack.values[offset] = cons1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS2): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons2; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS3): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons3; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS4): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + CAR(cons4) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons4; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS5): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + CAR(cons4) = lisp__data.stack.values[--offset]; + CAR(cons5) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons5; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS6): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + CAR(cons4) = lisp__data.stack.values[--offset]; + CAR(cons5) = lisp__data.stack.values[--offset]; + CAR(cons6) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons6; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS7): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + CAR(cons4) = lisp__data.stack.values[--offset]; + CAR(cons5) = lisp__data.stack.values[--offset]; + CAR(cons6) = lisp__data.stack.values[--offset]; + CAR(cons7) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons7; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_EQ): + reg0 = reg0 == lisp__data.stack.values[--lisp__data.stack.length] ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_EQL): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + reg0 = XEQL(reg1, reg0); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_EQUAL): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + reg0 = XEQUAL(reg1, reg0); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_EQUALP): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + reg0 = XEQUALP(reg1, reg0); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LENGTH): + reg0 = FIXNUM(LispLength(reg0)); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LAST): + { + long length; + + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + if (CONSP(reg1)) { + if (reg0 != NIL) { + if (!FIXNUMP(reg0) || (fixnum = FIXNUM_VALUE(reg0)) < 0) + LispDestroy("LAST: %s is not a positive fixnum", + STROBJ(reg0)); + } + else + fixnum = 1; + reg0 = reg1; + for (reg0 = reg1, length = 0; + CONSP(reg0); + reg0 = CDR(reg0), length++) + ; + for (length -= fixnum, reg0 = reg1; length > 0; length--) + reg0 = CDR(reg0); + } + else + reg0 = reg1; + } NEXT_OPCODE(); + +OPCODE_LABEL(XBC_NTHCDR): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + if (!FIXNUMP(reg1) || (fixnum = FIXNUM_VALUE(reg1)) < 0) + LispDestroy("NTHCDR: %s is not a positive fixnum", + STROBJ(reg1)); + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("NTHCDR: %s is not a list", STROBJ(reg0)); + for (; fixnum > 0; fixnum--) { + if (!CONSP(reg0)) + break; + reg0 = CDR(reg0); + } + } + NEXT_OPCODE(); + + /* Push to builtin stack */ +OPCODE_LABEL(XBC_CAR_PUSH): + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CAR: %s is not a list", STROBJ(reg0)); + reg0 = CAR(reg0); + } + goto push_builtin; + +OPCODE_LABEL(XBC_CDR_PUSH): + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CDR: %s is not a list", STROBJ(reg0)); + reg0 = CDR(reg0); + } + /*FALLTROUGH*/ + +OPCODE_LABEL(XBC_PUSH): +push_builtin: + lisp__data.stack.values[lisp__data.stack.length++] = reg0; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_NIL): + lisp__data.stack.values[lisp__data.stack.length++] = NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_UNSPEC): + lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_T): + lisp__data.stack.values[lisp__data.stack.length++] = T; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_NIL_N): + for (offset = *stream++; offset > 0; offset--) + lisp__data.stack.values[lisp__data.stack.length++] = NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_UNSPEC_N): + for (offset = *stream++; offset > 0; offset--) + lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LET): +let_argument: + /* The global object value is not changed, so it does not + * matter if it is a constant symbol. An error would be + * generated if it was declared as constant at the time of + * bytecode generation. Check can be done looking at the + * atom->constant field. */ + atom = symbols[*stream++]; + atom->offset = lisp__data.env.length; + lisp__data.env.names[lisp__data.env.length] = atom->string; + lisp__data.env.values[lisp__data.env.length++] = reg0; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LETX): +letx_argument: + atom = symbols[*stream++]; + atom->offset = lisp__data.env.length; + lisp__data.env.names[lisp__data.env.length] = atom->string; + lisp__data.env.values[lisp__data.env.length++] = reg0; + lisp__data.env.head++; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LET_NIL): + atom = symbols[*stream++]; + atom->offset = lisp__data.env.length; + lisp__data.env.names[lisp__data.env.length] = atom->string; + lisp__data.env.values[lisp__data.env.length++] = NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LETX_NIL): + atom = symbols[*stream++]; + atom->offset = lisp__data.env.length; + lisp__data.env.names[lisp__data.env.length] = atom->string; + lisp__data.env.values[lisp__data.env.length++] = NIL; + lisp__data.env.head++; + NEXT_OPCODE(); + + /* Bind locally added variables to a block */ +OPCODE_LABEL(XBC_LETBIND): + offset = *stream++; + lisp__data.env.head += offset; + NEXT_OPCODE(); + + /* Unbind locally added variables to a block */ +OPCODE_LABEL(XBC_UNLET): + offset = *stream++; + lisp__data.env.head -= offset; + lisp__data.env.length -= offset; + NEXT_OPCODE(); + + /* Load value from stack */ +OPCODE_LABEL(XBC_LOAD): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOAD_CAR): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto car; + +OPCODE_LABEL(XBC_LOAD_CDR): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto cdr; + +OPCODE_LABEL(XBC_LOAD_CAR_STORE): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CAR: %s is not a list", STROBJ(reg0)); + reg0 = CAR(reg0); + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + } + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOAD_CDR_STORE): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CDR: %s is not a list", STROBJ(reg0)); + reg0 = CDR(reg0); + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + } + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOAD_LET): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto let_argument; + +OPCODE_LABEL(XBC_LOAD_LETX): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto letx_argument; + +OPCODE_LABEL(XBC_LOAD_PUSH): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + lisp__data.stack.values[lisp__data.stack.length++] = reg0; + NEXT_OPCODE(); + + /* Load pointer to constant */ +OPCODE_LABEL(XBC_LOADCON): + reg0 = constants[*stream++]; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOADCON_LET): + reg0 = constants[*stream++]; + goto let_argument; + +OPCODE_LABEL(XBC_LOADCON_LETX): + reg0 = constants[*stream++]; + goto letx_argument; + +OPCODE_LABEL(XBC_LOADCON_PUSH): + reg0 = constants[*stream++]; + lisp__data.stack.values[lisp__data.stack.length++] = reg0; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOADCON_SET): + reg0 = constants[*stream++]; + offset = *stream++; + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + NEXT_OPCODE(); + + /* Change value of local variable */ +OPCODE_LABEL(XBC_CAR_SET): +car_set: + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CAR: %s is not a list", STROBJ(reg0)); + reg0 = CAR(reg0); + } + goto set_local_variable; + +OPCODE_LABEL(XBC_CDR_SET): +cdr_set: + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CDR: %s is not a list", STROBJ(reg0)); + reg0 = CDR(reg0); + } + goto set_local_variable; + +OPCODE_LABEL(XBC_LOAD_CAR_SET): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto car_set; + +OPCODE_LABEL(XBC_LOAD_CDR_SET): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto cdr_set; + +OPCODE_LABEL(XBC_LOAD_SET): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + /*FALLTROUGH*/ + +OPCODE_LABEL(XBC_SET): +set_local_variable: + offset = *stream++; + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_SET_NIL): + offset = *stream++; + lisp__data.env.values[lisp__data.env.lex + offset] = NIL; + NEXT_OPCODE(); + + /* Change value of a global/special variable */ +OPCODE_LABEL(XBC_SETSYM): + atom = symbols[*stream++]; + if (atom->dyn) { + /* atom->dyn and atom->constant are exclusive, no + * need to check if variable declared as constant. */ + if (atom->offset < lisp__data.env.head && + lisp__data.env.names[atom->offset] == atom->string) + lisp__data.env.values[atom->offset] = reg0; + else { + if (atom->watch) + LispSetAtomObjectProperty(atom, reg0); + else + SETVALUE(atom, reg0); + } + } + else if (atom->a_object) { + if (atom->constant) + LispDestroy("EVAL: %s is a constant", + STROBJ(atom->object)); + else if (atom->watch) + LispSetAtomObjectProperty(atom, reg0); + else + SETVALUE(atom, reg0); + } + else { + /* Create new global variable */ + LispPackage *pack; + + LispWarning("the variable %s was not declared", + atom->string); + LispSetAtomObjectProperty(atom, reg0); + pack = atom->package->data.package.package; + if (pack->glb.length >= pack->glb.space) + LispMoreGlobals(pack); + pack->glb.pairs[pack->glb.length++] = atom->object; + } + NEXT_OPCODE(); + +/* Resolve symbol value at runtime */ +#define LOAD_SYMBOL_VALUE() \ + atom = symbols[*stream++]; \ + if (atom->dyn) { \ + if (atom->offset < lisp__data.env.head && \ + lisp__data.env.names[atom->offset] == atom->string) \ + reg0 = lisp__data.env.values[atom->offset]; \ + else { \ + reg0 = atom->property->value; \ + if (reg0 == UNBOUND) \ + LispDestroy("EVAL: the symbol %s is unbound", \ + STROBJ(atom->object)); \ + } \ + } \ + else { \ + if (atom->a_object) \ + reg0 = atom->property->value; \ + else \ + LispDestroy("EVAL: the symbol %s is unbound", \ + STROBJ(atom->object)); \ + } + +OPCODE_LABEL(XBC_LOADSYM): + LOAD_SYMBOL_VALUE(); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOADSYM_LET): + LOAD_SYMBOL_VALUE(); + goto let_argument; + +OPCODE_LABEL(XBC_LOADSYM_LETX): + LOAD_SYMBOL_VALUE(); + goto letx_argument; + +OPCODE_LABEL(XBC_LOADSYM_PUSH): + LOAD_SYMBOL_VALUE(); + lisp__data.stack.values[lisp__data.stack.length++] = reg0; + NEXT_OPCODE(); + + /* Builtin function */ +OPCODE_LABEL(XBC_CALL): + offset = *stream++; + lisp__data.stack.base = lisp__data.stack.length - offset; + builtin = builtins[*stream++]; + if (builtin->multiple_values) { + RETURN_COUNT = 0; + reg0 = builtin->function(builtin); + } + else { + reg0 = builtin->function(builtin); + RETURN_COUNT = 0; + } + lisp__data.stack.length -= offset; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_CALL_SET): + offset = *stream++; + lisp__data.stack.base = lisp__data.stack.length - offset; + builtin = builtins[*stream++]; + if (builtin->multiple_values) { + RETURN_COUNT = 0; + reg0 = builtin->function(builtin); + } + else { + reg0 = builtin->function(builtin); + RETURN_COUNT = 0; + } + lisp__data.stack.length -= offset; + offset = *stream++; + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + NEXT_OPCODE(); + + /* Bytecode call */ +OPCODE_LABEL(XBC_BYTECALL): + lex = lisp__data.env.lex; + offset = *stream++; + lisp__data.env.head = lisp__data.env.length; + len = lisp__data.env.lex = lisp__data.env.length - offset; + reg0 = ExecuteBytecode(codes[*stream++]); + lisp__data.env.length = lisp__data.env.head = len; + lisp__data.env.lex = lex; + NEXT_OPCODE(); + + /* Unimplemented function/macro call */ +OPCODE_LABEL(XBC_FUNCALL): + lambda = constants[*stream++]; + arguments = constants[*stream++]; + reg0 = LispFuncall(lambda, arguments, 1); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_JUMP): + stream += *(signed short*)stream; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_JUMPT): + if (reg0 != NIL) + stream += *(signed short*)stream; + else + /* skip jump relative offset */ + stream += sizeof(signed short); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_JUMPNIL): + if (reg0 == NIL) + stream += *(signed short*)stream; + else + /* skip jump relative offset */ + stream += sizeof(signed short); + NEXT_OPCODE(); + + /* Build CONS of two constant arguments */ +OPCODE_LABEL(XBC_CCONS): + reg0 = constants[*stream++]; + reg1 = constants[*stream++]; + reg0 = CONS(reg0, reg1); + NEXT_OPCODE(); + + /* Start CONS */ +OPCODE_LABEL(XBC_CSTAR): + /* This the CAR of the CONS */ + lisp__data.protect.objects[phead++] = reg0; + NEXT_OPCODE(); + + /* Finish CONS */ +OPCODE_LABEL(XBC_CFINI): + reg0 = CONS(lisp__data.protect.objects[--phead], reg0); + NEXT_OPCODE(); + + /* Start building list */ +OPCODE_LABEL(XBC_LSTAR): + reg1 = CONS(reg0, NIL); + /* Start of list stored here */ + lisp__data.protect.objects[phead++] = reg1; + /* Tail of list stored here */ + lisp__data.protect.objects[phead++] = reg1; + NEXT_OPCODE(); + + /* Add to list */ +OPCODE_LABEL(XBC_LCONS): + reg1 = lisp__data.protect.objects[phead - 2]; + RPLACD(reg1, CONS(reg0, NIL)); + lisp__data.protect.objects[phead - 2] = CDR(reg1); + NEXT_OPCODE(); + + /* Finish list */ +OPCODE_LABEL(XBC_LFINI): + phead -= 2; + reg0 = lisp__data.protect.objects[phead + 1]; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_STRUCT): + offset = *stream++; + reg1 = constants[*stream++]; + if (!STRUCTP(reg0) || reg0->data.struc.def != reg1) { + char *name = ATOMID(CAR(reg1)); + + for (reg1 = CDR(reg1); offset; offset--) + reg1 = CDR(reg1); + LispDestroy("%s-%s: %s is not a %s", + name, ATOMID(CAR(reg1)), STROBJ(reg0), name); + } + for (reg0 = reg0->data.struc.fields; offset; offset--) + reg0 = CDR(reg0); + reg0 = CAR(reg0); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_STRUCTP): + reg1 = constants[*stream++]; + reg0 = STRUCTP(reg0) && reg0->data.struc.def == reg1 ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LETREC): + /* XXX could/should optimize, shouldn't need to parse + * the bytecode header again */ + lex = lisp__data.env.lex; + offset = *stream++; + lisp__data.env.head = lisp__data.env.length; + len = lisp__data.env.lex = lisp__data.env.length - offset; + reg0 = ExecuteBytecode(bytecode); + lisp__data.env.length = lisp__data.env.head = len; + lisp__data.env.lex = lex; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_RETURN): + lisp__data.protect.length = pbase; + return (reg0); + +#ifndef ALLOW_GOTO_ADDRESS + } /* end of switch */ + +predicate_label: + switch (*stream++) { +#endif + +OPCODE_LABEL(XBP_CONSP): + reg0 = CONSP(reg0) ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBP_LISTP): + reg0 = LISTP(reg0) ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBP_NUMBERP): + reg0 = NUMBERP(reg0) ? T : NIL; + NEXT_OPCODE(); + +#ifndef ALLOW_GOTO_ADDRESS + } /* end of switch */ + } +#endif + + /*NOTREACHED*/ + return (reg0); +} diff --git a/lisp/bytecode.h b/lisp/bytecode.h new file mode 100644 index 0000000..40d8444 --- /dev/null +++ b/lisp/bytecode.h @@ -0,0 +1,268 @@ +/* + * Copyright (c) 2002 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/bytecode.h,v 1.5 2002/11/23 08:26:48 paulo Exp $ */ + +#include "private.h" + +#ifndef Lisp_Bytecode_h +#define Lisp_Bytecode_h + +/* Number of arguments for &REST functions with no side effects, + * i.e. does not need to allocate new cells to build argument list. + * If this value is changed, it is also required to add more + * XBC_BCONS? opcodes and change ExecuteBytecode() */ +#define MAX_BCONS 8 + +typedef enum { + XBP_CONSP, + XBP_LISTP, + XBP_NUMBERP +} LispBytePredicate; + +typedef enum { + XBC_NOOP, + + XBC_INV, /* If NIL loaded, change to T else to NIL */ + XBC_NIL, /* Load NIL */ + XBC_T, /* Load T */ + + XBC_PRED, /* Preffix for predicate test */ + /* Followed by byte indicating test */ + + XBC_CAR, /* Set loaded value to it's car */ + XBC_CDR, /* Set loaded value to it's cdr */ + + XBC_CAR_SET, /* Set local variable to CAR or CDR of loaded value */ + XBC_CDR_SET, + /* Offset of local variable follows */ + + /* Sets C[AD]R of top of builtin stack with + * loaded value and pop builtin stack */ + XBC_RPLACA, + XBC_RPLACD, + + /* Push only one argument in builtin stack, and call directly + * LispObjectCompare without the need of pushing the second arguument */ + XBC_EQ, + XBC_EQL, + XBC_EQUAL, + XBC_EQUALP, + + XBC_LENGTH, + XBC_LAST, + XBC_NTHCDR, + + XBC_CAR_PUSH, /* Pushes CAR or CDR of loaded value to builtin stack */ + XBC_CDR_PUSH, + + XBC_PUSH, /* Push argument in builtin stack */ + XBC_PUSH_NIL, /* Pushes NIL in builtin stack */ + XBC_PUSH_UNSPEC, /* Pushes #<UNSPEC> in builtin stack */ + XBC_PUSH_T, /* Pushes T in builtin stack */ + XBC_PUSH_NIL_N, /* Pushes NIL in the builtin stack N times */ + XBC_PUSH_UNSPEC_N, /* Pushes #<UNSPEC> in the builtin stack N times */ + + + /* The builtin stack base is saved when entering the bytecode + * interpreter, and the bytecode does not reenter from builtin + * functions, yet, so there is no need, for XBC_BSAVE and + * XBC_BREST instructions */ + + XBC_LET, /* Push loaded value to stack */ + XBC_LETX, /* Push loaded value to stack and bind */ + /* Next byte(s) are the symbol offset */ + XBC_LET_NIL, /* Push loaded value to stack */ + XBC_LETX_NIL, /* Push loaded value to stack and bind */ + /* Next byte(s) are the symbol offset */ + + XBC_LETBIND, /* Bind locally added variables */ + /* Followed by number of symbols to bind */ + + XBC_UNLET, /* Unbind locally binded variables */ + /* Followed by number of symbols to unbind */ + + XBC_LOAD, /* Load argument already from the stack */ + /* Followed by offset follows the opcode */ + XBC_LOAD_LET, /* Load argument and push */ + XBC_LOAD_LETX, /* Load argument, push and bind */ + /* Followed by a short and the atom to be bound */ + XBC_LOAD_PUSH, + + XBC_LOADCON, /* Load a literal constant */ + /* Next bytes are the constant object */ + XBC_LOADCON_LET, /* Load a literal constant and push */ + XBC_LOADCON_LETX, /* Load a literal constant, push and bind */ + /* Followed by object constant and symbol to be bound */ + XBC_LOADCON_PUSH, + + /* Load CAR or CDR of local variable */ + XBC_LOAD_CAR, + XBC_LOAD_CDR, + + /* Change local variable value to it's CAR or CDR */ + XBC_LOAD_CAR_STORE, + XBC_LOAD_CDR_STORE, + + XBC_LOADCON_SET, + /* Followed by constant offset and local variable offset */ + + XBC_LOADSYM, /* Load object symbol value */ + /* The object atom pointer follows de opcode */ + XBC_LOADSYM_LET, /* Load object symbol value and push */ + XBC_LOADSYM_LETX, /* Load object symbol value, push and bind */ + /* The symbol atom name and bounded atom name to be bound follows */ + XBC_LOADSYM_PUSH, + + XBC_LOAD_SET, /* Set value of local variable to the value of another */ + /* Followed by two shorts */ + XBC_LOAD_CAR_SET, /* Like LOAD_SET, but apply CAR or CDR in the value */ + XBC_LOAD_CDR_SET, + + XBC_SET, /* Change value of local variable */ + /* A short integer with relative offset follows opcode */ + XBC_SETSYM, /* Change value of symbol */ + /* The atom symbol pointer follows opcode */ + + XBC_SET_NIL, /* Like XBC_SET but sets the local variable to NIL */ + + XBC_CALL, /* Call builtin function */ + /* 1 byte follows telling how many arguments to use */ + /* LispBuiltin pointer follows opcode */ + + XBC_CALL_SET, + /* Like BCALL, but also followed by an short index of local variable */ + + XBC_BYTECALL, /* Call bytecode */ + /* 1 byte for number of arguments */ + /* 1 byte for index in bytecode table */ + + XBC_FUNCALL, + /* Opcode followed by function and arguments objects, to + * be evaluated at run time, as it was not resolved at + * bytecode generation time (or is not implemented in + * the bytecode compiler) */ + + + XBC_LETREC, /* Recursive function call */ + /* 1 byte follows telling how many arguments the funtion receives */ + + /* Helper for math functions. Uses a preallocated CONS, + * setting it's CAR to the loaded value, and in the same step + * pushes the CONS to the builtin stack */ + XBC_BCONS, + /* Like BCONS but it is a list of 2 arguments, first argument + * is saved on the stack, replace with list of 2 arguments */ + XBC_BCONS1, + /* Like BCONS1 but it is a list of 3 arguments, first arguments + * are saved on the stack, replace with list of first stack + * argument with list or 3 arguments, and pop stack */ + XBC_BCONS2, + XBC_BCONS3, + XBC_BCONS4, + XBC_BCONS5, + XBC_BCONS6, + XBC_BCONS7, + + /* Build a CONS */ + XBC_CCONS, /* Make CONS of two constants */ + /* Constants follow opcode */ + XBC_CSTAR, /* Save the CAR of the CONS */ + XBC_CFINI, /* Loaded value is the CDR */ + + /* These are to help in interactively building lists */ + XBC_LSTAR, /* Start building a list in the gc protected stack */ + XBC_LCONS, /* Add loaded object to list */ + XBC_LFINI, /* List is finished */ + + /* Inconditional jumps */ + XBC_JUMP, /* Jump relative to following signed int */ + + /* Conditional jumps, if true */ + XBC_JUMPT, /* Jump relative to following signed int */ + + /* Conditional jumps, if false */ + XBC_JUMPNIL, /* Jump relative to following signed int */ + + /* Structure field access and type check */ + XBC_STRUCT, + XBC_STRUCTP, + + XBC_RETURN /* Resume bytecode execution */ +} LispByteOpcode; + + +struct _LispBytecode { + unsigned char *code; /* Bytecode data */ + long length; /* length of bytecode stream */ +}; + +/* + * Prototypes + */ +void LispBytecodeInit(void); + +LispObj *Lisp_Compile(LispBuiltin*); +LispObj *Lisp_Disassemble(LispBuiltin*); + +LispObj *LispCompileForm(LispObj*); +LispObj *LispExecuteBytecode(LispObj*); + +void Com_And(LispCom*, LispBuiltin*); +void Com_Block(LispCom*, LispBuiltin*); +void Com_C_r(LispCom*, LispBuiltin*); +void Com_Cond(LispCom*, LispBuiltin*); +void Com_Cons(LispCom*, LispBuiltin*); +void Com_Consp(LispCom*, LispBuiltin*); +void Com_Dolist(LispCom*, LispBuiltin*); +void Com_Eq(LispCom*, LispBuiltin*); +void Com_Go(LispCom*, LispBuiltin*); +void Com_If(LispCom*, LispBuiltin*); +void Com_Last(LispCom*, LispBuiltin*); +void Com_Length(LispCom*, LispBuiltin*); +void Com_Let(LispCom*, LispBuiltin*); +void Com_Letx(LispCom*, LispBuiltin*); +void Com_Listp(LispCom*, LispBuiltin*); +void Com_Loop(LispCom*, LispBuiltin*); +void Com_Nthcdr(LispCom*, LispBuiltin*); +void Com_Null(LispCom*, LispBuiltin*); +void Com_Numberp(LispCom*, LispBuiltin*); +void Com_Or(LispCom*, LispBuiltin*); +void Com_Progn(LispCom*, LispBuiltin*); +void Com_Return(LispCom*, LispBuiltin*); +void Com_ReturnFrom(LispCom*, LispBuiltin*); +void Com_Rplac_(LispCom*, LispBuiltin*); +void Com_Setq(LispCom*, LispBuiltin*); +void Com_Tagbody(LispCom*, LispBuiltin*); +void Com_Unless(LispCom*, LispBuiltin*); +void Com_Until(LispCom*, LispBuiltin*); +void Com_When(LispCom*, LispBuiltin*); +void Com_While(LispCom*, LispBuiltin*); + +#endif /* Lisp_Bytecode_h */ diff --git a/lisp/compile.c b/lisp/compile.c new file mode 100644 index 0000000..f699f39 --- /dev/null +++ b/lisp/compile.c @@ -0,0 +1,2225 @@ +/* + * Copyright (c) 2002 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/compile.c,v 1.14 2003/01/30 02:46:25 paulo Exp $ */ + +#define VARIABLE_USED 0x0001 +#define VARIABLE_ARGUMENT 0x0002 + +/* + * Prototypes + */ +static void ComPredicate(LispCom*, LispBuiltin*, LispBytePredicate); +static void ComReturnFrom(LispCom*, LispBuiltin*, int); + +static int ComConstantp(LispCom*, LispObj*); +static void ComAddVariable(LispCom*, LispObj*, LispObj*); +static int ComGetVariable(LispCom*, LispObj*); +static void ComVariableSetFlag(LispCom*, LispAtom*, int); +#define COM_VARIABLE_USED(atom) \ + ComVariableSetFlag(com, atom, VARIABLE_USED) +#define COM_VARIABLE_ARGUMENT(atom) \ + ComVariableSetFlag(com, atom, VARIABLE_ARGUMENT) + +static int FindIndex(void*, void**, int); +static int compare(const void*, const void*); +static int BuildTablePointer(void*, void***, int*); + +static void ComLabel(LispCom*, LispObj*); +static void ComPush(LispCom*, LispObj*, LispObj*, int, int, int); +static int ComCall(LispCom*, LispArgList*, LispObj*, LispObj*, int, int, int); +static void ComFuncall(LispCom*, LispObj*, LispObj*, int); +static void ComProgn(LispCom*, LispObj*); +static void ComEval(LispCom*, LispObj*); + +static void ComRecursiveCall(LispCom*, LispArgList*, LispObj*, LispObj*); +static void ComInlineCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*); + +static void ComMacroBackquote(LispCom*, LispObj*); +static void ComMacroCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*); +static LispObj *ComMacroExpandBackquote(LispCom*, LispObj*); +static LispObj *ComMacroExpand(LispCom*, LispObj*); +static LispObj *ComMacroExpandFuncall(LispCom*, LispObj*, LispObj*); +static LispObj *ComMacroExpandEval(LispCom*, LispObj*); + +/* + * Implementation + */ +void +Com_And(LispCom *com, LispBuiltin *builtin) +/* + and &rest args + */ +{ + LispObj *args; + + args = ARGUMENT(0); + + if (CONSP(args)) { + /* Evaluate first argument */ + ComEval(com, CAR(args)); + args = CDR(args); + + /* If more than one argument, create jump list */ + if (CONSP(args)) { + CodeTree *tree = NULL, *group; + + group = NEW_TREE(CodeTreeJumpIf); + group->code = XBC_JUMPNIL; + + for (; CONSP(args); args = CDR(args)) { + ComEval(com, CAR(args)); + tree = NEW_TREE(CodeTreeJumpIf); + tree->code = XBC_JUMPNIL; + group->group = tree; + group = tree; + } + /* Finish form the last CodeTree code is changed to sign the + * end of the AND list */ + group->code = XBC_NOOP; + if (group) + group->group = tree; + } + } + else + /* Identity of AND is T */ + com_Bytecode(com, XBC_T); +} + +void +Com_Block(LispCom *com, LispBuiltin *builtin) +/* + block name &rest body + */ +{ + + LispObj *name, *body; + + body = ARGUMENT(1); + name = ARGUMENT(0); + + if (name != NIL && name != T && !SYMBOLP(name)) + LispDestroy("%s: %s cannot name a block", + STRFUN(builtin), STROBJ(name)); + if (CONSP(body)) { + CompileIniBlock(com, LispBlockTag, name); + ComProgn(com, body); + CompileFiniBlock(com); + } + else + /* Just load NIL without starting an empty block */ + com_Bytecode(com, XBC_NIL); +} + +void +Com_C_r(LispCom *com, LispBuiltin *builtin) +/* + c[ad]{1,4}r list + */ +{ + LispObj *list; + char *desc; + + list = ARGUMENT(0); + + desc = STRFUN(builtin); + if (*desc == 'F') /* FIRST */ + desc = "CAR"; + else if (*desc == 'R') /* REST */ + desc = "CDR"; + + /* Check if it is a list of constants */ + while (desc[1] != 'R') + desc++; + ComEval(com, list); + while (*desc != 'C') { + com_Bytecode(com, *desc == 'A' ? XBC_CAR : XBC_CDR); + --desc; + } +} + +void +Com_Cond(LispCom *com, LispBuiltin *builtin) +/* + cond &rest body + */ +{ + int count; + LispObj *code, *body; + CodeTree *group, *tree; + + body = ARGUMENT(0); + + count = 0; + group = NULL; + if (CONSP(body)) { + for (; CONSP(body); body = CDR(body)) { + code = CAR(body); + CHECK_CONS(code); + ++count; + ComEval(com, CAR(code)); + tree = NEW_TREE(CodeTreeCond); + if (group) + group->group = tree; + tree->code = XBC_JUMPNIL; + group = tree; + /* The code to execute if the test is true */ + ComProgn(com, CDR(code)); + /* Add a node signaling the end of the PROGN code */ + tree = NEW_TREE(CodeTreeCond); + tree->code = XBC_JUMPT; + if (group) + group->group = tree; + group = tree; + } + } + if (!count) + com_Bytecode(com, XBC_NIL); + else + /* Where to jump after T progn */ + group->code = XBC_NOOP; +} + +void +Com_Cons(LispCom *com, LispBuiltin *builtin) +/* + cons car cdr + */ +{ + LispObj *car, *cdr; + + cdr = ARGUMENT(1); + car = ARGUMENT(0); + + if (ComConstantp(com, car) && ComConstantp(com, cdr)) + com_BytecodeCons(com, XBC_CCONS, car, cdr); + else { + ++com->stack.cpstack; + if (com->stack.pstack < com->stack.cpstack) + com->stack.pstack = com->stack.cpstack; + ComEval(com, car); + com_Bytecode(com, XBC_CSTAR); + ComEval(com, cdr); + com_Bytecode(com, XBC_CFINI); + --com->stack.cpstack; + } +} + +void +Com_Consp(LispCom *com, LispBuiltin *builtin) +/* + consp object + */ +{ + ComPredicate(com, builtin, XBP_CONSP); +} + +void +Com_Dolist(LispCom *com, LispBuiltin *builtin) +/* + dolist init &rest body + */ +{ + int unbound, item; + LispObj *symbol, *list, *result; + LispObj *init, *body; + CodeTree *group, *tree; + + body = ARGUMENT(1); + init = ARGUMENT(0); + + CHECK_CONS(init); + symbol = CAR(init); + CHECK_SYMBOL(symbol); + CHECK_CONSTANT(symbol); + init = CDR(init); + if (CONSP(init)) { + list = CAR(init); + init = CDR(init); + } + else + list = NIL; + if (CONSP(init)) { + result = CAR(init); + if (CONSP(CDR(init))) + LispDestroy("%s: too many arguments %s", + STRFUN(builtin), STROBJ(CDR(init))); + } + else + result = NIL; + + /* Generate code for the body of the form. + * The generated code uses two objects unavailable to user code, + * in the format: + * (block NIL + * (let ((? list) (item NIL)) + * (tagbody + * . ; the DOT object as a label + * (when (consp list) + * (setq item (car ?)) + * @body ; code to be executed + * (setq ? (cdr ?)) + * (go .) + * ) + * ) + * (setq item nil) + * result + * ) + * ) + */ + + /* XXX All of the logic below should be simplified at some time + * by adding more opcodes for compound operations ... */ + + /* Relative offsets the locally added variables will have at run time */ + unbound = lisp__data.env.length - lisp__data.env.lex; + item = unbound + 1; + + /* Start BLOCK NIL */ + FORM_ENTER(); + CompileIniBlock(com, LispBlockTag, NIL); + + /* Add the <?> variable */ + ComPush(com, UNBOUND, list, 1, 0, 0); + /* Add the <item> variable */ + ComPush(com, symbol, NIL, 0, 0, 0); + /* Stack length is increased */ + CompileStackEnter(com, 2, 0); + /* Bind variables */ + com_Bind(com, 2); + com->block->bind += 2; + lisp__data.env.head += 2; + + /* Remember that iteration variable is used even if it not referenced */ + COM_VARIABLE_USED(symbol->data.atom); + + /* Initialize the TAGBODY */ + FORM_ENTER(); + CompileIniBlock(com, LispBlockBody, NIL); + + /* Create the <.> label */ + ComLabel(com, DOT); + + /* Load <?> variable */ + com_BytecodeShort(com, XBC_LOAD, unbound); + /* Check if <?> is a list */ + com_BytecodeChar(com, XBC_PRED, XBP_CONSP); + + /* Start WHEN block */ + group = NEW_TREE(CodeTreeJumpIf); + group->code = XBC_JUMPNIL; + /* Load <?> again */ + com_BytecodeShort(com, XBC_LOAD, unbound); + /* Get CAR of <?> */ + com_Bytecode(com, XBC_CAR); + /* Store it in <item> */ + com_BytecodeShort(com, XBC_SET, item); + /* Execute @BODY */ + ComProgn(com, body); + + /* Load <?> again */ + com_BytecodeShort(com, XBC_LOAD, unbound); + /* Get CDR of <?> */ + com_Bytecode(com, XBC_CDR); + /* Change value of <?> */ + com_BytecodeShort(com, XBC_SET, unbound); + + /* GO back to <.> */ + tree = NEW_TREE(CodeTreeGo); + tree->data.object = DOT; + + /* Finish WHEN block */ + tree = NEW_TREE(CodeTreeJumpIf); + tree->code = XBC_NOOP; + group->group = tree; + + /* Finish the TAGBODY */ + CompileFiniBlock(com); + FORM_LEAVE(); + + /* Set <item> to NIL, in case result references it... + * Loaded value is NIL as the CONSP predicate */ + com_BytecodeShort(com, XBC_SET, item); + + /* Evaluate <result> */ + ComEval(com, result); + + /* Unbind variables */ + lisp__data.env.head -= 2; + lisp__data.env.length -= 2; + com->block->bind -= 2; + com_Unbind(com, 2); + /* Stack length is reduced. */ + CompileStackLeave(com, 2, 0); + + /* Finish BLOCK NIL */ + CompileFiniBlock(com); + FORM_LEAVE(); +} + +void +Com_Eq(LispCom *com, LispBuiltin *builtin) +/* + eq left right + eql left right + equal left right + equalp left right + */ +{ + LispObj *left, *right; + LispByteOpcode code; + char *name; + + right = ARGUMENT(1); + left = ARGUMENT(0); + + CompileStackEnter(com, 1, 1); + /* Just like preparing to call a builtin function */ + ComEval(com, left); + com_Bytecode(com, XBC_PUSH); + /* The second argument is now loaded */ + ComEval(com, right); + + /* Compare arguments and restore builtin stack */ + name = STRFUN(builtin); + switch (name[3]) { + case 'L': + code = XBC_EQL; + break; + case 'U': + code = name[5] == 'P' ? XBC_EQUALP : XBC_EQUAL; + break; + default: + code = XBC_EQ; + break; + } + com_Bytecode(com, code); + + CompileStackLeave(com, 1, 1); +} + +void +Com_Go(LispCom *com, LispBuiltin *builtin) +/* + go tag + */ +{ + int bind; + LispObj *tag; + CodeTree *tree; + CodeBlock *block; + + tag = ARGUMENT(0); + + block = com->block; + bind = block->bind; + + while (block) { + if (block->type == LispBlockClosure || block->type == LispBlockBody) + break; + block = block->prev; + if (block) + bind += block->bind; + } + + if (!block || block->type != LispBlockBody) + LispDestroy("%s called not within a block", STRFUN(builtin)); + + /* Unbind any local variables */ + com_Unbind(com, bind); + tree = NEW_TREE(CodeTreeGo); + tree->data.object = tag; +} + +void +Com_If(LispCom *com, LispBuiltin *builtin) +/* + if test then &optional else + */ +{ + CodeTree *group, *tree; + LispObj *test, *then, *oelse; + + oelse = ARGUMENT(2); + then = ARGUMENT(1); + test = ARGUMENT(0); + + /* Build code to execute test */ + ComEval(com, test); + + /* Add jump node to use if test is NIL */ + group = NEW_TREE(CodeTreeJumpIf); + group->code = XBC_JUMPNIL; + + /* Build T code */ + ComEval(com, then); + + if (oelse != UNSPEC) { + /* Remember start of NIL code */ + tree = NEW_TREE(CodeTreeJump); + tree->code = XBC_JUMP; + group->group = tree; + group = tree; + /* Build NIL code */ + ComEval(com, oelse); + } + + /* Remember jump of T code */ + tree = NEW_TREE(CodeTreeJumpIf); + tree->code = XBC_NOOP; + group->group = tree; +} + +void +Com_Last(LispCom *com, LispBuiltin *builtin) +/* + last list &optional count + */ +{ + LispObj *list, *count; + + count = ARGUMENT(1); + list = ARGUMENT(0); + + ComEval(com, list); + CompileStackEnter(com, 1, 1); + com_Bytecode(com, XBC_PUSH); + if (count == UNSPEC) + count = FIXNUM(1); + ComEval(com, count); + CompileStackLeave(com, 1, 1); + com_Bytecode(com, XBC_LAST); +} + +void +Com_Length(LispCom *com, LispBuiltin *builtin) +/* + length sequence + */ +{ + LispObj *sequence; + + sequence = ARGUMENT(0); + + ComEval(com, sequence); + com_Bytecode(com, XBC_LENGTH); +} + +void +Com_Let(LispCom *com, LispBuiltin *builtin) +/* + let init &rest body + */ +{ + int count; + LispObj *symbol, *value, *pair; + + LispObj *init, *body; + + body = ARGUMENT(1); + init = ARGUMENT(0); + + if (init == NIL) { + /* If no local variables */ + ComProgn(com, body); + return; + } + CHECK_CONS(init); + + /* Could optimize if the body is empty and the + * init form is known to have no side effects */ + + for (count = 0; CONSP(init); init = CDR(init), count++) { + pair = CAR(init); + if (CONSP(pair)) { + symbol = CAR(pair); + pair = CDR(pair); + if (CONSP(pair)) { + value = CAR(pair); + if (CDR(pair) != NIL) + LispDestroy("%s: too much arguments to initialize %s", + STRFUN(builtin), STROBJ(symbol)); + } + else + value = NIL; + } + else { + symbol = pair; + value = NIL; + } + CHECK_SYMBOL(symbol); + CHECK_CONSTANT(symbol); + + /* Add the variable */ + ComPush(com, symbol, value, 1, 0, 0); + } + + /* Stack length is increased */ + CompileStackEnter(com, count, 0); + /* Bind the added variables */ + com_Bind(com, count); + com->block->bind += count; + lisp__data.env.head += count; + /* Generate code for the body of the form */ + ComProgn(com, body); + /* Unbind the added variables */ + lisp__data.env.head -= count; + lisp__data.env.length -= count; + com->block->bind -= count; + com_Unbind(com, count); + /* Stack length is reduced. */ + CompileStackLeave(com, count, 0); +} + +void +Com_Letx(LispCom *com, LispBuiltin *builtin) +/* + let* init &rest body + */ +{ + int count; + LispObj *symbol, *value, *pair; + + LispObj *init, *body; + + body = ARGUMENT(1); + init = ARGUMENT(0); + + if (init == NIL) { + /* If no local variables */ + ComProgn(com, body); + return; + } + CHECK_CONS(body); + + /* Could optimize if the body is empty and the + * init form is known to have no side effects */ + + for (count = 0; CONSP(init); init = CDR(init), count++) { + pair = CAR(init); + if (CONSP(pair)) { + symbol = CAR(pair); + pair = CDR(pair); + if (CONSP(pair)) { + value = CAR(pair); + if (CDR(pair) != NIL) + LispDestroy("%s: too much arguments to initialize %s", + STRFUN(builtin), STROBJ(symbol)); + } + else + value = NIL; + } + else { + symbol = pair; + value = NIL; + } + CHECK_SYMBOL(symbol); + CHECK_CONSTANT(symbol); + + /* LET* is identical to &AUX arguments, just bind the symbol */ + ComPush(com, symbol, value, 1, 0, 0); + /* Every added variable is binded */ + com_Bind(com, 1); + /* Must be binded at compile time also */ + ++lisp__data.env.head; + ++com->block->bind; + } + + /* Generate code for the body of the form */ + CompileStackEnter(com, count, 0); + ComProgn(com, body); + com_Unbind(com, count); + com->block->bind -= count; + lisp__data.env.head -= count; + lisp__data.env.length -= count; + CompileStackLeave(com, count, 0); +} + +void +Com_Listp(LispCom *com, LispBuiltin *builtin) +/* + listp object + */ +{ + ComPredicate(com, builtin, XBP_LISTP); +} + +void +Com_Loop(LispCom *com, LispBuiltin *builtin) +/* + loop &rest body + */ +{ + CodeTree *tree, *group; + LispObj *body; + + body = ARGUMENT(0); + + /* Start NIL block */ + CompileIniBlock(com, LispBlockTag, NIL); + + /* Insert node to mark LOOP start */ + tree = NEW_TREE(CodeTreeJump); + tree->code = XBC_NOOP; + + /* Execute @BODY */ + if (CONSP(body)) + ComProgn(com, body); + else + /* XXX bytecode.c code require that blocks have at least one opcode */ + com_Bytecode(com, XBC_NIL); + + /* Insert node to jump of start of LOOP */ + group = NEW_TREE(CodeTreeJump); + group->code = XBC_JUMP; + group->group = tree; + + /* Finish NIL block */ + CompileFiniBlock(com); +} + +void +Com_Nthcdr(LispCom *com, LispBuiltin *builtin) +/* + nthcdr index list + */ +{ + LispObj *oindex, *list; + + list = ARGUMENT(1); + oindex = ARGUMENT(0); + + ComEval(com, oindex); + CompileStackEnter(com, 1, 1); + com_Bytecode(com, XBC_PUSH); + ComEval(com, list); + CompileStackLeave(com, 1, 1); + com_Bytecode(com, XBC_NTHCDR); +} + +void +Com_Null(LispCom *com, LispBuiltin *builtin) +/* + null list + */ +{ + LispObj *list; + + list = ARGUMENT(0); + + if (list == NIL) + com_Bytecode(com, XBC_T); + else if (ComConstantp(com, list)) + com_Bytecode(com, XBC_NIL); + else { + ComEval(com, list); + com_Bytecode(com, XBC_INV); + } +} + +void +Com_Numberp(LispCom *com, LispBuiltin *builtin) +/* + numberp object + */ +{ + ComPredicate(com, builtin, XBP_NUMBERP); +} + +void +Com_Or(LispCom *com, LispBuiltin *builtin) +/* + or &rest args + */ +{ + LispObj *args; + + args = ARGUMENT(0); + + if (CONSP(args)) { + /* Evaluate first argument */ + ComEval(com, CAR(args)); + args = CDR(args); + + /* If more than one argument, create jump list */ + if (CONSP(args)) { + CodeTree *tree = NULL, *group; + + group = NEW_TREE(CodeTreeJumpIf); + group->code = XBC_JUMPT; + + for (; CONSP(args); args = CDR(args)) { + ComEval(com, CAR(args)); + tree = NEW_TREE(CodeTreeJumpIf); + tree->code = XBC_JUMPT; + group->group = tree; + group = tree; + } + /* Finish form the last CodeTree code is changed to sign the + * end of the AND list */ + group->code = XBC_NOOP; + group->group = tree; + } + } + else + /* Identity of OR is NIL */ + com_Bytecode(com, XBC_NIL); +} + +void +Com_Progn(LispCom *com, LispBuiltin *builtin) +/* + progn &rest body + */ +{ + LispObj *body; + + body = ARGUMENT(0); + + ComProgn(com, body); +} + +void +Com_Return(LispCom *com, LispBuiltin *builtin) +/* + return &optional result + */ +{ + ComReturnFrom(com, builtin, 0); +} + +void +Com_ReturnFrom(LispCom *com, LispBuiltin *builtin) +/* + return-from name &optional result + */ +{ + ComReturnFrom(com, builtin, 1); +} + +void +Com_Rplac_(LispCom *com, LispBuiltin *builtin) +/* + rplac[ad] place value + */ +{ + LispObj *place, *value; + + value = ARGUMENT(1); + place = ARGUMENT(0); + + CompileStackEnter(com, 1, 1); + ComEval(com, place); + com_Bytecode(com, XBC_PUSH); + ComEval(com, value); + com_Bytecode(com, STRFUN(builtin)[5] == 'A' ? XBC_RPLACA : XBC_RPLACD); + CompileStackLeave(com, 1, 1); +} + +void +Com_Setq(LispCom *com, LispBuiltin *builtin) +/* + setq &rest form + */ +{ + int offset; + LispObj *form, *symbol, *value; + + form = ARGUMENT(0); + + for (; CONSP(form); form = CDR(form)) { + symbol = CAR(form); + CHECK_SYMBOL(symbol); + CHECK_CONSTANT(symbol); + form = CDR(form); + if (!CONSP(form)) + LispDestroy("%s: odd number of arguments", STRFUN(builtin)); + value = CAR(form); + /* Generate code to load value */ + ComEval(com, value); + offset = ComGetVariable(com, symbol); + if (offset >= 0) + com_Set(com, offset); + else + com_SetSym(com, symbol->data.atom); + } +} + +void +Com_Tagbody(LispCom *com, LispBuiltin *builtin) +/* + tagbody &rest body + */ +{ + LispObj *body; + + body = ARGUMENT(0); + + if (CONSP(body)) { + CompileIniBlock(com, LispBlockBody, NIL); + ComProgn(com, body); + /* Tagbody returns NIL */ + com_Bytecode(com, XBC_NIL); + CompileFiniBlock(com); + } + else + /* Tagbody always returns NIL */ + com_Bytecode(com, XBC_NIL); +} + +void +Com_Unless(LispCom *com, LispBuiltin *builtin) +/* + unless test &rest body + */ +{ + CodeTree *group, *tree; + LispObj *test, *body; + + body = ARGUMENT(1); + test = ARGUMENT(0); + + /* Generate code to evaluate test */ + ComEval(com, test); + /* Add node after test */ + group = NEW_TREE(CodeTreeJumpIf); + group->code = XBC_JUMPT; + /* Generate NIL code */ + ComProgn(com, body); + /* Insert node to know where to jump if test is T */ + tree = NEW_TREE(CodeTreeJumpIf); + tree->code = XBC_NOOP; + group->group = tree; +} + +void +Com_Until(LispCom *com, LispBuiltin *builtin) +/* + until test &rest body + */ +{ + CodeTree *tree, *group, *ltree, *lgroup; + LispObj *test, *body; + + body = ARGUMENT(1); + test = ARGUMENT(0); + + /* Insert node to mark LOOP start */ + ltree = NEW_TREE(CodeTreeJump); + ltree->code = XBC_NOOP; + + /* Build code for test */ + ComEval(com, test); + group = NEW_TREE(CodeTreeJumpIf); + group->code = XBC_JUMPT; + + /* Execute @BODY */ + ComProgn(com, body); + + /* Insert node to jump to test again */ + lgroup = NEW_TREE(CodeTreeJump); + lgroup->code = XBC_JUMP; + lgroup->group = ltree; + + /* Insert node to know where to jump if test is T */ + tree = NEW_TREE(CodeTreeJumpIf); + tree->code = XBC_NOOP; + group->group = tree; +} + +void +Com_When(LispCom *com, LispBuiltin *builtin) +/* + when test &rest body + */ +{ + CodeTree *group, *tree; + LispObj *test, *body; + + body = ARGUMENT(1); + test = ARGUMENT(0); + + /* Generate code to evaluate test */ + ComEval(com, test); + /* Add node after test */ + group = NEW_TREE(CodeTreeJumpIf); + group->code = XBC_JUMPNIL; + /* Generate T code */ + ComProgn(com, body); + /* Insert node to know where to jump if test is NIL */ + tree = NEW_TREE(CodeTreeJumpIf); + tree->code = XBC_NOOP; + group->group = tree; +} + +void +Com_While(LispCom *com, LispBuiltin *builtin) +/* + while test &rest body + */ +{ + CodeTree *tree, *group, *ltree, *lgroup; + LispObj *test, *body; + + body = ARGUMENT(1); + test = ARGUMENT(0); + + /* Insert node to mark LOOP start */ + ltree = NEW_TREE(CodeTreeJump); + ltree->code = XBC_NOOP; + + /* Build code for test */ + ComEval(com, test); + group = NEW_TREE(CodeTreeJumpIf); + group->code = XBC_JUMPNIL; + + /* Execute @BODY */ + ComProgn(com, body); + + /* Insert node to jump to test again */ + lgroup = NEW_TREE(CodeTreeJump); + lgroup->code = XBC_JUMP; + lgroup->group = ltree; + + /* Insert node to know where to jump if test is NIL */ + tree = NEW_TREE(CodeTreeJumpIf); + tree->code = XBC_NOOP; + group->group = tree; +} + + +/*********************************************************************** + * Com_XXX helper functions + ***********************************************************************/ +static void +ComPredicate(LispCom *com, LispBuiltin *builtin, LispBytePredicate predicate) +{ + LispObj *object; + + object = ARGUMENT(0); + + if (ComConstantp(com, object)) { + switch (predicate) { + case XBP_CONSP: + com_Bytecode(com, CONSP(object) ? XBC_T : XBC_NIL); + break; + case XBP_LISTP: + com_Bytecode(com, CONSP(object) || object == NIL ? + XBC_T : XBC_NIL); + break; + case XBP_NUMBERP: + com_Bytecode(com, NUMBERP(object) ? XBC_T : XBC_NIL); + break; + } + } + else { + ComEval(com, object); + com_BytecodeChar(com, XBC_PRED, predicate); + } +} + +/* XXX Could receive an argument telling if is the last statement in the + * block(s), i.e. if a jump opcode should be generated or just the + * evaluation of the returned value. Probably this is better done in + * an optimization step. */ +static void +ComReturnFrom(LispCom *com, LispBuiltin *builtin, int from) +{ + int bind; + CodeTree *tree; + LispObj *name, *result; + CodeBlock *block = com->block; + + if (from) { + result = ARGUMENT(1); + name = ARGUMENT(0); + } + else { + result = ARGUMENT(0); + name = NIL; + } + if (result == UNSPEC) + result = NIL; + + bind = block->bind; + while (block) { + if (block->type == LispBlockClosure) + /* A function call */ + break; + else if (block->type == LispBlockTag && block->tag == name) + break; + block = block->prev; + if (block) + bind += block->bind; + } + + if (!block || block->tag != name) + LispDestroy("%s: no visible %s block", STRFUN(builtin), STROBJ(name)); + + /* Generate code to load result */ + ComEval(com, result); + + /* Check for added variables that the jump is skiping the unbind opcode */ + com_Unbind(com, bind); + + tree = NEW_TREE(CodeTreeReturn); + tree->data.block = block; +} + +/*********************************************************************** + * Helper functions + ***********************************************************************/ +static int +ComConstantp(LispCom *com, LispObj *object) +{ + switch (OBJECT_TYPE(object)) { + case LispAtom_t: + /* Keywords are guaranteed to evaluate to itself */ + if (object->data.atom->package == lisp__data.keyword) + break; + return (0); + + /* Function call */ + case LispCons_t: + + /* Need macro expansion, these are special abstract objects */ + case LispQuote_t: + case LispBackquote_t: + case LispComma_t: + case LispFunctionQuote_t: + return (0); + + /* Anything else is a literal constant */ + default: + break; + } + + return (1); +} + +static int +FindIndex(void *item, void **table, int length) +{ + long cmp; + int left, right, i; + + left = 0; + right = length - 1; + while (left <= right) { + i = (left + right) >> 1; + cmp = (char*)item - (char*)table[i]; + if (cmp == 0) + return (i); + else if (cmp < 0) + right = i - 1; + else + left = i + 1; + } + + return (-1); +} + +static int +compare(const void *left, const void *right) +{ + long cmp = *(char**)left - *(char**)right; + + return (cmp < 0 ? -1 : 1); +} + +static int +BuildTablePointer(void *pointer, void ***pointers, int *num_pointers) +{ + int i; + + if ((i = FindIndex(pointer, *pointers, *num_pointers)) < 0) { + *pointers = LispRealloc(*pointers, + sizeof(void*) * (*num_pointers + 1)); + (*pointers)[*num_pointers] = pointer; + if (++*num_pointers > 1) + qsort(*pointers, *num_pointers, sizeof(void*), compare); + i = FindIndex(pointer, *pointers, *num_pointers); + } + + return (i); +} + +static void +ComAddVariable(LispCom *com, LispObj *symbol, LispObj *value) +{ + LispAtom *atom = symbol->data.atom; + + if (atom && atom->string && !com->macro) { + int i, length = com->block->variables.length; + + i = BuildTablePointer(atom, (void***)&com->block->variables.symbols, + &com->block->variables.length); + + if (com->block->variables.length != length) { + com->block->variables.flags = + LispRealloc(com->block->variables.flags, + com->block->variables.length * sizeof(int)); + + /* Variable was inserted in the middle of the list */ + if (i < length) + memmove(com->block->variables.flags + i + 1, + com->block->variables.flags + i, + (length - i) * sizeof(int)); + + com->block->variables.flags[i] = 0; + } + } + + LispAddVar(symbol, value); +} + +static int +ComGetVariable(LispCom *com, LispObj *symbol) +{ + LispAtom *name; + int i, base, offset; + Atom_id id; + + name = symbol->data.atom; + if (name->constant) { + if (name->package == lisp__data.keyword) + /* Just load <symbol> from the byte stream, keywords are + * guaranteed to evaluate to itself. */ + return (SYMBOL_KEYWORD); + return (SYMBOL_CONSTANT); + } + + offset = name->offset; + id = name->string; + base = lisp__data.env.lex; + i = lisp__data.env.head - 1; + + /* If variable is local */ + if (offset <= i && offset >= com->lex && lisp__data.env.names[offset] == id) { + COM_VARIABLE_USED(name); + /* Relative offset */ + return (offset - base); + } + + /* name->offset may have been changed in a macro expansion */ + for (; i >= com->lex; i--) + if (lisp__data.env.names[i] == id) { + name->offset = i; + COM_VARIABLE_USED(name); + return (i - base); + } + + if (!name->a_object) { + ++com->warnings; + LispWarning("variable %s is neither declared nor bound", + name->string); + } + + /* Not found, resolve <symbol> at run time */ + return (SYMBOL_UNBOUND); +} + +static void +ComVariableSetFlag(LispCom *com, LispAtom *atom, int flag) +{ + int i; + CodeBlock *block = com->block; + + while (block) { + i = FindIndex(atom, (void**)block->variables.symbols, + block->variables.length); + if (i >= 0) { + block->variables.flags[i] |= flag; + /* Descend block list if an argument to function being called + * has the same name as a bound variable in the current function. + */ + if ((flag & VARIABLE_ARGUMENT) || + !(block->variables.flags[i] & VARIABLE_ARGUMENT)) + break; + } + block = block->prev; + } +} + +/*********************************************************************** + * Bytecode compiler functions + ***********************************************************************/ +static void +ComLabel(LispCom *com, LispObj *label) +{ + int i; + CodeTree *tree; + + for (i = 0; i < com->block->tagbody.length; i++) + if (label == com->block->tagbody.labels[i]) + LispDestroy("TAGBODY: tag %s specified more than once", + STROBJ(label)); + + if (com->block->tagbody.length >= com->block->tagbody.space) { + com->block->tagbody.labels = + LispRealloc(com->block->tagbody.labels, + sizeof(LispObj*) * (com->block->tagbody.space + 8)); + /* Reserve space, will be used at link time when + * resolving GO jumps. */ + com->block->tagbody.codes = + LispRealloc(com->block->tagbody.codes, + sizeof(CodeTree*) * (com->block->tagbody.space + 8)); + com->block->tagbody.space += 8; + } + + com->block->tagbody.labels[com->block->tagbody.length++] = label; + tree = NEW_TREE(CodeTreeLabel); + tree->data.object = label; +} + +static void +ComPush(LispCom *com, LispObj *symbol, LispObj *value, + int eval, int builtin, int compile) +{ + /* If <compile> is set, it is pushing an argument to one of + * Com_XXX functions. */ + if (compile) { + if (builtin) + lisp__data.stack.values[lisp__data.stack.length++] = value; + else + ComAddVariable(com, symbol, value); + return; + } + + /* If <com->macro> is set, it is expanding a macro, just add the local + * variable <symbol> bounded to <value>, so that it will be available + * when calling the interpreter to expand the macro. */ + else if (com->macro) { + ComAddVariable(com, symbol, value); + return; + } + + /* If <eval> is set, it must generate the opcodes to evaluate <value>. + * If <value> is a constant, just generate the opcodes to load it. */ + else if (eval && !ComConstantp(com, value)) { + switch (OBJECT_TYPE(value)) { + case LispAtom_t: { + int offset = ComGetVariable(com, value); + + if (offset >= 0) { + /* Load <value> from user stack at the relative offset */ + if (builtin) + com_LoadPush(com, offset); + else + com_LoadLet(com, offset, symbol->data.atom); + } + /* ComConstantp() does not return true for this, as the + * current value must be computed. */ + else if (offset == SYMBOL_CONSTANT) { + value = value->data.atom->property->value; + if (builtin) + com_LoadConPush(com, value); + else + com_LoadConLet(com, value, symbol->data.atom); + } + else { + /* Load value bound to <value> at run time */ + if (builtin) + com_LoadSymPush(com, value->data.atom); + else + com_LoadSymLet(com, value->data.atom, + symbol->data.atom); + } + } break; + + default: + /* Generate code to evaluate <value> */ + ComEval(com, value); + if (builtin) + com_Bytecode(com, XBC_PUSH); + else + com_Let(com, symbol->data.atom); + break; + } + + /* Remember <symbol> will be bound, <value> only matters for + * the Com_XXX functions */ + if (builtin) + lisp__data.stack.values[lisp__data.stack.length++] = value; + else + ComAddVariable(com, symbol, value); + return; + } + + if (builtin) { + /* Load <value> as a constant in builtin stack */ + com_LoadConPush(com, value); + lisp__data.stack.values[lisp__data.stack.length++] = value; + } + else { + /* Load <value> as a constant in stack */ + com_LoadConLet(com, value, symbol->data.atom); + /* Remember <symbol> will be bound */ + ComAddVariable(com, symbol, value); + } +} + +/* This function does almost the same job as LispMakeEnvironment, but + * it is not optimized for speed, as it is not building argument lists + * to user code, but to Com_XXX functions, or helping in generating the + * opcodes to load arguments at bytecode run time. */ +static int +ComCall(LispCom *com, LispArgList *alist, + LispObj *name, LispObj *values, + int eval, int builtin, int compile) +{ + char *desc; + int i, count, base; + LispObj **symbols, **defaults, **sforms; + + if (builtin) { + base = lisp__data.stack.length; + /* This should never be executed, but make the check for safety */ + 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; + + 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; + } + + + /* Normal arguments */ +normal_label: + i = 0; + symbols = alist->normals.symbols; + count = alist->normals.num_symbols; + for (; i < count && CONSP(values); i++, values = CDR(values)) { + ComPush(com, symbols[i], CAR(values), eval, builtin, compile); + if (!builtin && !com->macro) + COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); + } + 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; + symbols = alist->optionals.symbols; + defaults = alist->optionals.defaults; + sforms = alist->optionals.sforms; + for (; i < count && CONSP(values); i++, values = CDR(values)) { + ComPush(com, symbols[i], CAR(values), eval, builtin, compile); + if (!builtin && !com->macro) + COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); + if (sforms[i]) { + ComPush(com, sforms[i], T, 0, builtin, compile); + if (!builtin && !com->macro) + COM_VARIABLE_ARGUMENT(sforms[i]->data.atom); + } + } + for (; i < count; i++) { + if (!builtin) { + int lex = com->lex; + int head = lisp__data.env.head; + + com->lex = base; + lisp__data.env.head = lisp__data.env.length; + /* default arguments are evaluated for macros */ + ComPush(com, symbols[i], defaults[i], 1, 0, compile); + if (!com->macro) + COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); + lisp__data.env.head = head; + com->lex = lex; + } + else + ComPush(com, symbols[i], defaults[i], eval, 1, compile); + if (sforms[i]) { + ComPush(com, sforms[i], NIL, 0, builtin, compile); + if (!builtin && !com->macro) + COM_VARIABLE_ARGUMENT(sforms[i]->data.atom); + } + } + + 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 varset; + LispObj *val, *karg, **keys; + + count = alist->keys.num_symbols; + symbols = alist->keys.symbols; + defaults = alist->keys.defaults; + sforms = alist->keys.sforms; + keys = alist->keys.keys; + + /* Check if arguments are correctly specified */ + for (karg = values; CONSP(karg); karg = CDR(karg)) { + val = CAR(karg); + if (KEYWORDP(val)) { + for (i = 0; i < alist->keys.num_symbols; i++) + if (!keys[i] && symbols[i] == val) + break; + } + + else if (!builtin && + QUOTEP(val) && SYMBOLP(val->data.quote)) { + for (i = 0; i < alist->keys.num_symbols; i++) + if (keys[i] && ATOMID(keys[i]) == ATOMID(val->data.quote)) + break; + } + + else + /* Just make the error test true */ + i = alist->keys.num_symbols; + + if (i == alist->keys.num_symbols) { + /* If not in argument specification list... */ + char function_name[36]; + + strcpy(function_name, STROBJ(name)); + LispDestroy("%s: invalid keyword %s", + function_name, STROBJ(val)); + } + + karg = CDR(karg); + if (!CONSP(karg)) + LispDestroy("%s: &KEY needs arguments as pairs", + STROBJ(name)); + } + + /* Add variables */ + for (i = 0; i < alist->keys.num_symbols; i++) { + val = defaults[i]; + varset = 0; + if (!builtin && 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; + 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; + break; + } + karg = CDR(karg); + } + } + + /* Add the variable to environment */ + if (varset) { + ComPush(com, symbols[i], val, eval, builtin, compile); + if (sforms[i]) + ComPush(com, sforms[i], T, 0, builtin, compile); + } + else { + /* default arguments are evaluated for macros */ + if (!builtin) { + int lex = com->lex; + int head = lisp__data.env.head; + + com->lex = base; + lisp__data.env.head = lisp__data.env.length; + ComPush(com, symbols[i], val, eval, 0, compile); + lisp__data.env.head = head; + com->lex = lex; + } + else + ComPush(com, symbols[i], val, eval, builtin, compile); + if (sforms[i]) + ComPush(com, sforms[i], NIL, 0, builtin, compile); + } + if (!builtin && !com->macro) { + COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); + if (sforms[i]) + COM_VARIABLE_ARGUMENT(sforms[i]->data.atom); + } + } + } + + if (*desc == 'a') { + /* &KEY uses all remaining arguments */ + values = NIL; + goto aux_label; + } + goto finished_label; + + + /* &REST */ +rest_label: + if (!eval || !CONSP(values) || (compile && !builtin)) + ComPush(com, alist->rest, values, eval, builtin, compile); + else { + char *string; + LispObj *list, *car = NIL; + int count, constantp; + + /* Count number of arguments and check if it is a list of constants */ + for (count = 0, constantp = 1, list = values; + CONSP(list); + list = CDR(list), count++) { + car = CAR(list); + if (!ComConstantp(com, car)) + constantp = 0; + } + + string = builtin ? ATOMID(name) : NULL; + /* XXX FIXME should have a flag indicating if function call + * change the &REST arguments even if it is a constant list + * (or if the returned value may be changed). */ + if (string && (count < MAX_BCONS || constantp) && + strcmp(string, "LIST") && + strcmp(string, "APPLY") && /* XXX depends on function argument */ + strcmp(string, "VECTOR") && + /* Append does not copy the last/single list */ + (strcmp(string, "APPEND") || !CONSP(car))) { + if (constantp) { + /* If the builtin function changes the &REST parameters, must + * define a Com_XXX function for it. */ + ComPush(com, alist->rest, values, 0, builtin, compile); + } + else { + CompileStackEnter(com, count - 1, 1); + for (; CONSP(CDR(values)); values = CDR(values)) { + /* Evaluate this argument */ + ComEval(com, CAR(values)); + /* Save result in builtin stack */ + com_Bytecode(com, XBC_PUSH); + } + CompileStackLeave(com, count - 1, 1); + /* The last argument is not saved in the stack */ + ComEval(com, CAR(values)); + values = NIL; + com_Bytecode(com, XBC_BCONS + (count - 1)); + } + } + else { + /* Allocate a fresh list of cons */ + + /* Generate code to load object */ + ComEval(com, CAR(values)); + + com->stack.cpstack += 2; + if (com->stack.pstack < com->stack.cpstack) + com->stack.pstack = com->stack.cpstack; + /* Start building a gc protected list, with the loaded value */ + com_Bytecode(com, XBC_LSTAR); + + for (values = CDR(values); CONSP(values); values = CDR(values)) { + /* Generate code to load object */ + ComEval(com, CAR(values)); + + /* Add loaded value to gc protected list */ + com_Bytecode(com, XBC_LCONS); + } + + /* Finish gc protected list */ + com_Bytecode(com, XBC_LFINI); + + /* Push loaded value */ + if (builtin) + com_Bytecode(com, XBC_PUSH); + else { + com_Let(com, alist->rest->data.atom); + + /* Remember this symbol will be bound */ + ComAddVariable(com, alist->rest, values); + } + com->stack.cpstack -= 2; + } + } + if (!builtin && !com->macro) + COM_VARIABLE_ARGUMENT(alist->rest->data.atom); + if (*desc != 'a') + goto finished_label; + + + /* &AUX */ +aux_label: + i = 0; + count = alist->auxs.num_symbols; + symbols = alist->auxs.symbols; + defaults = alist->auxs.initials; + if (!builtin && !compile) { + int lex = com->lex; + + com->lex = base; + lisp__data.env.head = lisp__data.env.length; + for (; i < count; i++) { + ComPush(com, symbols[i], defaults[i], 1, 0, 0); + if (!com->macro) + COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); + ++lisp__data.env.head; + } + com->lex = lex; + } + else { + for (; i < count; i++) { + ComPush(com, symbols[i], defaults[i], eval, builtin, compile); + if (!builtin && !com->macro) + COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); + } + } + +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; + + return (base); +} + +static void +ComFuncall(LispCom *com, LispObj *function, LispObj *arguments, int eval) +{ + int base, compile; + LispAtom *atom; + LispArgList *alist; + LispBuiltin *builtin; + LispObj *lambda; + + switch (OBJECT_TYPE(function)) { + case LispFunction_t: + function = function->data.atom->object; + case LispAtom_t: + atom = function->data.atom; + alist = atom->property->alist; + + if (atom->a_builtin) { + builtin = atom->property->fun.builtin; + compile = builtin->compile != NULL; + + /* If one of: + * o expanding a macro + * o calling a builtin special form + * o builtin function is a macro + * don't evaluate arguments. */ + if (com->macro || compile || builtin->type == LispMacro) + eval = 0; + + if (!com->macro && builtin->type == LispMacro) { + /* Set flag of variable used, in case variable is only + * used as a builtin macro argument. */ + LispObj *obj; + + for (obj = arguments; CONSP(obj); obj = CDR(obj)) { + if (SYMBOLP(CAR(obj))) + COM_VARIABLE_USED(CAR(obj)->data.atom); + } + } + + FORM_ENTER(); + if (!compile && !com->macro) + CompileStackEnter(com, alist->num_arguments, 1); + + /* Build argument list in the interpreter stacks */ + base = ComCall(com, alist, function, arguments, + eval, 1, compile); + + /* If <compile> is set, it is a special form */ + if (compile) + builtin->compile(com, builtin); + + /* Else, generate opcodes to call builtin function */ + else { + com_Call(com, alist->num_arguments, builtin); + CompileStackLeave(com, alist->num_arguments, 1); + } + lisp__data.stack.base = lisp__data.stack.length = base; + FORM_LEAVE(); + } + else if (atom->a_function) { + int macro; + + lambda = atom->property->fun.function; + macro = lambda->funtype == LispMacro; + + /* If <macro> is set, expand macro */ + if (macro) + ComMacroCall(com, alist, function, lambda, arguments); + + else { + if (com->toplevel->type == LispBlockClosure && + com->toplevel->tag == function) + ComRecursiveCall(com, alist, function, arguments); + else { +#if 0 + ComInlineCall(com, alist, function, arguments, + lambda->data.lambda.code); +#else + com_Funcall(com, function, arguments); +#endif + } + } + } + else if (atom->a_defstruct && + atom->property->structure.function != STRUCT_NAME && + atom->property->structure.function != STRUCT_CONSTRUCTOR) { + LispObj *definition = atom->property->structure.definition; + + if (!CONSP(arguments) || CONSP(CDR(arguments))) + LispDestroy("%s: too %s arguments", atom->string, + CONSP(arguments) ? "many" : "few"); + + ComEval(com, CAR(arguments)); + if (atom->property->structure.function == STRUCT_CHECK) + com_Structp(com, definition); + else + com_Struct(com, + atom->property->structure.function, definition); + } + else if (atom->a_compiled) { + FORM_ENTER(); + CompileStackEnter(com, alist->num_arguments, 0); + + /* Build argument list in the interpreter stacks */ + base = ComCall(com, alist, function, arguments, 1, 0, 0); + com_Bytecall(com, alist->num_arguments, + atom->property->fun.function); + CompileStackLeave(com, alist->num_arguments, 0); + lisp__data.env.head = lisp__data.env.length = base; + FORM_LEAVE(); + } + else { + /* Not yet defined function/macro. */ + ++com->warnings; + LispWarning("call to undefined function %s", atom->string); + com_Funcall(com, function, arguments); + } + break; + + case LispLambda_t: + lambda = function->data.lambda.code; + alist = (LispArgList*)function->data.lambda.name->data.opaque.data; + ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code); + 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; + ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code); + GC_LEAVE(); + break; + } + } + + default: + /* XXX If bytecode objects are made available, should + * handle it here. */ + LispDestroy("EVAL: %s is invalid as a function", + STROBJ(function)); + /*NOTREACHED*/ + break; + } +} + +/* Generate opcodes for an implicit PROGN */ +static void +ComProgn(LispCom *com, LispObj *code) +{ + if (CONSP(code)) { + for (; CONSP(code); code = CDR(code)) + ComEval(com, CAR(code)); + } + else + /* If no code to execute, empty PROGN returns NIL */ + com_Bytecode(com, XBC_NIL); +} + +/* Generate opcodes to evaluate <object>. */ +static void +ComEval(LispCom *com, LispObj *object) +{ + int offset; + LispObj *form; + + switch (OBJECT_TYPE(object)) { + case LispAtom_t: + if (IN_TAGBODY()) + ComLabel(com, object); + else { + offset = ComGetVariable(com, object); + if (offset >= 0) + /* Load from user stack at relative offset */ + com_Load(com, offset); + else if (offset == SYMBOL_KEYWORD) + com_LoadCon(com, object); + else if (offset == SYMBOL_CONSTANT) + /* Symbol defined as constant, just load it's value */ + com_LoadCon(com, LispGetVar(object)); + else + /* Load value bound to symbol at run time */ + com_LoadSym(com, object->data.atom); + } + break; + + case LispCons_t: { + /* Macro expansion may be done in the object form */ + form = com->form; + com->form = object; + ComFuncall(com, CAR(object), CDR(object), 1); + com->form = form; + } break; + + case LispQuote_t: + com_LoadCon(com, object->data.quote); + break; + + case LispBackquote_t: + /* Macro expansion is stored in the current value of com->form */ + ComMacroBackquote(com, object); + break; + + case LispComma_t: + LispDestroy("EVAL: comma outside of backquote"); + break; + + case LispFunctionQuote_t: + object = object->data.quote; + if (SYMBOLP(object)) + object = LispSymbolFunction(object); + else if (CONSP(object) && CAR(object) == Olambda) { + /* object will only be associated with bytecode later, + * so, make sure it is protected until compilation finishes */ + object = EVAL(object); + RPLACD(com->plist, CONS(CAR(com->plist), CDR(com->plist))); + RPLACA(com->plist, object); + } + else + LispDestroy("FUNCTION: %s is not a function", STROBJ(object)); + com_LoadCon(com, object); + break; + + case LispFixnum_t: + if (IN_TAGBODY()) { + ComLabel(com, object); + break; + } + /*FALLTROUGH*/ + + default: + /* Constant object */ + com_LoadCon(com, object); + break; + } +} + +/*********************************************************************** + * Lambda expansion helper functions + ***********************************************************************/ +static void +ComRecursiveCall(LispCom *com, LispArgList *alist, + LispObj *name, LispObj *arguments) +{ + int base, lex; + + /* Save state */ + lex = lisp__data.env.lex; + + FORM_ENTER(); + + /* Generate code to push function arguments in the stack */ + base = ComCall(com, alist, name, arguments, 1, 0, 0); + + /* Stack will grow this amount */ + CompileStackEnter(com, alist->num_arguments, 0); + +#if 0 + /* Make the variables available at run time */ + com_Bind(com, alist->num_arguments); + com->block->bind += alist->num_arguments; +#endif + + com_BytecodeChar(com, XBC_LETREC, alist->num_arguments); + +#if 0 + /* The variables are now unbound */ + com_Unbind(com, alist->num_arguments); + com->block->bind -= alist->num_arguments; +#endif + + /* Stack length is reduced */ + CompileStackLeave(com, alist->num_arguments, 0); + FORM_LEAVE(); + + /* Restore state */ + lisp__data.env.lex = lex; + lisp__data.env.head = lisp__data.env.length = base; +} + +static void +ComInlineCall(LispCom *com, LispArgList *alist, + LispObj *name, LispObj *arguments, LispObj *lambda) +{ + int base, lex; + + /* Save state */ + lex = lisp__data.env.lex; + + FORM_ENTER(); + /* Start the inline function block */ + CompileIniBlock(com, LispBlockClosure, name); + + /* Generate code to push function arguments in the stack */ + base = ComCall(com, alist, name, arguments, 1, 0, 0); + + /* Stack will grow this amount */ + CompileStackEnter(com, alist->num_arguments, 0); + + /* Make the variables available at run time */ + com_Bind(com, alist->num_arguments); + com->block->bind += alist->num_arguments; + + /* Expand the lambda list */ + ComProgn(com, lambda); + + /* The variables are now unbound */ + com_Unbind(com, alist->num_arguments); + com->block->bind -= alist->num_arguments; + + /* Stack length is reduced */ + CompileStackLeave(com, alist->num_arguments, 0); + + /* Finish the inline function block */ + CompileFiniBlock(com); + FORM_LEAVE(); + + /* Restore state */ + lisp__data.env.lex = lex; + lisp__data.env.head = lisp__data.env.length = base; +} + +/*********************************************************************** + * Macro expansion helper functions. + ***********************************************************************/ +static LispObj * +ComMacroExpandBackquote(LispCom *com, LispObj *object) +{ + return (LispEvalBackquote(object->data.quote, 1)); +} + +static LispObj * +ComMacroExpandFuncall(LispCom *com, LispObj *function, LispObj *arguments) +{ + return (LispFuncall(function, arguments, 1)); +} + +static LispObj * +ComMacroExpandEval(LispCom *com, LispObj *object) +{ + LispObj *result; + + switch (OBJECT_TYPE(object)) { + case LispAtom_t: + result = LispGetVar(object); + + /* Macro expansion requires bounded symbols */ + if (result == NULL) + LispDestroy("EVAL: the variable %s is unbound", + STROBJ(object)); + break; + + case LispCons_t: + result = ComMacroExpandFuncall(com, CAR(object), CDR(object)); + break; + + case LispQuote_t: + result = object->data.quote; + break; + + case LispBackquote_t: + result = ComMacroExpandBackquote(com, object); + break; + + case LispComma_t: + LispDestroy("EVAL: comma outside of backquote"); + + case LispFunctionQuote_t: + result = EVAL(object); + break; + + default: + result = object; + break; + } + + return (result); +} + +static LispObj * +ComMacroExpand(LispCom *com, LispObj *lambda) +{ + LispObj *result, **presult = &result, **plambda; + int jumped, *pjumped = &jumped, backquote, *pbackquote = &backquote; + LispBlock *block; + + int interpreter_lex, interpreter_head, interpreter_base; + + /* Save interpreter state */ + interpreter_base = lisp__data.stack.length; + interpreter_head = lisp__data.env.length; + interpreter_lex = lisp__data.env.lex; + + /* Use the variables */ + plambda = λ + *presult = NIL; + *pjumped = 1; + *pbackquote = !CONSP(lambda); + + block = LispBeginBlock(NIL, LispBlockProtect); + if (setjmp(block->jmp) == 0) { + if (!backquote) { + for (; CONSP(lambda); lambda = CDR(lambda)) + result = ComMacroExpandEval(com, CAR(lambda)); + } + else + result = ComMacroExpandBackquote(com, lambda); + + *pjumped = 0; + } + LispEndBlock(block); + + /* If tried to jump out of the macro expansion block */ + if (!lisp__data.destroyed && jumped) + LispDestroy("*** EVAL: bad jump in macro expansion"); + + /* Macro expansion did something wrong */ + if (lisp__data.destroyed) { + LispMessage("*** EVAL: aborting macro expansion"); + LispDestroy("."); + } + + /* Restore interpreter state */ + lisp__data.env.lex = interpreter_lex; + lisp__data.stack.length = interpreter_base; + lisp__data.env.head = lisp__data.env.length = interpreter_head; + + return (result); +} + +static void +ComMacroCall(LispCom *com, LispArgList *alist, + LispObj *name, LispObj *lambda, LispObj *arguments) +{ + int base; + LispObj *body; + + ++com->macro; + base = ComCall(com, alist, name, arguments, 0, 0, 0); + body = lambda->data.lambda.code; + body = ComMacroExpand(com, body); + --com->macro; + lisp__data.env.head = lisp__data.env.length = base; + + /* Macro is expanded, store the result */ + CAR(com->form) = body; + ComEval(com, body); +} + +static void +ComMacroBackquote(LispCom *com, LispObj *lambda) +{ + LispObj *body; + + ++com->macro; + body = ComMacroExpand(com, lambda); + --com->macro; + + /* Macro is expanded, store the result */ + CAR(com->form) = body; + + com_LoadCon(com, body); +} diff --git a/lisp/core.c b/lisp/core.c new file mode 100644 index 0000000..d834dd5 --- /dev/null +++ b/lisp/core.c @@ -0,0 +1,7040 @@ +/* + * 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/core.c,v 1.69 2002/12/20 04:32:45 paulo Exp $ */ + +#include "io.h" +#include "core.h" +#include "format.h" +#include "helper.h" +#include "package.h" +#include "private.h" +#include "write.h" + +/* + * Types + */ +typedef struct _SeqInfo { + LispType type; + union { + LispObj *list; + LispObj **vector; + unsigned char *string; + } data; +} SeqInfo; + +#define SETSEQ(seq, object) \ + switch (seq.type = XOBJECT_TYPE(object)) { \ + case LispString_t: \ + seq.data.string = (unsigned char*)THESTR(object); \ + break; \ + case LispCons_t: \ + seq.data.list = object; \ + break; \ + default: \ + seq.data.list = object->data.array.list; \ + break; \ + } + +#ifdef NEED_SETENV +extern int setenv(const char *name, const char *value, int overwrite); +extern void unsetenv(const char *name); +#endif + +/* + * Prototypes + */ +#define NONE 0 + +#define REMOVE 1 +#define SUBSTITUTE 2 +#define DELETE 3 +#define NSUBSTITUTE 4 + +#define ASSOC 1 +#define MEMBER 2 + +#define FIND 1 +#define POSITION 2 + +#define IF 1 +#define IFNOT 2 + +#define UNION 1 +#define INTERSECTION 2 +#define SETDIFFERENCE 3 +#define SETEXCLUSIVEOR 4 +#define SUBSETP 5 +#define NSETDIFFERENCE 6 +#define NINTERSECTION 7 +#define NUNION 8 +#define NSETEXCLUSIVEOR 9 + +#define COPY_LIST 1 +#define COPY_ALIST 2 +#define COPY_TREE 3 + +#define EVERY 1 +#define SOME 2 +#define NOTEVERY 3 +#define NOTANY 4 + +/* Call directly LispObjectCompare() if possible */ +#define FCODE(predicate) \ + predicate == Oeql ? FEQL : \ + predicate == Oequal ? FEQUAL : \ + predicate == Oeq ? FEQ : \ + predicate == Oequalp ? FEQUALP : 0 +#define FCOMPARE(predicate, left, right, code) \ + code == FEQ ? left == right : \ + code ? LispObjectCompare(left, right, code) != NIL : \ + APPLY2(predicate, left, right) != NIL + +#define FUNCTION_CHECK(predicate) \ + if (FUNCTIONP(predicate)) \ + predicate = (predicate)->data.atom->object + +#define CHECK_TEST_0() \ + if (test != UNSPEC && test_not != UNSPEC) \ + LispDestroy("%s: specify either :TEST or :TEST-NOT", \ + STRFUN(builtin)) + +#define CHECK_TEST() \ + CHECK_TEST_0(); \ + if (test_not == UNSPEC) { \ + if (test == UNSPEC) \ + lambda = Oeql; \ + else \ + lambda = test; \ + expect = 1; \ + } \ + else { \ + lambda = test_not; \ + expect = 0; \ + } \ + FUNCTION_CHECK(lambda); \ + code = FCODE(lambda) + + +static LispObj *LispAdjoin(LispBuiltin*, + LispObj*, LispObj*, LispObj*, LispObj*, LispObj*); +static LispObj *LispAssocOrMember(LispBuiltin*, int, int); +static LispObj *LispEverySomeAnyNot(LispBuiltin*, int); +static LispObj *LispFindOrPosition(LispBuiltin*, int, int); +static LispObj *LispDeleteOrRemoveDuplicates(LispBuiltin*, int); +static LispObj *LispDeleteRemoveXSubstitute(LispBuiltin*, int, int); +static LispObj *LispListSet(LispBuiltin*, int); +static LispObj *LispMapc(LispBuiltin*, int); +static LispObj *LispMapl(LispBuiltin*, int); +static LispObj *LispMapnconc(LispObj*); +extern LispObj *LispRunSetf(LispArgList*, LispObj*, LispObj*, LispObj*); +extern LispObj *LispRunSetfMacro(LispAtom*, LispObj*, LispObj*); +static LispObj *LispMergeSort(LispObj*, LispObj*, LispObj*, int); +static LispObj *LispXReverse(LispBuiltin*, int); +static LispObj *LispCopyList(LispBuiltin*, LispObj*, int); +static LispObj *LispValuesList(LispBuiltin*, int); +static LispObj *LispTreeEqual(LispObj*, LispObj*, LispObj*, int); +static LispDocType_t LispDocumentationType(LispBuiltin*, LispObj*); + +extern void LispSetAtomObjectProperty(LispAtom*, LispObj*); + +/* + * Initialization + */ +LispObj *Oeq, *Oeql, *Oequal, *Oequalp, *Omake_array, + *Kinitial_contents, *Osetf, *Ootherwise, *Oquote; +LispObj *Ogensym_counter; + +Atom_id Svariable, Sstructure, Stype, Ssetf; + +/* + * Implementation + */ +void +LispCoreInit(void) +{ + Oeq = STATIC_ATOM("EQ"); + Oeql = STATIC_ATOM("EQL"); + Oequal = STATIC_ATOM("EQUAL"); + Oequalp = STATIC_ATOM("EQUALP"); + Omake_array = STATIC_ATOM("MAKE-ARRAY"); + Kinitial_contents = KEYWORD("INITIAL-CONTENTS"); + Osetf = STATIC_ATOM("SETF"); + Ootherwise = STATIC_ATOM("OTHERWISE"); + LispExportSymbol(Ootherwise); + Oquote = STATIC_ATOM("QUOTE"); + LispExportSymbol(Oquote); + + Svariable = GETATOMID("VARIABLE"); + Sstructure = GETATOMID("STRUCTURE"); + Stype = GETATOMID("TYPE"); + + /* Create as a constant so that only the C code should change the value */ + Ogensym_counter = STATIC_ATOM("*GENSYM-COUNTER*"); + LispDefconstant(Ogensym_counter, FIXNUM(0), NIL); + LispExportSymbol(Ogensym_counter); + + Ssetf = ATOMID(Osetf); +} + +LispObj * +Lisp_Acons(LispBuiltin *builtin) +/* + acons key datum alist + */ +{ + LispObj *key, *datum, *alist; + + alist = ARGUMENT(2); + datum = ARGUMENT(1); + key = ARGUMENT(0); + + return (CONS(CONS(key, datum), alist)); +} + +static LispObj * +LispAdjoin(LispBuiltin*builtin, LispObj *item, LispObj *list, + LispObj *key, LispObj *test, LispObj *test_not) +{ + GC_ENTER(); + int code, expect, value; + LispObj *lambda, *compare, *object; + + CHECK_LIST(list); + CHECK_TEST(); + + if (key != UNSPEC) { + item = APPLY1(key, item); + /* Result is not guaranteed to be gc protected */ + GC_PROTECT(item); + } + + /* Check if item is not already in place */ + for (object = list; CONSP(object); object = CDR(object)) { + compare = CAR(object); + if (key != UNSPEC) { + compare = APPLY1(key, compare); + GC_PROTECT(compare); + value = FCOMPARE(lambda, item, compare, code); + /* Unprotect compare... */ + --lisp__data.protect.length; + } + else + value = FCOMPARE(lambda, item, compare, code); + + if (value == expect) { + /* Item is already in list */ + GC_LEAVE(); + + return (list); + } + } + GC_LEAVE(); + + return (CONS(item, list)); +} + +LispObj * +Lisp_Adjoin(LispBuiltin *builtin) +/* + adjoin item list &key key test test-not + */ +{ + LispObj *item, *list, *key, *test, *test_not; + + test_not = ARGUMENT(4); + test = ARGUMENT(3); + key = ARGUMENT(2); + list = ARGUMENT(1); + item = ARGUMENT(0); + + return (LispAdjoin(builtin, item, list, key, test, test_not)); +} + +LispObj * +Lisp_Append(LispBuiltin *builtin) +/* + append &rest lists + */ +{ + GC_ENTER(); + LispObj *result, *cons, *list; + + LispObj *lists; + + lists = ARGUMENT(0); + + /* no arguments */ + if (!CONSP(lists)) + return (NIL); + + /* skip initial nil lists */ + for (; CONSP(CDR(lists)) && CAR(lists) == NIL; lists = CDR(lists)) + ; + + /* last argument is not copied (even if it is the single argument) */ + if (!CONSP(CDR(lists))) + return (CAR(lists)); + + /* make sure result is a list */ + list = CAR(lists); + CHECK_CONS(list); + result = cons = CONS(CAR(list), NIL); + GC_PROTECT(result); + for (list = CDR(list); CONSP(list); list = CDR(list)) { + RPLACD(cons, CONS(CAR(list), NIL)); + cons = CDR(cons); + } + lists = CDR(lists); + + /* copy intermediate lists */ + for (; CONSP(CDR(lists)); lists = CDR(lists)) { + list = CAR(lists); + if (list == NIL) + continue; + /* intermediate elements must be lists */ + CHECK_CONS(list); + for (; CONSP(list); list = CDR(list)) { + RPLACD(cons, CONS(CAR(list), NIL)); + cons = CDR(cons); + } + } + + /* add last element */ + RPLACD(cons, CAR(lists)); + + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Aref(LispBuiltin *builtin) +/* + aref array &rest subscripts + */ +{ + long c, count, idx, seq; + LispObj *obj, *dim; + + LispObj *array, *subscripts; + + subscripts = ARGUMENT(1); + array = ARGUMENT(0); + + /* accept strings also */ + if (STRINGP(array) && CONSP(subscripts) && CDR(subscripts) == NIL) { + long offset, length = STRLEN(array); + + CHECK_INDEX(CAR(subscripts)); + offset = FIXNUM_VALUE(CAR(subscripts)); + + if (offset >= length) + LispDestroy("%s: index %ld too large for sequence length %ld", + STRFUN(builtin), offset, length); + + return (SCHAR(THESTR(array)[offset])); + } + + CHECK_ARRAY(array); + + for (count = 0, dim = subscripts, obj = array->data.array.dim; CONSP(dim); + count++, dim = CDR(dim), obj = CDR(obj)) { + if (count >= array->data.array.rank) + LispDestroy("%s: too many subscripts %s", + STRFUN(builtin), STROBJ(subscripts)); + if (!INDEXP(CAR(dim)) || + FIXNUM_VALUE(CAR(dim)) >= FIXNUM_VALUE(CAR(obj))) + LispDestroy("%s: %s is out of range or a bad index", + STRFUN(builtin), STROBJ(CAR(dim))); + } + if (count < array->data.array.rank) + LispDestroy("%s: too few subscripts %s", + STRFUN(builtin), STROBJ(subscripts)); + + for (count = seq = 0, dim = subscripts; CONSP(dim); dim = CDR(dim), seq++) { + for (idx = 0, obj = array->data.array.dim; idx < seq; + obj = CDR(obj), ++idx) + ; + for (c = 1, obj = CDR(obj); obj != NIL; obj = CDR(obj)) + c *= FIXNUM_VALUE(CAR(obj)); + count += c * FIXNUM_VALUE(CAR(dim)); + } + + for (array = array->data.array.list; count > 0; array = CDR(array), count--) + ; + + return (CAR(array)); +} + +static LispObj * +LispAssocOrMember(LispBuiltin *builtin, int function, int comparison) +/* + assoc item list &key test test-not key + assoc-if predicate list &key key + assoc-if-not predicate list &key key + member item list &key test test-not key + member-if predicate list &key key + member-if-not predicate list &key key + */ +{ + int code = 0, expect, value; + LispObj *lambda, *result, *compare; + + LispObj *item, *list, *test, *test_not, *key; + + if (comparison == NONE) { + key = ARGUMENT(4); + test_not = ARGUMENT(3); + test = ARGUMENT(2); + list = ARGUMENT(1); + item = ARGUMENT(0); + lambda = NIL; + } + else { + key = ARGUMENT(2); + list = ARGUMENT(1); + lambda = ARGUMENT(0); + test = test_not = UNSPEC; + item = NIL; + } + + if (list == NIL) + return (NIL); + CHECK_CONS(list); + + /* Resolve compare function, and expected result of comparison */ + if (comparison == NONE) { + CHECK_TEST(); + } + else + expect = comparison == IFNOT ? 0 : 1; + + result = NIL; + for (; CONSP(list); list = CDR(list)) { + compare = CAR(list); + if (function == ASSOC) { + if (!CONSP(compare)) + continue; + compare = CAR(compare); + } + if (key != UNSPEC) + compare = APPLY1(key, compare); + + if (comparison == NONE) + value = FCOMPARE(lambda, item, compare, code); + else + value = APPLY1(lambda, compare) != NIL; + if (value == expect) { + result = list; + if (function == ASSOC) + result = CAR(result); + break; + } + } + if (function == MEMBER) { + CHECK_LIST(list); + } + + return (result); +} + +LispObj * +Lisp_Assoc(LispBuiltin *builtin) +/* + assoc item list &key test test-not key + */ +{ + return (LispAssocOrMember(builtin, ASSOC, NONE)); +} + +LispObj * +Lisp_AssocIf(LispBuiltin *builtin) +/* + assoc-if predicate list &key key + */ +{ + return (LispAssocOrMember(builtin, ASSOC, IF)); +} + +LispObj * +Lisp_AssocIfNot(LispBuiltin *builtin) +/* + assoc-if-not predicate list &key key + */ +{ + return (LispAssocOrMember(builtin, ASSOC, IFNOT)); +} + +LispObj * +Lisp_And(LispBuiltin *builtin) +/* + and &rest args + */ +{ + LispObj *result = T, *args; + + args = ARGUMENT(0); + + for (; CONSP(args); args = CDR(args)) { + result = EVAL(CAR(args)); + if (result == NIL) + break; + } + + return (result); +} + +LispObj * +Lisp_Apply(LispBuiltin *builtin) +/* + apply function arg &rest more-args + */ +{ + GC_ENTER(); + LispObj *result, *arguments; + + LispObj *function, *arg, *more_args; + + more_args = ARGUMENT(2); + arg = ARGUMENT(1); + function = ARGUMENT(0); + + if (more_args == NIL) { + CHECK_LIST(arg); + arguments = arg; + for (; CONSP(arg); arg = CDR(arg)) + ; + CHECK_LIST(arg); + } + else { + LispObj *cons; + + CHECK_CONS(more_args); + arguments = cons = CONS(arg, NIL); + GC_PROTECT(arguments); + for (arg = CDR(more_args); + CONSP(arg); + more_args = arg, arg = CDR(arg)) { + RPLACD(cons, CONS(CAR(more_args), NIL)); + cons = CDR(cons); + } + more_args = CAR(more_args); + if (more_args != NIL) { + for (arg = more_args; CONSP(arg); arg = CDR(arg)) + ; + CHECK_LIST(arg); + RPLACD(cons, more_args); + } + } + + result = APPLY(function, arguments); + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Atom(LispBuiltin *builtin) +/* + atom object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (CONSP(object) ? NIL : T); +} + +LispObj * +Lisp_Block(LispBuiltin *builtin) +/* + block name &rest body + */ +{ + int did_jump, *pdid_jump = &did_jump; + LispObj *res, **pres = &res, **pbody; + LispBlock *block; + + LispObj *name, *body; + + body = ARGUMENT(1); + name = ARGUMENT(0); + + if (!SYMBOLP(name) && name != NIL && name != T) + LispDestroy("%s: %s cannot name a block", + STRFUN(builtin), STROBJ(name)); + + pbody = &body; + *pres = NIL; + *pdid_jump = 1; + block = LispBeginBlock(name, LispBlockTag); + if (setjmp(block->jmp) == 0) { + for (; CONSP(body); body = CDR(body)) + res = EVAL(CAR(body)); + *pdid_jump = 0; + } + LispEndBlock(block); + if (*pdid_jump) + *pres = lisp__data.block.block_ret; + + return (res); +} + +LispObj * +Lisp_Boundp(LispBuiltin *builtin) +/* + boundp symbol + */ +{ + LispAtom *atom; + + LispObj *symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + + atom = symbol->data.atom; + if (atom->package == lisp__data.keyword || + (atom->a_object && atom->property->value != UNBOUND)) + return (T); + + return (NIL); +} + +LispObj * +Lisp_Butlast(LispBuiltin *builtin) +/* + butlast list &optional count + */ +{ + GC_ENTER(); + long length, count; + LispObj *result, *cons, *list, *ocount; + + ocount = ARGUMENT(1); + list = ARGUMENT(0); + + CHECK_LIST(list); + if (ocount == UNSPEC) + count = 1; + else { + CHECK_INDEX(ocount); + count = FIXNUM_VALUE(ocount); + } + length = LispLength(list); + + if (count == 0) + return (list); + else if (count >= length) + return (NIL); + + length -= count + 1; + result = cons = CONS(CAR(list), NIL); + GC_PROTECT(result); + for (list = CDR(list); length > 0; list = CDR(list), length--) { + RPLACD(cons, CONS(CAR(list), NIL)); + cons = CDR(cons); + } + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Nbutlast(LispBuiltin *builtin) +/* + nbutlast list &optional count + */ +{ + long length, count; + LispObj *result, *list, *ocount; + + ocount = ARGUMENT(1); + list = ARGUMENT(0); + + CHECK_LIST(list); + if (ocount == UNSPEC) + count = 1; + else { + CHECK_INDEX(ocount); + count = FIXNUM_VALUE(ocount); + } + length = LispLength(list); + + if (count == 0) + return (list); + else if (count >= length) + return (NIL); + + length -= count + 1; + result = list; + for (; length > 0; list = CDR(list), length--) + ; + RPLACD(list, NIL); + + return (result); +} + +LispObj * +Lisp_Car(LispBuiltin *builtin) +/* + car list + */ +{ + LispObj *list, *result = NULL; + + list = ARGUMENT(0); + + if (list == NIL) + result = NIL; + else { + CHECK_CONS(list); + result = CAR(list); + } + + return (result); +} + +LispObj * +Lisp_Case(LispBuiltin *builtin) +/* + case keyform &rest body + */ +{ + LispObj *result, *code, *keyform, *body, *form; + + body = ARGUMENT(1); + keyform = ARGUMENT(0); + + result = NIL; + keyform = EVAL(keyform); + + for (; CONSP(body); body = CDR(body)) { + code = CAR(body); + CHECK_CONS(code); + + form = CAR(code); + if (form == T || form == Ootherwise) { + if (CONSP(CDR(body))) + LispDestroy("%s: %s must be the last clause", + STRFUN(builtin), STROBJ(CAR(code))); + result = CDR(code); + break; + } + else if (CONSP(form)) { + for (; CONSP(form); form = CDR(form)) + if (XEQL(keyform, CAR(form)) == T) { + result = CDR(code); + break; + } + if (CONSP(form)) /* if found match */ + break; + } + else if (XEQL(keyform, form) == T) { + result = CDR(code); + break; + } + } + + for (body = result; CONSP(body); body = CDR(body)) + result = EVAL(CAR(body)); + + return (result); +} + +LispObj * +Lisp_Catch(LispBuiltin *builtin) +/* + catch tag &rest body + */ +{ + int did_jump, *pdid_jump = &did_jump; + LispObj *res, **pres = &res; + LispBlock *block; + + LispObj *tag, *body, **pbody; + + body = ARGUMENT(1); + tag = ARGUMENT(0); + + pbody = &body; + *pres = NIL; + *pdid_jump = 1; + block = LispBeginBlock(tag, LispBlockCatch); + if (setjmp(block->jmp) == 0) { + for (; CONSP(body); body = CDR(body)) + res = EVAL(CAR(body)); + *pdid_jump = 0; + } + LispEndBlock(block); + if (*pdid_jump) + *pres = lisp__data.block.block_ret; + + return (res); +} + +LispObj * +Lisp_Coerce(LispBuiltin *builtin) +/* + coerce object result-type + */ +{ + LispObj *object, *result_type; + + result_type = ARGUMENT(1); + object = ARGUMENT(0); + + return (LispCoerce(builtin, object, result_type)); +} + +LispObj * +Lisp_Cdr(LispBuiltin *builtin) +/* + cdr list + */ +{ + LispObj *list, *result = NULL; + + list = ARGUMENT(0); + + if (list == NIL) + result = NIL; + else { + CHECK_CONS(list); + result = CDR(list); + } + + return (result); +} + +LispObj * +Lisp_C_r(LispBuiltin *builtin) +/* + c[ad]{2,4}r list + */ +{ + char *desc; + + LispObj *list, *result = NULL; + + list = ARGUMENT(0); + + result = list; + desc = STRFUN(builtin); + while (desc[1] != 'R') + ++desc; + while (*desc != 'C') { + if (result == NIL) + break; + CHECK_CONS(result); + result = *desc == 'A' ? CAR(result) : CDR(result); + --desc; + } + + return (result); +} + +LispObj * +Lisp_Cond(LispBuiltin *builtin) +/* + cond &rest body + */ +{ + LispObj *result, *code, *body; + + body = ARGUMENT(0); + + result = NIL; + for (; CONSP(body); body = CDR(body)) { + code = CAR(body); + + CHECK_CONS(code); + result = EVAL(CAR(code)); + if (result == NIL) + continue; + for (code = CDR(code); CONSP(code); code = CDR(code)) + result = EVAL(CAR(code)); + break; + } + + return (result); +} + +static LispObj * +LispCopyList(LispBuiltin *builtin, LispObj *list, int function) +{ + GC_ENTER(); + LispObj *result, *cons; + + if (list == NIL) + return (list); + CHECK_CONS(list); + + result = cons = CONS(NIL, NIL); + GC_PROTECT(result); + if (CONSP(CAR(list))) { + switch (function) { + case COPY_LIST: + RPLACA(result, CAR(list)); + break; + case COPY_ALIST: + RPLACA(result, CONS(CAR(CAR(list)), CDR(CAR(list)))); + break; + case COPY_TREE: + RPLACA(result, LispCopyList(builtin, CAR(list), COPY_TREE)); + break; + } + } + else + RPLACA(result, CAR(list)); + + for (list = CDR(list); CONSP(list); list = CDR(list)) { + CDR(cons) = CONS(NIL, NIL); + cons = CDR(cons); + if (CONSP(CAR(list))) { + switch (function) { + case COPY_LIST: + RPLACA(cons, CAR(list)); + break; + case COPY_ALIST: + RPLACA(cons, CONS(CAR(CAR(list)), CDR(CAR(list)))); + break; + case COPY_TREE: + RPLACA(cons, LispCopyList(builtin, CAR(list), COPY_TREE)); + break; + } + } + else + RPLACA(cons, CAR(list)); + } + /* in case list is dotted */ + RPLACD(cons, list); + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_CopyAlist(LispBuiltin *builtin) +/* + copy-alist list + */ +{ + LispObj *list; + + list = ARGUMENT(0); + + return (LispCopyList(builtin, list, COPY_ALIST)); +} + +LispObj * +Lisp_CopyList(LispBuiltin *builtin) +/* + copy-list list + */ +{ + LispObj *list; + + list = ARGUMENT(0); + + return (LispCopyList(builtin, list, COPY_LIST)); +} + +LispObj * +Lisp_CopyTree(LispBuiltin *builtin) +/* + copy-tree list + */ +{ + LispObj *list; + + list = ARGUMENT(0); + + return (LispCopyList(builtin, list, COPY_TREE)); +} + +LispObj * +Lisp_Cons(LispBuiltin *builtin) +/* + cons car cdr + */ +{ + LispObj *car, *cdr; + + cdr = ARGUMENT(1); + car = ARGUMENT(0); + + return (CONS(car, cdr)); +} + +LispObj * +Lisp_Consp(LispBuiltin *builtin) +/* + consp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (CONSP(object) ? T : NIL); +} + +LispObj * +Lisp_Constantp(LispBuiltin *builtin) +/* + constantp form &optional environment + */ +{ + LispObj *form, *environment; + + environment = ARGUMENT(1); + form = ARGUMENT(0); + + /* not all self-evaluating objects are considered constants */ + if (!POINTERP(form) || + NUMBERP(form) || + XQUOTEP(form) || + (XCONSP(form) && CAR(form) == Oquote) || + (XSYMBOLP(form) && form->data.atom->constant) || + XSTRINGP(form) || + XARRAYP(form)) + return (T); + + return (NIL); +} + +LispObj * +Lisp_Defconstant(LispBuiltin *builtin) +/* + defconstant name initial-value &optional documentation + */ +{ + LispObj *name, *initial_value, *documentation; + + documentation = ARGUMENT(2); + initial_value = ARGUMENT(1); + name = ARGUMENT(0); + + CHECK_SYMBOL(name); + if (documentation != UNSPEC) { + CHECK_STRING(documentation); + } + else + documentation = NIL; + LispDefconstant(name, EVAL(initial_value), documentation); + + return (name); +} + +LispObj * +Lisp_Defmacro(LispBuiltin *builtin) +/* + defmacro name lambda-list &rest body + */ +{ + LispArgList *alist; + + LispObj *lambda, *name, *lambda_list, *body; + + body = ARGUMENT(2); + lambda_list = ARGUMENT(1); + name = ARGUMENT(0); + + CHECK_SYMBOL(name); + alist = LispCheckArguments(LispMacro, lambda_list, ATOMID(name), 0); + + if (CONSP(body) && STRINGP(CAR(body))) { + LispAddDocumentation(name, CAR(body), LispDocFunction); + body = CDR(body); + } + + lambda_list = LispListProtectedArguments(alist); + lambda = LispNewLambda(name, body, lambda_list, LispMacro); + + if (name->data.atom->a_builtin || name->data.atom->a_compiled) { + if (name->data.atom->a_builtin) { + ERROR_CHECK_SPECIAL_FORM(name->data.atom); + } + /* redefining these may cause surprises if bytecode + * compiled functions references them */ + LispWarning("%s: %s is being redefined", STRFUN(builtin), ATOMID(name)); + + LispRemAtomBuiltinProperty(name->data.atom); + } + + LispSetAtomFunctionProperty(name->data.atom, lambda, alist); + LispUseArgList(alist); + + return (name); +} + +LispObj * +Lisp_Defun(LispBuiltin *builtin) +/* + defun name lambda-list &rest body + */ +{ + LispArgList *alist; + + LispObj *lambda, *name, *lambda_list, *body; + + body = ARGUMENT(2); + lambda_list = ARGUMENT(1); + name = ARGUMENT(0); + + CHECK_SYMBOL(name); + alist = LispCheckArguments(LispFunction, lambda_list, ATOMID(name), 0); + + if (CONSP(body) && STRINGP(CAR(body))) { + LispAddDocumentation(name, CAR(body), LispDocFunction); + body = CDR(body); + } + + lambda_list = LispListProtectedArguments(alist); + lambda = LispNewLambda(name, body, lambda_list, LispFunction); + + if (name->data.atom->a_builtin || name->data.atom->a_compiled) { + if (name->data.atom->a_builtin) { + ERROR_CHECK_SPECIAL_FORM(name->data.atom); + } + /* redefining these may cause surprises if bytecode + * compiled functions references them */ + LispWarning("%s: %s is being redefined", STRFUN(builtin), ATOMID(name)); + + LispRemAtomBuiltinProperty(name->data.atom); + } + LispSetAtomFunctionProperty(name->data.atom, lambda, alist); + LispUseArgList(alist); + + return (name); +} + +LispObj * +Lisp_Defsetf(LispBuiltin *builtin) +/* + defsetf function lambda-list &rest body + */ +{ + LispArgList *alist; + LispObj *obj; + LispObj *lambda, *function, *lambda_list, *store, *body; + + body = ARGUMENT(2); + lambda_list = ARGUMENT(1); + function = ARGUMENT(0); + + CHECK_SYMBOL(function); + + if (body == NIL || (CONSP(body) && STRINGP(CAR(body)))) { + if (!SYMBOLP(lambda_list)) + LispDestroy("%s: syntax error %s %s", + STRFUN(builtin), STROBJ(function), STROBJ(lambda_list)); + if (body != NIL) + LispAddDocumentation(function, CAR(body), LispDocSetf); + + LispSetAtomSetfProperty(function->data.atom, lambda_list, NULL); + + return (function); + } + + alist = LispCheckArguments(LispSetf, lambda_list, ATOMID(function), 0); + + store = CAR(body); + if (!CONSP(store)) + LispDestroy("%s: %s is a bad store value", + STRFUN(builtin), STROBJ(store)); + for (obj = store; CONSP(obj); obj = CDR(obj)) { + CHECK_SYMBOL(CAR(obj)); + } + + body = CDR(body); + if (CONSP(body) && STRINGP(CAR(body))) { + LispAddDocumentation(function, CAR(body), LispDocSetf); + body = CDR(body); + } + + lambda = LispNewLambda(function, body, store, LispSetf); + LispSetAtomSetfProperty(function->data.atom, lambda, alist); + LispUseArgList(alist); + + return (function); +} + +LispObj * +Lisp_Defparameter(LispBuiltin *builtin) +/* + defparameter name initial-value &optional documentation + */ +{ + LispObj *name, *initial_value, *documentation; + + documentation = ARGUMENT(2); + initial_value = ARGUMENT(1); + name = ARGUMENT(0); + + CHECK_SYMBOL(name); + if (documentation != UNSPEC) { + CHECK_STRING(documentation); + } + else + documentation = NIL; + + LispProclaimSpecial(name, EVAL(initial_value), documentation); + + return (name); +} + +LispObj * +Lisp_Defvar(LispBuiltin *builtin) +/* + defvar name &optional initial-value documentation + */ +{ + LispObj *name, *initial_value, *documentation; + + documentation = ARGUMENT(2); + initial_value = ARGUMENT(1); + name = ARGUMENT(0); + + CHECK_SYMBOL(name); + if (documentation != UNSPEC) { + CHECK_STRING(documentation); + } + else + documentation = NIL; + + LispProclaimSpecial(name, + initial_value != UNSPEC ? EVAL(initial_value) : NULL, + documentation); + + return (name); +} + +LispObj * +Lisp_Delete(LispBuiltin *builtin) +/* + delete item sequence &key from-end test test-not start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, DELETE, NONE)); +} + +LispObj * +Lisp_DeleteIf(LispBuiltin *builtin) +/* + delete-if predicate sequence &key from-end start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, DELETE, IF)); +} + +LispObj * +Lisp_DeleteIfNot(LispBuiltin *builtin) +/* + delete-if-not predicate sequence &key from-end start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, DELETE, IFNOT)); +} + +LispObj * +Lisp_DeleteDuplicates(LispBuiltin *builtin) +/* + delete-duplicates sequence &key from-end test test-not start end key + */ +{ + return (LispDeleteOrRemoveDuplicates(builtin, DELETE)); +} + +LispObj * +Lisp_Do(LispBuiltin *builtin) +/* + do init test &rest body + */ +{ + return (LispDo(builtin, 0)); +} + +LispObj * +Lisp_DoP(LispBuiltin *builtin) +/* + do* init test &rest body + */ +{ + return (LispDo(builtin, 1)); +} + +static LispDocType_t +LispDocumentationType(LispBuiltin *builtin, LispObj *type) +{ + Atom_id atom; + LispDocType_t doc_type = LispDocVariable; + + CHECK_SYMBOL(type); + atom = ATOMID(type); + + if (atom == Svariable) + doc_type = LispDocVariable; + else if (atom == Sfunction) + doc_type = LispDocFunction; + else if (atom == Sstructure) + doc_type = LispDocStructure; + else if (atom == Stype) + doc_type = LispDocType; + else if (atom == Ssetf) + doc_type = LispDocSetf; + else { + LispDestroy("%s: unknown documentation type %s", + STRFUN(builtin), STROBJ(type)); + /*NOTREACHED*/ + } + + return (doc_type); +} + +LispObj * +Lisp_Documentation(LispBuiltin *builtin) +/* + documentation symbol type + */ +{ + LispObj *symbol, *type; + + type = ARGUMENT(1); + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + /* type is checked in LispDocumentationType() */ + + return (LispGetDocumentation(symbol, LispDocumentationType(builtin, type))); +} + +LispObj * +Lisp_DoList(LispBuiltin *builtin) +{ + return (LispDoListTimes(builtin, 0)); +} + +LispObj * +Lisp_DoTimes(LispBuiltin *builtin) +{ + return (LispDoListTimes(builtin, 1)); +} + +LispObj * +Lisp_Elt(LispBuiltin *builtin) +/* + elt sequence index + svref sequence index + */ +{ + long offset, length; + LispObj *result, *sequence, *oindex; + + oindex = ARGUMENT(1); + sequence = ARGUMENT(0); + + length = LispLength(sequence); + + CHECK_INDEX(oindex); + offset = FIXNUM_VALUE(oindex); + + if (offset >= length) + LispDestroy("%s: index %ld too large for sequence length %ld", + STRFUN(builtin), offset, length); + + if (STRINGP(sequence)) + result = SCHAR(THESTR(sequence)[offset]); + else { + if (ARRAYP(sequence)) + sequence = sequence->data.array.list; + + for (; offset > 0; offset--, sequence = CDR(sequence)) + ; + result = CAR(sequence); + } + + return (result); +} + +LispObj * +Lisp_Endp(LispBuiltin *builtin) +/* + endp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + if (object == NIL) + return (T); + CHECK_CONS(object); + + return (NIL); +} + +LispObj * +Lisp_Eq(LispBuiltin *builtin) +/* + eq left right + */ +{ + LispObj *left, *right; + + right = ARGUMENT(1); + left = ARGUMENT(0); + + return (XEQ(left, right)); +} + +LispObj * +Lisp_Eql(LispBuiltin *builtin) +/* + eql left right + */ +{ + LispObj *left, *right; + + right = ARGUMENT(1); + left = ARGUMENT(0); + + return (XEQL(left, right)); +} + +LispObj * +Lisp_Equal(LispBuiltin *builtin) +/* + equal left right + */ +{ + LispObj *left, *right; + + right = ARGUMENT(1); + left = ARGUMENT(0); + + return (XEQUAL(left, right)); +} + +LispObj * +Lisp_Equalp(LispBuiltin *builtin) +/* + equalp left right + */ +{ + LispObj *left, *right; + + right = ARGUMENT(1); + left = ARGUMENT(0); + + return (XEQUALP(left, right)); +} + +LispObj * +Lisp_Error(LispBuiltin *builtin) +/* + error control-string &rest arguments + */ +{ + LispObj *string, *arglist; + + LispObj *control_string, *arguments; + + arguments = ARGUMENT(1); + control_string = ARGUMENT(0); + + arglist = CONS(NIL, CONS(control_string, arguments)); + GC_PROTECT(arglist); + string = APPLY(Oformat, arglist); + LispDestroy("%s", THESTR(string)); + /*NOTREACHED*/ + + /* No need to call GC_ENTER() and GC_LEAVE() macros */ + return (NIL); +} + +LispObj * +Lisp_Eval(LispBuiltin *builtin) +/* + eval form + */ +{ + int lex; + LispObj *form, *result; + + form = ARGUMENT(0); + + /* make sure eval form will not access local variables */ + lex = lisp__data.env.lex; + lisp__data.env.lex = lisp__data.env.length; + result = EVAL(form); + lisp__data.env.lex = lex; + + return (result); +} + +static LispObj * +LispEverySomeAnyNot(LispBuiltin *builtin, int function) +/* + every predicate sequence &rest more-sequences + some predicate sequence &rest more-sequences + notevery predicate sequence &rest more-sequences + notany predicate sequence &rest more-sequences + */ +{ + GC_ENTER(); + long i, j, length, count; + LispObj *result, *list, *item, *arguments, *acons, *value; + SeqInfo stk[8], *seqs; + + LispObj *predicate, *sequence, *more_sequences; + + more_sequences = ARGUMENT(2); + sequence = ARGUMENT(1); + predicate = ARGUMENT(0); + + count = 1; + length = LispLength(sequence); + for (list = more_sequences; CONSP(list); list = CDR(list), count++) { + i = LispLength(CAR(list)); + if (i < length) + length = i; + } + + result = function == EVERY || function == NOTANY ? T : NIL; + + /* if at least one sequence has length zero */ + if (length == 0) + return (result); + + if (count > sizeof(stk) / sizeof(stk[0])) + seqs = LispMalloc(count * sizeof(SeqInfo)); + else + seqs = &stk[0]; + + /* build information about sequences */ + SETSEQ(seqs[0], sequence); + for (i = 1, list = more_sequences; CONSP(list); list = CDR(list), i++) { + item = CAR(list); + SETSEQ(seqs[i], item); + } + + /* prepare argument list */ + arguments = acons = CONS(NIL, NIL); + GC_PROTECT(arguments); + for (i = 1; i < count; i++) { + RPLACD(acons, CONS(NIL, NIL)); + acons = CDR(acons); + } + + /* loop applying predicate in sequence elements */ + for (i = 0; i < length; i++) { + + /* build argument list */ + for (acons = arguments, j = 0; j < count; acons = CDR(acons), j++) { + if (seqs[j].type == LispString_t) + item = SCHAR(*seqs[j].data.string++); + else { + item = CAR(seqs[j].data.list); + seqs[j].data.list = CDR(seqs[j].data.list); + } + RPLACA(acons, item); + } + + /* apply predicate */ + value = APPLY(predicate, arguments); + + /* check if needs to terminate loop */ + if (value == NIL) { + if (function == EVERY) { + result = NIL; + break; + } + if (function == NOTEVERY) { + result = T; + break; + } + } + else { + if (function == SOME) { + result = value; + break; + } + if (function == NOTANY) { + result = NIL; + break; + } + } + } + + GC_LEAVE(); + if (seqs != &stk[0]) + LispFree(seqs); + + return (result); +} + +LispObj * +Lisp_Every(LispBuiltin *builtin) +/* + every predicate sequence &rest more-sequences + */ +{ + return (LispEverySomeAnyNot(builtin, EVERY)); +} + +LispObj * +Lisp_Some(LispBuiltin *builtin) +/* + some predicate sequence &rest more-sequences + */ +{ + return (LispEverySomeAnyNot(builtin, SOME)); +} + +LispObj * +Lisp_Notevery(LispBuiltin *builtin) +/* + notevery predicate sequence &rest more-sequences + */ +{ + return (LispEverySomeAnyNot(builtin, NOTEVERY)); +} + +LispObj * +Lisp_Notany(LispBuiltin *builtin) +/* + notany predicate sequence &rest more-sequences + */ +{ + return (LispEverySomeAnyNot(builtin, NOTANY)); +} + +LispObj * +Lisp_Fboundp(LispBuiltin *builtin) +/* + fboundp symbol + */ +{ + LispAtom *atom; + + LispObj *symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + + atom = symbol->data.atom; + if (atom->a_function || atom->a_builtin || atom->a_compiled) + return (T); + + return (NIL); +} + +LispObj * +Lisp_Find(LispBuiltin *builtin) +/* + find item sequence &key from-end test test-not start end key + */ +{ + return (LispFindOrPosition(builtin, FIND, NONE)); +} + +LispObj * +Lisp_FindIf(LispBuiltin *builtin) +/* + find-if predicate sequence &key from-end start end key + */ +{ + return (LispFindOrPosition(builtin, FIND, IF)); +} + +LispObj * +Lisp_FindIfNot(LispBuiltin *builtin) +/* + find-if-not predicate sequence &key from-end start end key + */ +{ + return (LispFindOrPosition(builtin, FIND, IFNOT)); +} + +LispObj * +Lisp_Fill(LispBuiltin *builtin) +/* + fill sequence item &key start end + */ +{ + long i, start, end, length; + + LispObj *sequence, *item, *ostart, *oend; + + oend = ARGUMENT(3); + ostart = ARGUMENT(2); + item = ARGUMENT(1); + sequence = ARGUMENT(0); + + LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, + &start, &end, &length); + + if (STRINGP(sequence)) { + int ch; + char *string = THESTR(sequence); + + CHECK_STRING_WRITABLE(sequence); + CHECK_SCHAR(item); + ch = SCHAR_VALUE(item); + for (i = start; i < end; i++) + string[i] = ch; + } + else { + LispObj *list; + + if (CONSP(sequence)) + list = sequence; + else + list = sequence->data.array.list; + + for (i = 0; i < start; i++, list = CDR(list)) + ; + for (; i < end; i++, list = CDR(list)) + RPLACA(list, item); + } + + return (sequence); +} + +LispObj * +Lisp_Fmakunbound(LispBuiltin *builtin) +/* + fmkaunbound symbol + */ +{ + LispObj *symbol; + + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + if (symbol->data.atom->a_function) + LispRemAtomFunctionProperty(symbol->data.atom); + else if (symbol->data.atom->a_builtin) + LispRemAtomBuiltinProperty(symbol->data.atom); + else if (symbol->data.atom->a_compiled) + LispRemAtomCompiledProperty(symbol->data.atom); + + return (symbol); +} + +LispObj * +Lisp_Funcall(LispBuiltin *builtin) +/* + funcall function &rest arguments + */ +{ + LispObj *result; + + LispObj *function, *arguments; + + arguments = ARGUMENT(1); + function = ARGUMENT(0); + + result = APPLY(function, arguments); + + return (result); +} + +LispObj * +Lisp_Functionp(LispBuiltin *builtin) +/* + functionp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (FUNCTIONP(object) || LAMBDAP(object) ? T : NIL); +} + +LispObj * +Lisp_Get(LispBuiltin *builtin) +/* + get symbol indicator &optional default + */ +{ + LispObj *result; + + LispObj *symbol, *indicator, *defalt; + + defalt = ARGUMENT(2); + indicator = ARGUMENT(1); + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + + result = LispGetAtomProperty(symbol->data.atom, indicator); + + if (result != NIL) + result = CAR(result); + else + result = defalt == UNSPEC ? NIL : defalt; + + return (result); +} + +/* + * ext::getenv + */ +LispObj * +Lisp_Getenv(LispBuiltin *builtin) +/* + getenv name + */ +{ + char *value; + + LispObj *name; + + name = ARGUMENT(0); + + CHECK_STRING(name); + value = getenv(THESTR(name)); + + return (value ? STRING(value) : NIL); +} + +LispObj * +Lisp_Gc(LispBuiltin *builtin) +/* + gc &optional car cdr + */ +{ + LispObj *car, *cdr; + + cdr = ARGUMENT(1); + car = ARGUMENT(0); + + LispGC(car, cdr); + + return (NIL); +} + +LispObj * +Lisp_Gensym(LispBuiltin *builtin) +/* + gensym &optional arg + */ +{ + char *preffix = "G", name[132]; + long counter = LONGINT_VALUE(Ogensym_counter->data.atom->property->value); + LispObj *symbol; + + LispObj *arg; + + arg = ARGUMENT(0); + if (arg != UNSPEC) { + if (STRINGP(arg)) + preffix = THESTR(arg); + else { + CHECK_INDEX(arg); + counter = FIXNUM_VALUE(arg); + } + } + snprintf(name, sizeof(name), "%s%ld", preffix, counter); + if (strlen(name) >= 128) + LispDestroy("%s: name %s too long", STRFUN(builtin), name); + Ogensym_counter->data.atom->property->value = INTEGER(counter + 1); + + symbol = UNINTERNED_ATOM(name); + symbol->data.atom->unreadable = !LispCheckAtomString(name); + + return (symbol); +} + +LispObj * +Lisp_Go(LispBuiltin *builtin) +/* + go tag + */ +{ + unsigned blevel = lisp__data.block.block_level; + + LispObj *tag; + + tag = ARGUMENT(0); + + while (blevel) { + LispBlock *block = lisp__data.block.block[--blevel]; + + if (block->type == LispBlockClosure) + /* if reached a function call */ + break; + if (block->type == LispBlockBody) { + lisp__data.block.block_ret = tag; + LispBlockUnwind(block); + BLOCKJUMP(block); + } + } + + LispDestroy("%s: no visible tagbody for %s", + STRFUN(builtin), STROBJ(tag)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +Lisp_If(LispBuiltin *builtin) +/* + if test then &optional else + */ +{ + LispObj *result, *test, *then, *oelse; + + oelse = ARGUMENT(2); + then = ARGUMENT(1); + test = ARGUMENT(0); + + test = EVAL(test); + if (test != NIL) + result = EVAL(then); + else if (oelse != UNSPEC) + result = EVAL(oelse); + else + result = NIL; + + return (result); +} + +LispObj * +Lisp_IgnoreErrors(LispBuiltin *builtin) +/* + ignore-erros &rest body + */ +{ + LispObj *result, **presult, **pbody; + int i, jumped, *pjumped; + LispBlock *block; + + /* interpreter state */ + GC_ENTER(); + int stack, lex, length; + + /* memory allocation */ + int mem_level; + void **mem; + + LispObj *body; + + body = ARGUMENT(0); + + /* Save environment information */ + stack = lisp__data.stack.length; + lex = lisp__data.env.lex; + length = lisp__data.env.length; + + /* Save memory allocation information */ + mem_level = lisp__data.mem.level; + mem = LispMalloc(mem_level * sizeof(void*)); + memcpy(mem, lisp__data.mem.mem, mem_level * sizeof(void*)); + + ++lisp__data.ignore_errors; + presult = &result; + pjumped = &jumped; + pbody = &body; + result = NIL; + jumped = 1; + block = LispBeginBlock(NIL, LispBlockProtect); + if (setjmp(block->jmp) == 0) { + for (; CONSP(body); body = CDR(body)) + result = EVAL(CAR(body)); + jumped = 0; + } + LispEndBlock(block); + if (!lisp__data.destroyed && jumped) + result = lisp__data.block.block_ret; + + if (lisp__data.destroyed) { + /* Restore environment */ + lisp__data.stack.length = stack; + lisp__data.env.lex = lex; + lisp__data.env.head = lisp__data.env.length = length; + GC_LEAVE(); + + /* Check for possible leaks due to ignoring errors */ + for (i = 0; i < mem_level; i++) { + if (lisp__data.mem.mem[i] && mem[i] != lisp__data.mem.mem[i]) + LispFree(lisp__data.mem.mem[i]); + } + for (; i < lisp__data.mem.level; i++) { + if (lisp__data.mem.mem[i]) + LispFree(lisp__data.mem.mem[i]); + } + + lisp__data.destroyed = 0; + result = NIL; + RETURN_COUNT = 1; + RETURN(0) = lisp__data.error_condition; + } + LispFree(mem); + --lisp__data.ignore_errors; + + return (result); +} + +LispObj * +Lisp_Intersection(LispBuiltin *builtin) +/* + intersection list1 list2 &key test test-not key + */ +{ + return (LispListSet(builtin, INTERSECTION)); +} + +LispObj * +Lisp_Nintersection(LispBuiltin *builtin) +/* + nintersection list1 list2 &key test test-not key + */ +{ + return (LispListSet(builtin, NINTERSECTION)); +} + +LispObj * +Lisp_Keywordp(LispBuiltin *builtin) +/* + keywordp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (KEYWORDP(object) ? T : NIL); +} + +LispObj * +Lisp_Lambda(LispBuiltin *builtin) +/* + lambda lambda-list &rest body + */ +{ + GC_ENTER(); + LispObj *name; + LispArgList *alist; + + LispObj *lambda, *lambda_list, *body; + + body = ARGUMENT(1); + lambda_list = ARGUMENT(0); + + alist = LispCheckArguments(LispLambda, lambda_list, Snil, 0); + + name = OPAQUE(alist, LispArgList_t); + lambda_list = LispListProtectedArguments(alist); + GC_PROTECT(name); + GC_PROTECT(lambda_list); + lambda = LispNewLambda(name, body, lambda_list, LispLambda); + LispUseArgList(alist); + GC_LEAVE(); + + return (lambda); +} + +LispObj * +Lisp_Last(LispBuiltin *builtin) +/* + last list &optional count + */ +{ + long count, length; + LispObj *list, *ocount; + + ocount = ARGUMENT(1); + list = ARGUMENT(0); + + if (!CONSP(list)) + return (list); + + length = LispLength(list); + + if (ocount == UNSPEC) + count = 1; + else { + CHECK_INDEX(ocount); + count = FIXNUM_VALUE(ocount); + } + + if (count >= length) + return (list); + + length -= count; + for (; length > 0; length--) + list = CDR(list); + + return (list); +} + +LispObj * +Lisp_Length(LispBuiltin *builtin) +/* + length sequence + */ +{ + LispObj *sequence; + + sequence = ARGUMENT(0); + + return (FIXNUM(LispLength(sequence))); +} + +LispObj * +Lisp_Let(LispBuiltin *builtin) +/* + let init &rest body + */ +{ + GC_ENTER(); + int head = lisp__data.env.length; + LispObj *init, *body, *pair, *result, *list, *cons = NIL; + + body = ARGUMENT(1); + init = ARGUMENT(0); + + CHECK_LIST(init); + for (list = NIL; CONSP(init); init = CDR(init)) { + LispObj *symbol, *value; + + pair = CAR(init); + if (SYMBOLP(pair)) { + symbol = pair; + value = NIL; + } + else { + CHECK_CONS(pair); + symbol = CAR(pair); + CHECK_SYMBOL(symbol); + pair = CDR(pair); + if (CONSP(pair)) { + value = CAR(pair); + if (CDR(pair) != NIL) + LispDestroy("%s: too much arguments to initialize %s", + STRFUN(builtin), STROBJ(symbol)); + value = EVAL(value); + } + else + value = NIL; + } + pair = CONS(symbol, value); + if (list == NIL) { + list = cons = CONS(pair, NIL); + GC_PROTECT(list); + } + else { + RPLACD(cons, CONS(pair, NIL)); + cons = CDR(cons); + } + } + /* Add variables */ + for (; CONSP(list); list = CDR(list)) { + pair = CAR(list); + CHECK_CONSTANT(CAR(pair)); + LispAddVar(CAR(pair), CDR(pair)); + ++lisp__data.env.head; + } + /* Values of symbols are now protected */ + GC_LEAVE(); + + /* execute body */ + for (result = NIL; CONSP(body); body = CDR(body)) + result = EVAL(CAR(body)); + + lisp__data.env.head = lisp__data.env.length = head; + + return (result); +} + +LispObj * +Lisp_LetP(LispBuiltin *builtin) +/* + let* init &rest body + */ +{ + int head = lisp__data.env.length; + LispObj *init, *body, *pair, *result; + + body = ARGUMENT(1); + init = ARGUMENT(0); + + CHECK_LIST(init); + for (; CONSP(init); init = CDR(init)) { + LispObj *symbol, *value; + + pair = CAR(init); + if (SYMBOLP(pair)) { + symbol = pair; + value = NIL; + } + else { + CHECK_CONS(pair); + symbol = CAR(pair); + CHECK_SYMBOL(symbol); + pair = CDR(pair); + if (CONSP(pair)) { + value = CAR(pair); + if (CDR(pair) != NIL) + LispDestroy("%s: too much arguments to initialize %s", + STRFUN(builtin), STROBJ(symbol)); + value = EVAL(value); + } + else + value = NIL; + } + + CHECK_CONSTANT(symbol); + LispAddVar(symbol, value); + ++lisp__data.env.head; + } + + /* execute body */ + for (result = NIL; CONSP(body); body = CDR(body)) + result = EVAL(CAR(body)); + + lisp__data.env.head = lisp__data.env.length = head; + + return (result); +} + +LispObj * +Lisp_List(LispBuiltin *builtin) +/* + list &rest args + */ +{ + LispObj *args; + + args = ARGUMENT(0); + + return (args); +} + +LispObj * +Lisp_ListP(LispBuiltin *builtin) +/* + list* object &rest more-objects + */ +{ + GC_ENTER(); + LispObj *result, *cons; + + LispObj *object, *more_objects; + + more_objects = ARGUMENT(1); + object = ARGUMENT(0); + + if (!CONSP(more_objects)) + return (object); + + result = cons = CONS(object, CAR(more_objects)); + GC_PROTECT(result); + for (more_objects = CDR(more_objects); CONSP(more_objects); + more_objects = CDR(more_objects)) { + object = CAR(more_objects); + RPLACD(cons, CONS(CDR(cons), object)); + cons = CDR(cons); + } + GC_LEAVE(); + + return (result); +} + +/* "classic" list-length */ +LispObj * +Lisp_ListLength(LispBuiltin *builtin) +/* + list-length list + */ +{ + long length; + LispObj *fast, *slow; + + LispObj *list; + + list = ARGUMENT(0); + + CHECK_LIST(list); + for (fast = slow = list, length = 0; + CONSP(slow); + slow = CDR(slow), length += 2) { + if (fast == NIL) + break; + CHECK_CONS(fast); + fast = CDR(fast); + if (fast == NIL) { + ++length; + break; + } + CHECK_CONS(fast); + fast = CDR(fast); + if (slow == fast) + /* circular list */ + return (NIL); + } + + return (FIXNUM(length)); +} + +LispObj * +Lisp_Listp(LispBuiltin *builtin) +/* + listp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (object == NIL || CONSP(object) ? T : NIL); +} + +static LispObj * +LispListSet(LispBuiltin *builtin, int function) +/* + intersection list1 list2 &key test test-not key + nintersection list1 list2 &key test test-not key + set-difference list1 list2 &key test test-not key + nset-difference list1 list2 &key test test-not key + set-exclusive-or list1 list2 &key test test-not key + nset-exclusive-or list1 list2 &key test test-not key + subsetp list1 list2 &key test test-not key + union list1 list2 &key test test-not key + nunion list1 list2 &key test test-not key + */ +{ + GC_ENTER(); + int code, expect, value, inplace, check_list2, + intersection, setdifference, xunion, setexclusiveor; + LispObj *lambda, *result, *cmp, *cmp1, *cmp2, + *item, *clist1, *clist2, *cons, *cdr; + + LispObj *list1, *list2, *test, *test_not, *key; + + key = ARGUMENT(4); + test_not = ARGUMENT(3); + test = ARGUMENT(2); + list2 = ARGUMENT(1); + list1 = ARGUMENT(0); + + /* Check if arguments are valid lists */ + CHECK_LIST(list1); + CHECK_LIST(list2); + + setdifference = intersection = xunion = setexclusiveor = inplace = 0; + switch (function) { + case NSETDIFFERENCE: + inplace = 1; + case SETDIFFERENCE: + setdifference = 1; + break; + case NINTERSECTION: + inplace = 1; + case INTERSECTION: + intersection = 1; + break; + case NUNION: + inplace = 1; + case UNION: + xunion = 1; + break; + case NSETEXCLUSIVEOR: + inplace = 1; + case SETEXCLUSIVEOR: + setexclusiveor = 1; + break; + } + + /* Check for fast return */ + if (list1 == NIL) + return (setdifference || intersection ? + NIL : function == SUBSETP ? T : list2); + if (list2 == NIL) + return (intersection || xunion || function == SUBSETP ? NIL : list1); + + CHECK_TEST(); + clist1 = cdr = NIL; + + /* Make a copy of list2 with the key predicate applied */ + if (key != UNSPEC) { + result = cons = CONS(APPLY1(key, CAR(list2)), NIL); + GC_PROTECT(result); + for (cmp2 = CDR(list2); CONSP(cmp2); cmp2 = CDR(cmp2)) { + item = APPLY1(key, CAR(cmp2)); + RPLACD(cons, CONS(APPLY1(key, CAR(cmp2)), NIL)); + cons = CDR(cons); + } + /* check if list2 is a proper list */ + CHECK_LIST(cmp2); + clist2 = result; + check_list2 = 0; + } + else { + clist2 = list2; + check_list2 = 1; + } + result = cons = NIL; + + /* Compare elements of lists + * Logic: + * UNION + * 1) Walk list1 and if CAR(list1) not in list2, add it to result + * 2) Add list2 to result + * INTERSECTION + * 1) Walk list1 and if CAR(list1) in list2, add it to result + * SET-DIFFERENCE + * 1) Walk list1 and if CAR(list1) not in list2, add it to result + * SET-EXCLUSIVE-OR + * 1) Walk list1 and if CAR(list1) not in list2, add it to result + * 2) Walk list2 and if CAR(list2) not in list1, add it to result + * SUBSETP + * 1) Walk list1 and if CAR(list1) not in list2, return NIL + * 2) Return T + */ + value = 0; + for (cmp1 = list1; CONSP(cmp1); cmp1 = CDR(cmp1)) { + item = CAR(cmp1); + + /* Apply key predicate if required */ + if (key != UNSPEC) { + cmp = APPLY1(key, item); + if (setexclusiveor) { + if (clist1 == NIL) { + clist1 = cdr = CONS(cmp, NIL); + GC_PROTECT(clist1); + } + else { + RPLACD(cdr, CONS(cmp, NIL)); + cdr = CDR(cdr); + } + } + } + else + cmp = item; + + /* Compare against list2 */ + for (cmp2 = clist2; CONSP(cmp2); cmp2 = CDR(cmp2)) { + value = FCOMPARE(lambda, cmp, CAR(cmp2), code); + if (value == expect) + break; + } + if (check_list2 && value != expect) { + /* check if list2 is a proper list */ + CHECK_LIST(cmp2); + check_list2 = 0; + } + + if (function == SUBSETP) { + /* Element of list1 not in list2? */ + if (value != expect) { + GC_LEAVE(); + + return (NIL); + } + } + /* If need to add item to result */ + else if (((setdifference || xunion || setexclusiveor) && + value != expect) || + (intersection && value == expect)) { + if (inplace) { + if (result == NIL) + result = cons = cmp1; + else { + if (setexclusiveor) { + /* don't remove elements yet, will need + * to check agains't list2 later */ + for (cmp2 = cons; CDR(cmp2) != cmp1; cmp2 = CDR(cmp2)) + ; + if (cmp2 != cons) { + RPLACD(cmp2, list1); + list1 = cmp2; + } + } + RPLACD(cons, cmp1); + cons = cmp1; + } + } + else { + if (result == NIL) { + result = cons = CONS(item, NIL); + GC_PROTECT(result); + } + else { + RPLACD(cons, CONS(item, NIL)); + cons = CDR(cons); + } + } + } + } + /* check if list1 is a proper list */ + CHECK_LIST(cmp1); + + if (function == SUBSETP) { + GC_LEAVE(); + + return (T); + } + else if (xunion) { + /* Add list2 to tail of result */ + if (result == NIL) + result = list2; + else + RPLACD(cons, list2); + } + else if (setexclusiveor) { + LispObj *result2, *cons2; + + result2 = cons2 = NIL; + for (cmp2 = list2; CONSP(cmp2); cmp2 = CDR(cmp2)) { + item = CAR(cmp2); + + if (key != UNSPEC) { + cmp = CAR(clist2); + /* XXX changing clist2 */ + clist2 = CDR(clist2); + cmp1 = clist1; + } + else { + cmp = item; + cmp1 = list1; + } + + /* Compare against list1 */ + for (; CONSP(cmp1); cmp1 = CDR(cmp1)) { + value = FCOMPARE(lambda, cmp, CAR(cmp1), code); + if (value == expect) + break; + } + + if (value != expect) { + if (inplace) { + if (result2 == NIL) + result2 = cons2 = cmp2; + else { + RPLACD(cons2, cmp2); + cons2 = cmp2; + } + } + else { + if (result == NIL) { + result = cons = CONS(item, NIL); + GC_PROTECT(result); + } + else { + RPLACD(cons, CONS(item, NIL)); + cons = CDR(cons); + } + } + } + } + if (inplace) { + if (CONSP(cons2)) + RPLACD(cons2, NIL); + if (result == NIL) + result = result2; + else + RPLACD(cons, result2); + } + } + else if ((function == NSETDIFFERENCE || function == NINTERSECTION) && + CONSP(cons)) + RPLACD(cons, NIL); + + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Loop(LispBuiltin *builtin) +/* + loop &rest body + */ +{ + LispObj *code, *result; + LispBlock *block; + + LispObj *body; + + body = ARGUMENT(0); + + result = NIL; + block = LispBeginBlock(NIL, LispBlockTag); + if (setjmp(block->jmp) == 0) { + for (;;) + for (code = body; CONSP(code); code = CDR(code)) + (void)EVAL(CAR(code)); + } + LispEndBlock(block); + result = lisp__data.block.block_ret; + + return (result); +} + +/* XXX This function is broken, needs a review + (being delayed until true array/vectors be implemented) */ +LispObj * +Lisp_MakeArray(LispBuiltin *builtin) +/* + make-array dimensions &key element-type initial-element initial-contents + adjustable fill-pointer displaced-to + displaced-index-offset + */ +{ + long rank = 0, count = 1, offset, zero, c; + LispObj *obj, *dim, *array; + LispType type; + + LispObj *dimensions, *element_type, *initial_element, *initial_contents, + *adjustable, *fill_pointer, *displaced_to, + *displaced_index_offset; + + dim = array = NIL; + type = LispNil_t; + + displaced_index_offset = ARGUMENT(7); + displaced_to = ARGUMENT(6); + fill_pointer = ARGUMENT(5); + adjustable = ARGUMENT(4); + initial_contents = ARGUMENT(3); + initial_element = ARGUMENT(2); + element_type = ARGUMENT(1); + dimensions = ARGUMENT(0); + + if (INDEXP(dimensions)) { + dim = CONS(dimensions, NIL); + rank = 1; + count = FIXNUM_VALUE(dimensions); + } + else if (CONSP(dimensions)) { + dim = dimensions; + + for (rank = 0; CONSP(dim); rank++, dim = CDR(dim)) { + obj = CAR(dim); + CHECK_INDEX(obj); + count *= FIXNUM_VALUE(obj); + } + dim = dimensions; + } + else if (dimensions == NIL) { + dim = NIL; + rank = count = 0; + } + else + LispDestroy("%s: %s is a bad array dimension", + STRFUN(builtin), STROBJ(dimensions)); + + /* check element-type */ + if (element_type != UNSPEC) { + if (element_type == T) + type = LispNil_t; + else if (!SYMBOLP(element_type)) + LispDestroy("%s: unsupported element type %s", + STRFUN(builtin), STROBJ(element_type)); + else { + Atom_id atom = ATOMID(element_type); + + if (atom == Satom) + type = LispAtom_t; + else if (atom == Sinteger) + type = LispInteger_t; + else if (atom == Scharacter) + type = LispSChar_t; + else if (atom == Sstring) + type = LispString_t; + else if (atom == Slist) + type = LispCons_t; + else if (atom == Sopaque) + type = LispOpaque_t; + else + LispDestroy("%s: unsupported element type %s", + STRFUN(builtin), ATOMID(element_type)); + } + } + + /* check initial-contents */ + if (rank) { + CHECK_LIST(initial_contents); + } + + /* check displaced-to */ + if (displaced_to != UNSPEC) { + CHECK_ARRAY(displaced_to); + } + + /* check displaced-index-offset */ + offset = -1; + if (displaced_index_offset != UNSPEC) { + CHECK_INDEX(displaced_index_offset); + offset = FIXNUM_VALUE(displaced_index_offset); + } + + c = 0; + if (initial_element != UNSPEC) + ++c; + if (initial_contents != UNSPEC) + ++c; + if (displaced_to != UNSPEC || offset >= 0) + ++c; + if (c > 1) + LispDestroy("%s: more than one initialization specified", + STRFUN(builtin)); + if (initial_element == UNSPEC) + initial_element = NIL; + + zero = count == 0; + if (displaced_to != UNSPEC) { + CHECK_ARRAY(displaced_to); + if (offset < 0) + offset = 0; + for (c = 1, obj = displaced_to->data.array.dim; obj != NIL; + obj = CDR(obj)) + c *= FIXNUM_VALUE(CAR(obj)); + if (c < count + offset) + LispDestroy("%s: array-total-size + displaced-index-offset " + "exceeds total size", STRFUN(builtin)); + for (c = 0, array = displaced_to->data.array.list; c < offset; c++) + array = CDR(array); + } + else if (initial_contents != UNSPEC) { + CHECK_CONS(initial_contents); + if (rank == 0) + array = initial_contents; + else if (rank == 1) { + for (array = initial_contents, c = 0; c < count; + array = CDR(array), c++) + if (!CONSP(array)) + LispDestroy("%s: bad argument or size %s", + STRFUN(builtin), STROBJ(array)); + if (array != NIL) + LispDestroy("%s: bad argument or size %s", + STRFUN(builtin), STROBJ(array)); + array = initial_contents; + } + else { + LispObj *err = NIL; + /* check if list matches */ + int i, j, k, *dims, *loop; + + /* create iteration variables */ + dims = LispMalloc(sizeof(int) * rank); + loop = LispCalloc(1, sizeof(int) * (rank - 1)); + for (i = 0, obj = dim; CONSP(obj); i++, obj = CDR(obj)) + dims[i] = FIXNUM_VALUE(CAR(obj)); + + /* check if list matches specified dimensions */ + while (loop[0] < dims[0]) { + for (obj = initial_contents, i = 0; i < rank - 1; i++) { + for (j = 0; j < loop[i]; j++) + obj = CDR(obj); + err = obj; + if (!CONSP(obj = CAR(obj))) + goto make_array_error; + err = obj; + } + --i; + for (;;) { + ++loop[i]; + if (i && loop[i] >= dims[i]) + loop[i] = 0; + else + break; + --i; + } + for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) { + if (!CONSP(obj)) + goto make_array_error; + } + if (obj == NIL) + continue; +make_array_error: + LispFree(dims); + LispFree(loop); + LispDestroy("%s: bad argument or size %s", + STRFUN(builtin), STROBJ(err)); + } + + /* list is correct, use it to fill initial values */ + + /* reset loop */ + memset(loop, 0, sizeof(int) * (rank - 1)); + + GCDisable(); + /* fill array with supplied values */ + array = NIL; + while (loop[0] < dims[0]) { + for (obj = initial_contents, i = 0; i < rank - 1; i++) { + for (j = 0; j < loop[i]; j++) + obj = CDR(obj); + obj = CAR(obj); + } + --i; + for (;;) { + ++loop[i]; + if (i && loop[i] >= dims[i]) + loop[i] = 0; + else + break; + --i; + } + for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) { + if (array == NIL) + array = CONS(CAR(obj), NIL); + else { + RPLACD(array, CONS(CAR(array), CDR(array))); + RPLACA(array, CAR(obj)); + } + } + } + LispFree(dims); + LispFree(loop); + array = LispReverse(array); + GCEnable(); + } + } + else { + GCDisable(); + /* allocate array */ + if (count) { + --count; + array = CONS(initial_element, NIL); + while (count) { + RPLACD(array, CONS(CAR(array), CDR(array))); + RPLACA(array, initial_element); + count--; + } + } + GCEnable(); + } + + obj = LispNew(array, dim); + obj->type = LispArray_t; + obj->data.array.list = array; + obj->data.array.dim = dim; + obj->data.array.rank = rank; + obj->data.array.type = type; + obj->data.array.zero = zero; + + return (obj); +} + +LispObj * +Lisp_MakeList(LispBuiltin *builtin) +/* + make-list size &key initial-element + */ +{ + GC_ENTER(); + long count; + LispObj *result, *cons; + + LispObj *size, *initial_element; + + initial_element = ARGUMENT(1); + size = ARGUMENT(0); + + CHECK_INDEX(size); + count = FIXNUM_VALUE(size); + + if (count == 0) + return (NIL); + if (initial_element == UNSPEC) + initial_element = NIL; + + result = cons = CONS(initial_element, NIL); + GC_PROTECT(result); + for (; count > 1; count--) { + RPLACD(cons, CONS(initial_element, NIL)); + cons = CDR(cons); + } + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_MakeSymbol(LispBuiltin *builtin) +/* + make-symbol name + */ +{ + LispObj *name, *symbol; + + name = ARGUMENT(0); + CHECK_STRING(name); + + symbol = UNINTERNED_ATOM(THESTR(name)); + symbol->data.atom->unreadable = !LispCheckAtomString(THESTR(name)); + + return (symbol); +} + +LispObj * +Lisp_Makunbound(LispBuiltin *builtin) +/* + makunbound symbol + */ +{ + LispObj *symbol; + + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + LispUnsetVar(symbol); + + return (symbol); +} + +LispObj * +Lisp_Mapc(LispBuiltin *builtin) +/* + mapc function list &rest more-lists + */ +{ + return (LispMapc(builtin, 0)); +} + +LispObj * +Lisp_Mapcar(LispBuiltin *builtin) +/* + mapcar function list &rest more-lists + */ +{ + return (LispMapc(builtin, 1)); +} + +/* Like nconc but ignore non list arguments */ +LispObj * +LispMapnconc(LispObj *list) +{ + LispObj *result = NIL; + + if (CONSP(list)) { + LispObj *cons, *head, *tail; + + cons = NIL; + for (; CONSP(CDR(list)); list = CDR(list)) { + head = CAR(list); + if (CONSP(head)) { + for (tail = head; CONSP(CDR(tail)); tail = CDR(tail)) + ; + if (cons != NIL) + RPLACD(cons, head); + else + result = head; + cons = tail; + } + } + head = CAR(list); + if (CONSP(head)) { + if (cons != NIL) + RPLACD(cons, head); + else + result = head; + } + } + + return (result); +} + +LispObj * +Lisp_Mapcan(LispBuiltin *builtin) +/* + mapcan function list &rest more-lists + */ +{ + return (LispMapnconc(LispMapc(builtin, 1))); +} + +static LispObj * +LispMapc(LispBuiltin *builtin, int mapcar) +{ + GC_ENTER(); + long i, offset, count, length; + LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value; + LispObj *stk[8], **cdrs; + + LispObj *function, *list, *more_lists; + + more_lists = ARGUMENT(2); + list = ARGUMENT(1); + function = ARGUMENT(0); + + /* Result will be no longer than this */ + for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist)) + ; + + /* If first argument is not a list... */ + if (length == 0) + return (NIL); + + /* At least one argument will be passed to function, count how many + * extra arguments will be used, and calculate result length. */ + count = 0; + for (rest = more_lists; CONSP(rest); rest = CDR(rest), count++) { + + /* Check if extra list is really a list, and if it is smaller + * than the first list */ + for (i = 0, alist = CAR(rest); + i < length && CONSP(alist); + i++, alist = CDR(alist)) + ; + + /* If it is not a true list */ + if (i == 0) + return (NIL); + + /* If it is smaller than the currently calculated result length */ + if (i < length) + length = i; + } + + if (mapcar) { + /* Initialize gc protected object cells for resulting list */ + result = cons = CONS(NIL, NIL); + GC_PROTECT(result); + } + else + result = cons = list; + + if (count >= sizeof(stk) / sizeof(stk[0])) + cdrs = LispMalloc(count * sizeof(LispObj*)); + else + cdrs = &stk[0]; + for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest)) + cdrs[i] = CAR(rest); + + /* Initialize gc protected object cells for argument list */ + arguments = acons = CONS(NIL, NIL); + GC_PROTECT(arguments); + + /* Allocate space for extra arguments */ + for (i = 0; i < count; i++) { + RPLACD(acons, CONS(NIL, NIL)); + acons = CDR(acons); + } + + /* For every element of the list that will be used */ + for (offset = 0;; list = CDR(list)) { + acons = arguments; + + /* Add first argument */ + RPLACA(acons, CAR(list)); + acons = CDR(acons); + + /* For every extra list argument */ + for (i = 0; i < count; i++) { + alist = cdrs[i]; + cdrs[i] = CDR(cdrs[i]); + + /* Add element to argument list */ + RPLACA(acons, CAR(alist)); + acons = CDR(acons); + } + + value = APPLY(function, arguments); + + if (mapcar) { + /* Store result */ + RPLACA(cons, value); + + /* Allocate new result cell */ + if (++offset < length) { + RPLACD(cons, CONS(NIL, NIL)); + cons = CDR(cons); + } + else + break; + } + else if (++offset >= length) + break; + } + + /* Unprotect argument and result list */ + GC_LEAVE(); + if (cdrs != &stk[0]) + LispFree(cdrs); + + return (result); +} + +static LispObj * +LispMapl(LispBuiltin *builtin, int maplist) +{ + GC_ENTER(); + long i, offset, count, length; + LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value; + LispObj *stk[8], **cdrs; + + LispObj *function, *list, *more_lists; + + more_lists = ARGUMENT(2); + list = ARGUMENT(1); + function = ARGUMENT(0); + + /* count is the number of lists, length is the length of the result */ + for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist)) + ; + + /* first argument is not a list */ + if (length == 0) + return (NIL); + + /* check remaining arguments */ + for (count = 0, rest = more_lists; CONSP(rest); rest = CDR(rest), count++) { + for (i = 0, alist = CAR(rest); + i < length && CONSP(alist); + i++, alist = CDR(alist)) + ; + /* argument is not a list */ + if (i == 0) + return (NIL); + /* result will have the length of the smallest list */ + if (i < length) + length = i; + } + + /* result will be a list */ + if (maplist) { + result = cons = CONS(NIL, NIL); + GC_PROTECT(result); + } + else + result = cons = list; + + if (count >= sizeof(stk) / sizeof(stk[0])) + cdrs = LispMalloc(count * sizeof(LispObj*)); + else + cdrs = &stk[0]; + for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest)) + cdrs[i] = CAR(rest); + + /* initialize argument list */ + arguments = acons = CONS(NIL, NIL); + GC_PROTECT(arguments); + for (i = 0; i < count; i++) { + RPLACD(acons, CONS(NIL, NIL)); + acons = CDR(acons); + } + + /* for every used list element */ + for (offset = 0;; list = CDR(list)) { + acons = arguments; + + /* first argument */ + RPLACA(acons, list); + acons = CDR(acons); + + /* for every extra list */ + for (i = 0; i < count; i++) { + RPLACA(acons, cdrs[i]); + cdrs[i] = CDR(cdrs[i]); + acons = CDR(acons); + } + + value = APPLY(function, arguments); + + if (maplist) { + /* store result */ + RPLACA(cons, value); + + /* allocate new cell */ + if (++offset < length) { + RPLACD(cons, CONS(NIL, NIL)); + cons = CDR(cons); + } + else + break; + } + else if (++offset >= length) + break; + } + + GC_LEAVE(); + if (cdrs != &stk[0]) + LispFree(cdrs); + + return (result); +} + +LispObj * +Lisp_Mapl(LispBuiltin *builtin) +/* + mapl function list &rest more-lists + */ +{ + return (LispMapl(builtin, 0)); +} + +LispObj * +Lisp_Maplist(LispBuiltin *builtin) +/* + maplist function list &rest more-lists + */ +{ + return (LispMapl(builtin, 1)); +} + +LispObj * +Lisp_Mapcon(LispBuiltin *builtin) +/* + mapcon function list &rest more-lists + */ +{ + return (LispMapnconc(LispMapl(builtin, 1))); +} + +LispObj * +Lisp_Member(LispBuiltin *builtin) +/* + member item list &key test test-not key + */ +{ + int code, expect; + LispObj *compare, *lambda; + LispObj *item, *list, *test, *test_not, *key; + + key = ARGUMENT(4); + test_not = ARGUMENT(3); + test = ARGUMENT(2); + list = ARGUMENT(1); + item = ARGUMENT(0); + + if (list == NIL) + return (NIL); + CHECK_CONS(list); + + CHECK_TEST(); + if (key == UNSPEC) { + if (code == FEQ) { + for (; CONSP(list); list = CDR(list)) + if (item == CAR(list)) + return (list); + } + else { + for (; CONSP(list); list = CDR(list)) + if (FCOMPARE(lambda, item, CAR(list), code) == expect) + return (list); + } + } + else { + if (code == FEQ) { + for (; CONSP(list); list = CDR(list)) + if (item == APPLY1(key, CAR(list))) + return (list); + } + else { + for (; CONSP(list); list = CDR(list)) { + compare = APPLY1(key, CAR(list)); + if (FCOMPARE(lambda, item, compare, code) == expect) + return (list); + } + } + } + /* check if is a proper list */ + CHECK_LIST(list); + + return (NIL); +} + +LispObj * +Lisp_MemberIf(LispBuiltin *builtin) +/* + member-if predicate list &key key + */ +{ + return (LispAssocOrMember(builtin, MEMBER, IF)); +} + +LispObj * +Lisp_MemberIfNot(LispBuiltin *builtin) +/* + member-if-not predicate list &key key + */ +{ + return (LispAssocOrMember(builtin, MEMBER, IFNOT)); +} + +LispObj * +Lisp_MultipleValueBind(LispBuiltin *builtin) +/* + multiple-value-bind symbols values &rest body + */ +{ + int i, head = lisp__data.env.length; + LispObj *result, *symbol, *value; + + LispObj *symbols, *values, *body; + + body = ARGUMENT(2); + values = ARGUMENT(1); + symbols = ARGUMENT(0); + + result = EVAL(values); + for (i = -1; CONSP(symbols); symbols = CDR(symbols), i++) { + symbol = CAR(symbols); + CHECK_SYMBOL(symbol); + CHECK_CONSTANT(symbol); + if (i >= 0 && i < RETURN_COUNT) + value = RETURN(i); + else if (i < 0) + value = result; + else + value = NIL; + LispAddVar(symbol, value); + ++lisp__data.env.head; + } + + /* Execute code with binded variables (if any) */ + for (result = NIL; CONSP(body); body = CDR(body)) + result = EVAL(CAR(body)); + + lisp__data.env.head = lisp__data.env.length = head; + + return (result); +} + +LispObj * +Lisp_MultipleValueCall(LispBuiltin *builtin) +/* + multiple-value-call function &rest form + */ +{ + GC_ENTER(); + int i; + LispObj *arguments, *cons, *result; + + LispObj *function, *form; + + form = ARGUMENT(1); + function = ARGUMENT(0); + + /* build argument list */ + arguments = cons = NIL; + for (; CONSP(form); form = CDR(form)) { + RETURN_COUNT = 0; + result = EVAL(CAR(form)); + if (RETURN_COUNT >= 0) { + if (arguments == NIL) { + arguments = cons = CONS(result, NIL); + GC_PROTECT(arguments); + } + else { + RPLACD(cons, CONS(result, NIL)); + cons = CDR(cons); + } + for (i = 0; i < RETURN_COUNT; i++) { + RPLACD(cons, CONS(RETURN(i), NIL)); + cons = CDR(cons); + } + } + } + + /* apply function */ + if (POINTERP(function) && !XSYMBOLP(function) && !XFUNCTIONP(function)) { + function = EVAL(function); + GC_PROTECT(function); + } + result = APPLY(function, arguments); + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_MultipleValueProg1(LispBuiltin *builtin) +/* + multiple-value-prog1 first-form &rest form + */ +{ + GC_ENTER(); + int i, count; + LispObj *values, *cons; + + LispObj *first_form, *form; + + form = ARGUMENT(1); + first_form = ARGUMENT(0); + + values = EVAL(first_form); + if (!CONSP(form)) + return (values); + + cons = NIL; + count = RETURN_COUNT; + if (count < 0) + values = NIL; + else if (count == 0) { + GC_PROTECT(values); + } + else { + values = cons = CONS(values, NIL); + GC_PROTECT(values); + for (i = 0; i < count; i++) { + RPLACD(cons, CONS(RETURN(i), NIL)); + cons = CDR(cons); + } + } + + for (; CONSP(form); form = CDR(form)) + EVAL(CAR(form)); + + RETURN_COUNT = count; + if (count > 0) { + for (i = 0, cons = CDR(values); CONSP(cons); cons = CDR(cons), i++) + RETURN(i) = CAR(cons); + values = CAR(values); + } + GC_LEAVE(); + + return (values); +} + +LispObj * +Lisp_MultipleValueList(LispBuiltin *builtin) +/* + multiple-value-list form + */ +{ + int i; + GC_ENTER(); + LispObj *form, *result, *cons; + + form = ARGUMENT(0); + + result = EVAL(form); + + if (RETURN_COUNT < 0) + return (NIL); + + result = cons = CONS(result, NIL); + GC_PROTECT(result); + for (i = 0; i < RETURN_COUNT; i++) { + RPLACD(cons, CONS(RETURN(i), NIL)); + cons = CDR(cons); + } + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_MultipleValueSetq(LispBuiltin *builtin) +/* + multiple-value-setq symbols form + */ +{ + int i; + LispObj *result, *symbol, *value; + + LispObj *symbols, *form; + + form = ARGUMENT(1); + symbols = ARGUMENT(0); + + CHECK_LIST(symbols); + result = EVAL(form); + if (CONSP(symbols)) { + symbol = CAR(symbols); + CHECK_SYMBOL(symbol); + CHECK_CONSTANT(symbol); + LispSetVar(symbol, result); + symbols = CDR(symbols); + } + for (i = 0; CONSP(symbols); symbols = CDR(symbols), i++) { + symbol = CAR(symbols); + CHECK_SYMBOL(symbol); + CHECK_CONSTANT(symbol); + if (i < RETURN_COUNT && RETURN_COUNT > 0) + value = RETURN(i); + else + value = NIL; + LispSetVar(symbol, value); + } + + return (result); +} + +LispObj * +Lisp_Nconc(LispBuiltin *builtin) +/* + nconc &rest lists + */ +{ + LispObj *list, *lists, *cons, *head, *tail; + + lists = ARGUMENT(0); + + /* skip any initial empty lists */ + for (; CONSP(lists); lists = CDR(lists)) + if (CAR(lists) != NIL) + break; + + /* don't check if a proper list */ + if (!CONSP(lists)) + return (lists); + + /* setup to concatenate lists */ + list = CAR(lists); + CHECK_CONS(list); + for (cons = list; CONSP(CDR(cons)); cons = CDR(cons)) + ; + + /* if only two lists */ + lists = CDR(lists); + if (!CONSP(lists)) { + RPLACD(cons, lists); + + return (list); + } + + /* concatenate */ + for (; CONSP(CDR(lists)); lists = CDR(lists)) { + head = CAR(lists); + if (head == NIL) + continue; + CHECK_CONS(head); + for (tail = head; CONSP(CDR(tail)); tail = CDR(tail)) + ; + RPLACD(cons, head); + cons = tail; + } + /* add last list */ + RPLACD(cons, CAR(lists)); + + return (list); +} + +LispObj * +Lisp_Nreverse(LispBuiltin *builtin) +/* + nreverse sequence + */ +{ + return (LispXReverse(builtin, 1)); +} + +LispObj * +Lisp_NsetDifference(LispBuiltin *builtin) +/* + nset-difference list1 list2 &key test test-not key + */ +{ + return (LispListSet(builtin, NSETDIFFERENCE)); +} + +LispObj * +Lisp_Nsubstitute(LispBuiltin *builtin) +/* + nsubstitute newitem olditem sequence &key from-end test test-not start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, NONE)); +} + +LispObj * +Lisp_NsubstituteIf(LispBuiltin *builtin) +/* + nsubstitute-if newitem test sequence &key from-end start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IF)); +} + +LispObj * +Lisp_NsubstituteIfNot(LispBuiltin *builtin) +/* + nsubstitute-if-not newitem test sequence &key from-end start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IFNOT)); +} + +LispObj * +Lisp_Nth(LispBuiltin *builtin) +/* + nth index list + */ +{ + long position; + LispObj *oindex, *list; + + list = ARGUMENT(1); + oindex = ARGUMENT(0); + + CHECK_INDEX(oindex); + position = FIXNUM_VALUE(oindex); + + if (list == NIL) + return (NIL); + + CHECK_CONS(list); + for (; position > 0; position--) { + if (!CONSP(list)) + return (NIL); + list = CDR(list); + } + + return (CONSP(list) ? CAR(list) : NIL); +} + +LispObj * +Lisp_Nthcdr(LispBuiltin *builtin) +/* + nthcdr index list + */ +{ + long position; + LispObj *oindex, *list; + + list = ARGUMENT(1); + oindex = ARGUMENT(0); + + CHECK_INDEX(oindex); + position = FIXNUM_VALUE(oindex); + + if (list == NIL) + return (NIL); + CHECK_CONS(list); + + for (; position > 0; position--) { + if (!CONSP(list)) + return (NIL); + list = CDR(list); + } + + return (list); +} + +LispObj * +Lisp_NthValue(LispBuiltin *builtin) +/* + nth-value index form + */ +{ + long i; + LispObj *oindex, *form, *result; + + form = ARGUMENT(1); + oindex = ARGUMENT(0); + + oindex = EVAL(oindex); + CHECK_INDEX(oindex); + i = FIXNUM_VALUE(oindex) - 1; + + result = EVAL(form); + if (RETURN_COUNT < 0 || i >= RETURN_COUNT) + result = NIL; + else if (i >= 0) + result = RETURN(i); + + return (result); +} + +LispObj * +Lisp_Null(LispBuiltin *builtin) +/* + null list + */ +{ + LispObj *list; + + list = ARGUMENT(0); + + return (list == NIL ? T : NIL); +} + +LispObj * +Lisp_Or(LispBuiltin *builtin) +/* + or &rest args + */ +{ + LispObj *result = NIL, *args; + + args = ARGUMENT(0); + + for (; CONSP(args); args = CDR(args)) { + result = EVAL(CAR(args)); + if (result != NIL) + break; + } + + return (result); +} + +LispObj * +Lisp_Pairlis(LispBuiltin *builtin) +/* + pairlis key data &optional alist + */ +{ + LispObj *result, *cons; + + LispObj *key, *data, *alist; + + alist = ARGUMENT(2); + data = ARGUMENT(1); + key = ARGUMENT(0); + + if (CONSP(key) && CONSP(data)) { + GC_ENTER(); + + result = cons = CONS(CONS(CAR(key), CAR(data)), NIL); + GC_PROTECT(result); + key = CDR(key); + data = CDR(data); + for (; CONSP(key) && CONSP(data); key = CDR(key), data = CDR(data)) { + RPLACD(cons, CONS(CONS(CAR(key), CAR(data)), NIL)); + cons = CDR(cons); + } + if (CONSP(key) || CONSP(data)) + LispDestroy("%s: different length lists", STRFUN(builtin)); + GC_LEAVE(); + if (alist != UNSPEC) + RPLACD(cons, alist); + } + else + result = alist == UNSPEC ? NIL : alist; + + return (result); +} + +static LispObj * +LispFindOrPosition(LispBuiltin *builtin, + int function, int comparison) +/* + find item sequence &key from-end test test-not start end key + find-if predicate sequence &key from-end start end key + find-if-not predicate sequence &key from-end start end key + position item sequence &key from-end test test-not start end key + position-if predicate sequence &key from-end start end key + position-if-not predicate sequence &key from-end start end key + */ +{ + int code = 0, istring, expect, value; + char *string = NULL; + long offset = -1, start, end, length, i = comparison == NONE ? 7 : 5; + LispObj *cmp, *element, **objects = NULL; + + LispObj *item, *predicate, *sequence, *from_end, + *test, *test_not, *ostart, *oend, *key; + + key = ARGUMENT(i); --i; + oend = ARGUMENT(i); --i; + ostart = ARGUMENT(i); --i; + if (comparison == NONE) { + test_not = ARGUMENT(i); --i; + test = ARGUMENT(i); --i; + } + else + test_not = test = UNSPEC; + from_end = ARGUMENT(i); --i; + if (from_end == UNSPEC) + from_end = NIL; + sequence = ARGUMENT(i); --i; + if (comparison == NONE) { + item = ARGUMENT(i); + predicate = Oeql; + } + else { + predicate = ARGUMENT(i); + item = NIL; + } + + LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, + &start, &end, &length); + + if (sequence == NIL) + return (NIL); + + /* Cannot specify both :test and :test-not */ + if (test != UNSPEC && test_not != UNSPEC) + LispDestroy("%s: specify either :TEST or :TEST-NOT", STRFUN(builtin)); + + expect = 1; + if (comparison == NONE) { + if (test != UNSPEC) + predicate = test; + else if (test_not != UNSPEC) { + predicate = test_not; + expect = 0; + } + FUNCTION_CHECK(predicate); + code = FCODE(predicate); + } + + cmp = element = NIL; + istring = STRINGP(sequence); + if (istring) + string = THESTR(sequence); + else { + if (!CONSP(sequence)) + sequence = sequence->data.array.list; + for (i = 0; i < start; i++) + sequence = CDR(sequence); + } + + if ((length = end - start) == 0) + return (NIL); + + if (from_end != NIL && !istring) { + objects = LispMalloc(sizeof(LispObj*) * length); + for (i = length - 1; i >= 0; i--, sequence = CDR(sequence)) + objects[i] = CAR(sequence); + } + + for (i = 0; i < length; i++) { + if (istring) + element = SCHAR(string[from_end == NIL ? i + start : end - i - 1]); + else + element = from_end == NIL ? CAR(sequence) : objects[i]; + + if (key != UNSPEC) + cmp = APPLY1(key, element); + else + cmp = element; + + /* Update list */ + if (!istring && from_end == NIL) + sequence = CDR(sequence); + + if (comparison == NONE) + value = FCOMPARE(predicate, item, cmp, code); + else + value = APPLY1(predicate, cmp) != NIL; + + if ((!value && + (comparison == IFNOT || + (comparison == NONE && !expect))) || + (value && + (comparison == IF || + (comparison == NONE && expect)))) { + offset = from_end == NIL ? i + start : end - i - 1; + break; + } + } + + if (from_end != NIL && !istring) + LispFree(objects); + + return (offset == -1 ? NIL : function == FIND ? element : FIXNUM(offset)); +} + +LispObj * +Lisp_Pop(LispBuiltin *builtin) +/* + pop place + */ +{ + LispObj *result, *value; + + LispObj *place; + + place = ARGUMENT(0); + + if (SYMBOLP(place)) { + result = LispGetVar(place); + if (result == NULL) + LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); + CHECK_CONSTANT(place); + if (result != NIL) { + CHECK_CONS(result); + value = CDR(result); + result = CAR(result); + } + else + value = NIL; + LispSetVar(place, value); + } + else { + GC_ENTER(); + LispObj quote; + + result = EVAL(place); + if (result != NIL) { + CHECK_CONS(result); + value = CDR(result); + GC_PROTECT(value); + result = CAR(result); + } + else + value = NIL; + quote.type = LispQuote_t; + quote.data.quote = value; + APPLY2(Osetf, place, "e); + GC_LEAVE(); + } + + return (result); +} + +LispObj * +Lisp_Position(LispBuiltin *builtin) +/* + position item sequence &key from-end test test-not start end key + */ +{ + return (LispFindOrPosition(builtin, POSITION, NONE)); +} + +LispObj * +Lisp_PositionIf(LispBuiltin *builtin) +/* + position-if predicate sequence &key from-end start end key + */ +{ + return (LispFindOrPosition(builtin, POSITION, IF)); +} + +LispObj * +Lisp_PositionIfNot(LispBuiltin *builtin) +/* + position-if-not predicate sequence &key from-end start end key + */ +{ + return (LispFindOrPosition(builtin, POSITION, IFNOT)); +} + +LispObj * +Lisp_Proclaim(LispBuiltin *builtin) +/* + proclaim declaration + */ +{ + LispObj *arguments, *object; + char *operation; + + LispObj *declaration; + + declaration = ARGUMENT(0); + + CHECK_CONS(declaration); + + arguments = declaration; + object = CAR(arguments); + CHECK_SYMBOL(object); + + operation = ATOMID(object); + if (strcmp(operation, "SPECIAL") == 0) { + for (arguments = CDR(arguments); CONSP(arguments); + arguments = CDR(arguments)) { + object = CAR(arguments); + CHECK_SYMBOL(object); + LispProclaimSpecial(object, NULL, NIL); + } + } + else if (strcmp(operation, "TYPE") == 0) { + /* XXX no type checking yet, but should be added */ + } + /* else do nothing */ + + return (NIL); +} + +LispObj * +Lisp_Prog1(LispBuiltin *builtin) +/* + prog1 first &rest body + */ +{ + GC_ENTER(); + LispObj *result; + + LispObj *first, *body; + + body = ARGUMENT(1); + first = ARGUMENT(0); + + result = EVAL(first); + + GC_PROTECT(result); + for (; CONSP(body); body = CDR(body)) + (void)EVAL(CAR(body)); + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Prog2(LispBuiltin *builtin) +/* + prog2 first second &rest body + */ +{ + GC_ENTER(); + LispObj *result; + + LispObj *first, *second, *body; + + body = ARGUMENT(2); + second = ARGUMENT(1); + first = ARGUMENT(0); + + (void)EVAL(first); + result = EVAL(second); + GC_PROTECT(result); + for (; CONSP(body); body = CDR(body)) + (void)EVAL(CAR(body)); + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Progn(LispBuiltin *builtin) +/* + progn &rest body + */ +{ + LispObj *result = NIL; + + LispObj *body; + + body = ARGUMENT(0); + + for (; CONSP(body); body = CDR(body)) + result = EVAL(CAR(body)); + + return (result); +} + +/* + * This does what I believe is the expected behaviour (or at least + * acceptable for the the interpreter), if the code being executed + * ever tries to change/bind a progv symbol, the symbol state will + * be restored when exiting the progv block, so, code like: + * (progv '(*x*) '(1) (defvar *x* 10)) + * when exiting the block, will have *x* unbound, and not a dynamic + * symbol; if it was already bound, will have the old value. + * Symbols already dynamic can be freely changed, even unbounded in + * the progv block. + */ +LispObj * +Lisp_Progv(LispBuiltin *builtin) +/* + progv symbols values &rest body + */ +{ + GC_ENTER(); + int head = lisp__data.env.length, i, count, ostk[32], *offsets; + LispObj *result, *list, *symbol, *value, **presult, **psymbols, **pbody; + int jumped, *pjumped, *pcount, **poffsets; + char fstk[32], *flags, **pflags; + LispBlock *block; + LispAtom *atom; + + LispObj *symbols, *values, *body; + + /* Possible states */ +#define DYNAMIC_SYMBOL 1 +#define GLOBAL_SYMBOL 2 +#define UNBOUND_SYMBOL 3 + + body = ARGUMENT(2); + values = ARGUMENT(1); + symbols = ARGUMENT(0); + + /* get symbol names */ + symbols = EVAL(symbols); + GC_PROTECT(symbols); + + /* get symbol values */ + values = EVAL(values); + GC_PROTECT(values); + + /* use variables */ + pbody = &body; + psymbols = &symbols; + presult = &result; + pjumped = &jumped; + poffsets = &offsets; + pcount = &count; + pflags = &flags; + + /* count/check symbols and allocate space to remember symbol state */ + for (count = 0, list = symbols; CONSP(list); count++, list = CDR(list)) { + symbol = CAR(list); + CHECK_SYMBOL(symbol); + CHECK_CONSTANT(symbol); + } + if (count > sizeof(fstk)) { + flags = LispMalloc(count); + offsets = LispMalloc(count * sizeof(int)); + } + else { + flags = &fstk[0]; + offsets = &ostk[0]; + } + + /* store flags and save old value if required */ + for (i = 0, list = symbols; i < count; i++, list = CDR(list)) { + atom = CAR(list)->data.atom; + if (atom->dyn) + flags[i] = DYNAMIC_SYMBOL; + else if (atom->a_object) { + flags[i] = GLOBAL_SYMBOL; + offsets[i] = lisp__data.protect.length; + GC_PROTECT(atom->property->value); + } + else + flags[i] = UNBOUND_SYMBOL; + } + + /* bind the symbols */ + for (i = 0, list = symbols; i < count; i++, list = CDR(list)) { + symbol = CAR(list); + atom = symbol->data.atom; + if (CONSP(values)) { + value = CAR(values); + values = CDR(values); + } + else + value = NIL; + if (flags[i] != DYNAMIC_SYMBOL) { + if (!atom->a_object) + LispSetAtomObjectProperty(atom, value); + else + SETVALUE(atom, value); + } + else + LispAddVar(symbol, value); + } + /* bind dynamic symbols */ + lisp__data.env.head = lisp__data.env.length; + + jumped = 0; + result = NIL; + block = LispBeginBlock(NIL, LispBlockProtect); + if (setjmp(block->jmp) == 0) { + for (; CONSP(body); body = CDR(body)) + result = EVAL(CAR(body)); + } + + /* restore symbols */ + for (i = 0, list = symbols; i < count; i++, list = CDR(list)) { + symbol = CAR(list); + atom = symbol->data.atom; + if (flags[i] != DYNAMIC_SYMBOL) { + if (flags[i] == UNBOUND_SYMBOL) + LispUnsetVar(symbol); + else { + /* restore global symbol value */ + LispSetAtomObjectProperty(atom, lisp__data.protect.objects + [offsets[i]]); + atom->dyn = 0; + } + } + } + /* unbind dynamic symbols */ + lisp__data.env.head = lisp__data.env.length = head; + GC_LEAVE(); + + if (count > sizeof(fstk)) { + LispFree(flags); + LispFree(offsets); + } + + LispEndBlock(block); + if (!lisp__data.destroyed) { + if (jumped) + result = lisp__data.block.block_ret; + } + else { + /* check if there is an unwind-protect block */ + LispBlockUnwind(NULL); + + /* no unwind-protect block, return to the toplevel */ + LispDestroy("."); + } + + return (result); +} + +LispObj * +Lisp_Provide(LispBuiltin *builtin) +/* + provide module + */ +{ + LispObj *module, *obj; + + module = ARGUMENT(0); + + CHECK_STRING(module); + for (obj = MOD; obj != NIL; obj = CDR(obj)) { + if (STRLEN(CAR(obj)) == STRLEN(module) && + memcmp(THESTR(CAR(obj)), THESTR(module), STRLEN(module)) == 0) + return (module); + } + + if (MOD == NIL) + MOD = CONS(module, NIL); + else { + RPLACD(MOD, CONS(CAR(MOD), CDR(MOD))); + RPLACA(MOD, module); + } + + LispSetVar(lisp__data.modules, MOD); + + return (MOD); +} + +LispObj * +Lisp_Push(LispBuiltin *builtin) +/* + push item place + */ +{ + LispObj *result, *list; + + LispObj *item, *place; + + place = ARGUMENT(1); + item = ARGUMENT(0); + + item = EVAL(item); + + if (SYMBOLP(place)) { + list = LispGetVar(place); + if (list == NULL) + LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); + CHECK_CONSTANT(place); + LispSetVar(place, result = CONS(item, list)); + } + else { + GC_ENTER(); + LispObj quote; + + list = EVAL(place); + result = CONS(item, list); + GC_PROTECT(result); + quote.type = LispQuote_t; + quote.data.quote = result; + APPLY2(Osetf, place, "e); + GC_LEAVE(); + } + + return (result); +} + +LispObj * +Lisp_Pushnew(LispBuiltin *builtin) +/* + pushnew item place &key key test test-not + */ +{ + GC_ENTER(); + LispObj *result, *list; + + LispObj *item, *place, *key, *test, *test_not; + + test_not = ARGUMENT(4); + test = ARGUMENT(3); + key = ARGUMENT(2); + place = ARGUMENT(1); + item = ARGUMENT(0); + + /* Evaluate place */ + if (SYMBOLP(place)) { + list = LispGetVar(place); + if (list == NULL) + LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); + /* Do error checking now. */ + CHECK_CONSTANT(place); + } + else + /* It is possible that list is not gc protected? */ + list = EVAL(place); + + item = EVAL(item); + GC_PROTECT(item); + if (key != UNSPEC) { + key = EVAL(key); + GC_PROTECT(key); + } + if (test != UNSPEC) { + test = EVAL(test); + GC_PROTECT(test); + } + else if (test_not != UNSPEC) { + test_not = EVAL(test_not); + GC_PROTECT(test_not); + } + + result = LispAdjoin(builtin, item, list, key, test, test_not); + + /* Item already in list */ + if (result == list) { + GC_LEAVE(); + + return (result); + } + + if (SYMBOLP(place)) { + CHECK_CONSTANT(place); + LispSetVar(place, result); + } + else { + LispObj quote; + + GC_PROTECT(result); + quote.type = LispQuote_t; + quote.data.quote = result; + APPLY2(Osetf, place, "e); + } + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Quit(LispBuiltin *builtin) +/* + quit &optional status + */ +{ + int status = 0; + LispObj *ostatus; + + ostatus = ARGUMENT(0); + + if (FIXNUMP(ostatus)) + status = (int)FIXNUM_VALUE(ostatus); + else if (ostatus != UNSPEC) + LispDestroy("%s: bad exit status argument %s", + STRFUN(builtin), STROBJ(ostatus)); + + exit(status); +} + +LispObj * +Lisp_Quote(LispBuiltin *builtin) +/* + quote object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (object); +} + +LispObj * +Lisp_Replace(LispBuiltin *builtin) +/* + replace sequence1 sequence2 &key start1 end1 start2 end2 + */ +{ + long length, length1, length2, start1, end1, start2, end2; + LispObj *sequence1, *sequence2, *ostart1, *oend1, *ostart2, *oend2; + + oend2 = ARGUMENT(5); + ostart2 = ARGUMENT(4); + oend1 = ARGUMENT(3); + ostart1 = ARGUMENT(2); + sequence2 = ARGUMENT(1); + sequence1 = ARGUMENT(0); + + LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1, + &start1, &end1, &length1); + LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2, + &start2, &end2, &length2); + + if (start1 == end1 || start2 == end2) + return (sequence1); + + length = end1 - start1; + if (length > end2 - start2) + length = end2 - start2; + + if (STRINGP(sequence1)) { + CHECK_STRING_WRITABLE(sequence1); + if (!STRINGP(sequence2)) + LispDestroy("%s: cannot store %s in %s", + STRFUN(builtin), STROBJ(sequence2), THESTR(sequence1)); + + memmove(THESTR(sequence1) + start1, THESTR(sequence2) + start2, length); + } + else { + int i; + LispObj *from, *to; + + if (ARRAYP(sequence1)) + sequence1 = sequence1->data.array.list; + if (ARRAYP(sequence2)) + sequence2 = sequence2->data.array.list; + + /* adjust pointers */ + for (i = 0, from = sequence2; i < start2; i++, from = CDR(from)) + ; + for (i = 0, to = sequence1; i < start1; i++, to = CDR(to)) + ; + + /* copy data */ + for (i = 0; i < length; i++, from = CDR(from), to = CDR(to)) + RPLACA(to, CAR(from)); + } + + return (sequence1); +} + +static LispObj * +LispDeleteOrRemoveDuplicates(LispBuiltin *builtin, int function) +/* + delete-duplicates sequence &key from-end test test-not start end key + remove-duplicates sequence &key from-end test test-not start end key + */ +{ + GC_ENTER(); + int code, expect, value = 0; + long i, j, start, end, length, count; + LispObj *lambda, *result, *cons, *compare; + + LispObj *sequence, *from_end, *test, *test_not, *ostart, *oend, *key; + + key = ARGUMENT(6); + oend = ARGUMENT(5); + ostart = ARGUMENT(4); + test_not = ARGUMENT(3); + test = ARGUMENT(2); + from_end = ARGUMENT(1); + if (from_end == UNSPEC) + from_end = NIL; + sequence = ARGUMENT(0); + + LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, + &start, &end, &length); + + /* Check if need to do something */ + if (start == end) + return (sequence); + + CHECK_TEST(); + + /* Initialize */ + count = 0; + + result = cons = NIL; + if (STRINGP(sequence)) { + char *ptr, *string, *buffer = LispMalloc(length + 1); + + /* Use same code, update start/end offsets */ + if (from_end != NIL) { + i = length - start; + start = length - end; + end = i; + } + + if (from_end == NIL) + string = THESTR(sequence); + else { + /* Make a reversed copy of the sequence */ + string = LispMalloc(length + 1); + for (ptr = THESTR(sequence) + length - 1, i = 0; i < length; i++) + string[i] = *ptr--; + string[i] = '\0'; + } + + ptr = buffer; + /* Copy leading bytes */ + for (i = 0; i < start; i++) + *ptr++ = string[i]; + + compare = SCHAR(string[i]); + if (key != UNSPEC) + compare = APPLY1(key, compare); + result = cons = CONS(compare, NIL); + GC_PROTECT(result); + for (++i; i < end; i++) { + compare = SCHAR(string[i]); + if (key != UNSPEC) + compare = APPLY1(key, compare); + RPLACD(cons, CONS(compare, NIL)); + cons = CDR(cons); + } + + for (i = start; i < end; i++, result = CDR(result)) { + compare = CAR(result); + for (j = i + 1, cons = CDR(result); j < end; j++, cons = CDR(cons)) { + value = FCOMPARE(lambda, compare, CAR(cons), code); + if (value == expect) + break; + } + if (value != expect) + *ptr++ = string[i]; + else + ++count; + } + + if (count) { + /* Copy ending bytes */ + for (; i <= length; i++) /* Also copy the ending nul */ + *ptr++ = string[i]; + + if (from_end == NIL) + ptr = buffer; + else { + for (i = 0, ptr = buffer + strlen(buffer); + ptr > buffer; + i++) + string[i] = *--ptr; + string[i] = '\0'; + ptr = string; + LispFree(buffer); + } + if (function == REMOVE) + result = STRING2(ptr); + else { + CHECK_STRING_WRITABLE(sequence); + result = sequence; + free(THESTR(result)); + THESTR(result) = ptr; + LispMused(ptr); + } + } + else { + result = sequence; + if (from_end != NIL) + LispFree(string); + } + } + else { + long xlength = end - start; + LispObj *list, *object, **kobjects = NULL, **xobjects; + LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength); + + if (!CONSP(sequence)) + object = sequence->data.array.list; + else + object = sequence; + list = object; + + for (i = 0; i < start; i++) + object = CDR(object); + + /* Put data in a vector */ + if (from_end == NIL) { + for (i = 0; i < xlength; i++, object = CDR(object)) + objects[i] = CAR(object); + } + else { + for (i = xlength - 1; i >= 0; i--, object = CDR(object)) + objects[i] = CAR(object); + } + + /* Apply key predicate if required */ + if (key != UNSPEC) { + kobjects = LispMalloc(sizeof(LispObj*) * xlength); + for (i = 0; i < xlength; i++) { + kobjects[i] = APPLY1(key, objects[i]); + GC_PROTECT(kobjects[i]); + } + xobjects = kobjects; + } + else + xobjects = objects; + + /* Check if needs to remove something */ + for (i = 0; i < xlength; i++) { + compare = xobjects[i]; + for (j = i + 1; j < xlength; j++) { + value = FCOMPARE(lambda, compare, xobjects[j], code); + if (value == expect) { + objects[i] = NULL; + ++count; + break; + } + } + } + + if (count) { + /* Create/set result list */ + object = list; + + if (start) { + /* Skip first elements of resulting list */ + if (function == REMOVE) { + result = cons = CONS(CAR(object), NIL); + GC_PROTECT(result); + for (i = 1, object = CDR(object); + i < start; + i++, object = CDR(object)) { + RPLACD(cons, CONS(CAR(object), NIL)); + cons = CDR(cons); + } + } + else { + result = cons = object; + for (i = 1; i < start; i++, cons = CDR(cons)) + ; + } + } + else if (function == DELETE) + result = list; + + /* Skip initial removed elements */ + if (function == REMOVE) { + for (i = 0; objects[i] == NULL && i < xlength; i++) + ; + } + else + i = 0; + + if (i < xlength) { + int xstart, xlimit, xinc; + + if (from_end == NIL) { + xstart = i; + xlimit = xlength; + xinc = 1; + } + else { + xstart = xlength - 1; + xlimit = i - 1; + xinc = -1; + } + + if (function == REMOVE) { + for (i = xstart; i != xlimit; i += xinc) { + if (objects[i] != NULL) { + if (result == NIL) { + result = cons = CONS(objects[i], NIL); + GC_PROTECT(result); + } + else { + RPLACD(cons, CONS(objects[i], NIL)); + cons = CDR(cons); + } + } + } + } + else { + /* Delete duplicates */ + for (i = xstart; i != xlimit; i += xinc) { + if (objects[i] == NULL) { + if (cons == NIL) { + if (CONSP(CDR(result))) { + RPLACA(result, CADR(result)); + RPLACD(result, CDDR(result)); + } + else { + RPLACA(result, CDR(result)); + RPLACD(result, NIL); + } + } + else { + if (CONSP(CDR(cons))) + RPLACD(cons, CDDR(cons)); + else + RPLACD(cons, NIL); + } + } + else { + if (cons == NIL) + cons = result; + else + cons = CDR(cons); + } + } + } + } + if (end < length && function == REMOVE) { + for (i = start; i < end; i++, object = CDR(object)) + ; + if (result == NIL) { + result = cons = CONS(CAR(object), NIL); + GC_PROTECT(result); + ++i; + object = CDR(object); + } + for (; i < length; i++, object = CDR(object)) { + RPLACD(cons, CONS(CAR(object), NIL)); + cons = CDR(cons); + } + } + } + else + result = sequence; + LispFree(objects); + if (key != UNSPEC) + LispFree(kobjects); + + if (count && !CONSP(sequence)) { + if (function == REMOVE) + result = VECTOR(result); + else { + length = FIXNUM_VALUE(CAR(sequence->data.array.dim)) - count; + CAR(sequence->data.array.dim) = FIXNUM(length); + result = sequence; + } + } + } + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_RemoveDuplicates(LispBuiltin *builtin) +/* + remove-duplicates sequence &key from-end test test-not start end key + */ +{ + return (LispDeleteOrRemoveDuplicates(builtin, REMOVE)); +} + +static LispObj * +LispDeleteRemoveXSubstitute(LispBuiltin *builtin, + int function, int comparison) +/* + delete item sequence &key from-end test test-not start end count key + delete-if predicate sequence &key from-end start end count key + delete-if-not predicate sequence &key from-end start end count key + remove item sequence &key from-end test test-not start end count key + remove-if predicate sequence &key from-end start end count key + remove-if-not predicate sequence &key from-end start end count key + substitute newitem olditem sequence &key from-end test test-not start end count key + substitute-if newitem test sequence &key from-end start end count key + substitute-if-not newitem test sequence &key from-end start end count key + nsubstitute newitem olditem sequence &key from-end test test-not start end count key + nsubstitute-if newitem test sequence &key from-end start end count key + nsubstitute-if-not newitem test sequence &key from-end start end count key + */ +{ + GC_ENTER(); + int code, expect, value, inplace, substitute; + long i, j, start, end, length, copy, count, xstart, xend, xinc, xlength; + + LispObj *result, *compare; + + LispObj *item, *newitem, *lambda, *sequence, *from_end, + *test, *test_not, *ostart, *oend, *ocount, *key; + + substitute = function == SUBSTITUTE || function == NSUBSTITUTE; + if (!substitute) + i = comparison == NONE ? 8 : 6; + else /* substitute */ + i = comparison == NONE ? 9 : 7; + + /* Get function arguments */ + key = ARGUMENT(i); --i; + ocount = ARGUMENT(i); --i; + oend = ARGUMENT(i); --i; + ostart = ARGUMENT(i); --i; + if (comparison == NONE) { + test_not = ARGUMENT(i); --i; + test = ARGUMENT(i); --i; + } + else + test_not = test = UNSPEC; + from_end = ARGUMENT(i); --i; + if (from_end == UNSPEC) + from_end = NIL; + sequence = ARGUMENT(i); --i; + if (comparison != NONE) { + lambda = ARGUMENT(i); --i; + if (substitute) + newitem = ARGUMENT(0); + else + newitem = NIL; + item = NIL; + } + else { + lambda = NIL; + if (substitute) { + item = ARGUMENT(1); + newitem = ARGUMENT(0); + } + else { + item = ARGUMENT(0); + newitem = NIL; + } + } + + /* Check if argument is a valid sequence, and if start/end + * are correctly specified. */ + LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, + &start, &end, &length); + + /* Check count argument */ + if (ocount == UNSPEC) { + count = length; + /* Doesn't matter, but left to right should be slightly faster */ + from_end = NIL; + } + else { + CHECK_INDEX(ocount); + count = FIXNUM_VALUE(ocount); + } + + /* Check if need to do something */ + if (start == end || count == 0) + return (sequence); + + CHECK_TEST_0(); + + /* Resolve comparison function, and expected result of comparison */ + if (comparison == NONE) { + if (test_not == UNSPEC) { + if (test == UNSPEC) + lambda = Oeql; + else + lambda = test; + expect = 1; + } + else { + lambda = test_not; + expect = 0; + } + FUNCTION_CHECK(lambda); + } + else + expect = comparison == IFNOT ? 0 : 1; + + /* Check for fast path to comparison function */ + code = FCODE(lambda); + + /* Initialize for loop */ + copy = count; + result = sequence; + inplace = function == DELETE || function == NSUBSTITUTE; + xlength = end - start; + + /* String is easier */ + if (STRINGP(sequence)) { + char *buffer, *string; + + if (comparison == NONE) { + CHECK_SCHAR(item); + } + if (substitute) { + CHECK_SCHAR(newitem); + } + + if (from_end == NIL) { + xstart = start; + xend = end; + xinc = 1; + } + else { + xstart = end - 1; + xend = start - 1; + xinc = -1; + } + + string = THESTR(sequence); + buffer = LispMalloc(length + 1); + + /* Copy leading bytes, if any */ + for (i = 0; i < start; i++) + buffer[i] = string[i]; + + for (j = xstart; i != xend && count > 0; i += xinc) { + compare = SCHAR(string[i]); + if (key != UNSPEC) { + compare = APPLY1(key, compare); + /* Value returned by the key predicate may not be protected */ + GC_PROTECT(compare); + if (comparison == NONE) + value = FCOMPARE(lambda, item, compare, code); + else + value = APPLY1(lambda, compare) != NIL; + /* Unprotect value returned by the key predicate */ + GC_LEAVE(); + } + else { + if (comparison == NONE) + value = FCOMPARE(lambda, item, compare, code); + else + value = APPLY1(lambda, compare) != NIL; + } + + if (value != expect) { + buffer[j] = string[i]; + j += xinc; + } + else { + if (substitute) { + buffer[j] = SCHAR_VALUE(newitem); + j += xinc; + } + else + --count; + } + } + + if (count != copy && from_end != NIL) + memmove(buffer + start, buffer + copy - count, count); + + /* Copy remaining bytes, if any */ + for (; i < length; i++, j++) + buffer[j] = string[i]; + buffer[j] = '\0'; + + xlength = length - (copy - count); + if (inplace) { + CHECK_STRING_WRITABLE(sequence); + /* result is a pointer to sequence */ + LispFree(THESTR(sequence)); + LispMused(buffer); + THESTR(sequence) = buffer; + STRLEN(sequence) = xlength; + } + else + result = LSTRING2(buffer, xlength); + } + + /* If inplace, need to update CAR and CDR of sequence */ + else { + LispObj *list, *object; + LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength); + + if (!CONSP(sequence)) + list = sequence->data.array.list; + else + list = sequence; + + /* Put data in a vector */ + for (i = 0, object = list; i < start; i++) + object = CDR(object); + + for (i = 0; i < xlength; i++, object = CDR(object)) + objects[i] = CAR(object); + + if (from_end == NIL) { + xstart = 0; + xend = xlength; + xinc = 1; + } + else { + xstart = xlength - 1; + xend = -1; + xinc = -1; + } + + /* Check if needs to remove something */ + for (i = xstart; i != xend && count > 0; i += xinc) { + compare = objects[i]; + if (key != UNSPEC) { + compare = APPLY1(key, compare); + GC_PROTECT(compare); + if (comparison == NONE) + value = FCOMPARE(lambda, item, compare, code); + else + value = APPLY1(lambda, compare) != NIL; + GC_LEAVE(); + } + else { + if (comparison == NONE) + value = FCOMPARE(lambda, item, compare, code); + else + value = APPLY1(lambda, compare) != NIL; + } + if (value == expect) { + if (substitute) + objects[i] = newitem; + else + objects[i] = NULL; + --count; + } + } + + if (copy != count) { + LispObj *cons = NIL; + + i = 0; + object = list; + if (inplace) { + /* While result is NIL, skip initial elements of sequence */ + result = start ? list : NIL; + + /* Skip initial elements, if any */ + for (; i < start; i++, cons = object, object = CDR(object)) + ; + } + /* Copy initial elements, if any */ + else { + result = NIL; + if (start) { + result = cons = CONS(CAR(list), NIL); + GC_PROTECT(result); + for (++i, object = CDR(list); + i < start; + i++, object = CDR(object)) { + RPLACD(cons, CONS(CAR(object), NIL)); + cons = CDR(cons); + } + } + } + + /* Skip initial removed elements, if any */ + for (i = 0; objects[i] == NULL && i < xlength; i++) + ; + + for (i = 0; i < xlength; i++, object = CDR(object)) { + if (objects[i]) { + if (inplace) { + if (result == NIL) + result = cons = object; + else { + RPLACD(cons, object); + cons = CDR(cons); + } + if (function == NSUBSTITUTE) + RPLACA(cons, objects[i]); + } + else { + if (result == NIL) { + result = cons = CONS(objects[i], NIL); + GC_PROTECT(result); + } + else { + RPLACD(cons, CONS(objects[i], NIL)); + cons = CDR(cons); + } + } + } + } + + if (inplace) { + if (result == NIL) + result = object; + else + RPLACD(cons, object); + + if (!CONSP(sequence)) { + result = sequence; + CAR(result)->data.array.dim = + FIXNUM(length - (copy - count)); + } + } + else if (end < length) { + i = end; + /* Copy ending elements, if any */ + if (result == NIL) { + result = cons = CONS(CAR(object), NIL); + GC_PROTECT(result); + object = CDR(object); + i++; + } + for (; i < length; i++, object = CDR(object)) { + RPLACD(cons, CONS(CAR(object), NIL)); + cons = CDR(cons); + } + } + } + + /* Release comparison vector */ + LispFree(objects); + } + + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Remove(LispBuiltin *builtin) +/* + remove item sequence &key from-end test test-not start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, REMOVE, NONE)); +} + +LispObj * +Lisp_RemoveIf(LispBuiltin *builtin) +/* + remove-if predicate sequence &key from-end start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IF)); +} + +LispObj * +Lisp_RemoveIfNot(LispBuiltin *builtin) +/* + remove-if-not predicate sequence &key from-end start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IFNOT)); +} + +LispObj * +Lisp_Remprop(LispBuiltin *builtin) +/* + remprop symbol indicator + */ +{ + LispObj *symbol, *indicator; + + indicator = ARGUMENT(1); + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + + return (LispRemAtomProperty(symbol->data.atom, indicator)); +} + +LispObj * +Lisp_Return(LispBuiltin *builtin) +/* + return &optional result + */ +{ + unsigned blevel = lisp__data.block.block_level; + + LispObj *result; + + result = ARGUMENT(0); + + while (blevel) { + LispBlock *block = lisp__data.block.block[--blevel]; + + if (block->type == LispBlockClosure) + /* if reached a function call */ + break; + if (block->type == LispBlockTag && block->tag == NIL) { + lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result); + LispBlockUnwind(block); + BLOCKJUMP(block); + } + } + LispDestroy("%s: no visible NIL block", STRFUN(builtin)); + + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +Lisp_ReturnFrom(LispBuiltin *builtin) +/* + return-from name &optional result + */ +{ + unsigned blevel = lisp__data.block.block_level; + + LispObj *name, *result; + + result = ARGUMENT(1); + name = ARGUMENT(0); + + if (name != NIL && name != T && !SYMBOLP(name)) + LispDestroy("%s: %s is not a valid block name", + STRFUN(builtin), STROBJ(name)); + + while (blevel) { + LispBlock *block = lisp__data.block.block[--blevel]; + + if (name == block->tag && + (block->type == LispBlockTag || block->type == LispBlockClosure)) { + lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result); + LispBlockUnwind(block); + BLOCKJUMP(block); + } + if (block->type == LispBlockClosure) + /* can use return-from only in the current function */ + break; + } + LispDestroy("%s: no visible block named %s", + STRFUN(builtin), STROBJ(name)); + + /*NOTREACHED*/ + return (NIL); +} + +static LispObj * +LispXReverse(LispBuiltin *builtin, int inplace) +/* + nreverse sequence + reverse sequence + */ +{ + long length; + LispObj *list, *result = NIL; + + LispObj *sequence; + + sequence = ARGUMENT(0); + + /* Do error checking for arrays and object type. */ + length = LispLength(sequence); + if (length <= 1) + return (sequence); + + switch (XOBJECT_TYPE(sequence)) { + case LispString_t: { + long i; + char *from, *to; + + from = THESTR(sequence) + length - 1; + if (inplace) { + char temp; + + CHECK_STRING_WRITABLE(sequence); + to = THESTR(sequence); + for (i = 0; i < length / 2; i++) { + temp = to[i]; + to[i] = from[-i]; + from[-i] = temp; + } + result = sequence; + } + else { + to = LispMalloc(length + 1); + to[length] = '\0'; + for (i = 0; i < length; i++) + to[i] = from[-i]; + result = STRING2(to); + } + } return (result); + case LispCons_t: + if (inplace) { + long i, j; + LispObj *temp; + + /* For large lists this can be very slow, but for small + * amounts of data, this avoid allocating a buffer to + * to store the CAR of the sequence. This is only done + * to not destroy the contents of a variable. + */ + for (i = 0, list = sequence; + i < (length + 1) / 2; + i++, list = CDR(list)) + ; + length /= 2; + for (i = 0; i < length; i++, list = CDR(list)) { + for (j = length - i - 1, result = sequence; + j > 0; + j--, result = CDR(result)) + ; + temp = CAR(list); + RPLACA(list, CAR(result)); + RPLACA(result, temp); + } + return (sequence); + } + list = sequence; + break; + case LispArray_t: + if (inplace) { + sequence->data.array.list = + LispReverse(sequence->data.array.list); + return (sequence); + } + list = sequence->data.array.list; + break; + default: /* LispNil_t */ + return (result); + } + + { + GC_ENTER(); + LispObj *cons; + + result = cons = CONS(CAR(list), NIL); + GC_PROTECT(result); + for (list = CDR(list); CONSP(list); list = CDR(list)) { + RPLACD(cons, CONS(CAR(list), NIL)); + cons = CDR(cons); + } + result = LispReverse(result); + + GC_LEAVE(); + } + + if (ARRAYP(sequence)) { + list = result; + + result = LispNew(list, NIL); + result->type = LispArray_t; + result->data.array.list = list; + result->data.array.dim = sequence->data.array.dim; + result->data.array.rank = sequence->data.array.rank; + result->data.array.type = sequence->data.array.type; + result->data.array.zero = sequence->data.array.zero; + } + + return (result); +} + +LispObj * +Lisp_Reverse(LispBuiltin *builtin) +/* + reverse sequence + */ +{ + return (LispXReverse(builtin, 0)); +} + +LispObj * +Lisp_Rplaca(LispBuiltin *builtin) +/* + rplaca place value + */ +{ + LispObj *place, *value; + + value = ARGUMENT(1); + place = ARGUMENT(0); + + CHECK_CONS(place); + RPLACA(place, value); + + return (place); +} + +LispObj * +Lisp_Rplacd(LispBuiltin *builtin) +/* + rplacd place value + */ +{ + LispObj *place, *value; + + value = ARGUMENT(1); + place = ARGUMENT(0); + + CHECK_CONS(place); + RPLACD(place, value); + + return (place); +} + +LispObj * +Lisp_Search(LispBuiltin *builtin) +/* + search sequence1 sequence2 &key from-end test test-not key start1 start2 end1 end2 + */ +{ + int code = 0, expect, value; + long start1, start2, end1, end2, length1, length2, off1, off2, offset = -1; + LispObj *cmp1, *cmp2, *list1 = NIL, *lambda; + SeqInfo seq1, seq2; + + LispObj *sequence1, *sequence2, *from_end, *test, *test_not, + *key, *ostart1, *ostart2, *oend1, *oend2; + + oend2 = ARGUMENT(9); + oend1 = ARGUMENT(8); + ostart2 = ARGUMENT(7); + ostart1 = ARGUMENT(6); + key = ARGUMENT(5); + test_not = ARGUMENT(4); + test = ARGUMENT(3); + from_end = ARGUMENT(2); + sequence2 = ARGUMENT(1); + sequence1 = ARGUMENT(0); + + LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1, + &start1, &end1, &length1); + LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2, + &start2, &end2, &length2); + + /* Check for special conditions */ + if (start1 == end1) + return (FIXNUM(end2)); + else if (start2 == end2) + return (start1 == end1 ? FIXNUM(start2) : NIL); + + CHECK_TEST(); + + if (from_end == UNSPEC) + from_end = NIL; + + SETSEQ(seq1, sequence1); + SETSEQ(seq2, sequence2); + + length1 = end1 - start1; + length2 = end2 - start2; + + /* update start of sequences */ + if (start1) { + if (seq1.type == LispString_t) + seq1.data.string += start1; + else { + for (cmp1 = seq1.data.list; start1; cmp1 = CDR(cmp1), --start1) + ; + seq1.data.list = cmp1; + } + end1 = length1; + } + if (start2) { + if (seq2.type == LispString_t) + seq2.data.string += start2; + else { + for (cmp2 = seq2.data.list; start2; cmp2 = CDR(cmp2), --start2) + ; + seq2.data.list = cmp2; + } + end2 = length2; + } + + /* easier case */ + if (from_end == NIL) { + LispObj *list2 = NIL; + + /* while a match is possible */ + while (end2 - start2 >= length1) { + + /* prepare to search */ + off1 = 0; + off2 = start2; + if (seq1.type != LispString_t) + list1 = seq1.data.list; + if (seq2.type != LispString_t) + list2 = seq2.data.list; + + /* for every element that must match in sequence1 */ + while (off1 < length1) { + if (seq1.type == LispString_t) + cmp1 = SCHAR(seq1.data.string[off1]); + else + cmp1 = CAR(list1); + if (seq2.type == LispString_t) + cmp2 = SCHAR(seq2.data.string[off2]); + else + cmp2 = CAR(list2); + if (key != UNSPEC) { + cmp1 = APPLY1(key, cmp1); + cmp2 = APPLY1(key, cmp2); + } + + /* compare elements */ + value = FCOMPARE(lambda, cmp1, cmp2, code); + if (value != expect) + break; + + /* update offsets/sequence pointers */ + ++off1; + ++off2; + if (seq1.type != LispString_t) + list1 = CDR(list1); + if (seq2.type != LispString_t) + list2 = CDR(list2); + } + + /* if everything matched */ + if (off1 == end1) { + offset = off2 - length1; + break; + } + + /* update offset/sequence2 pointer */ + ++start2; + if (seq2.type != LispString_t) + seq2.data.list = CDR(seq2.data.list); + } + } + else { + /* allocate vector if required, only list2 requires it. + * list1 can be traversed forward */ + if (seq2.type != LispString_t) { + cmp2 = seq2.data.list; + seq2.data.vector = LispMalloc(sizeof(LispObj*) * length2); + for (off2 = 0; off2 < end2; off2++, cmp2 = CDR(cmp2)) + seq2.data.vector[off2] = CAR(cmp2); + } + + /* while a match is possible */ + while (end2 >= length1) { + + /* prepare to search */ + off1 = 0; + off2 = end2 - length1; + if (seq1.type != LispString_t) + list1 = seq1.data.list; + + /* for every element that must match in sequence1 */ + while (off1 < end1) { + if (seq1.type == LispString_t) + cmp1 = SCHAR(seq1.data.string[off1]); + else + cmp1 = CAR(list1); + if (seq2.type == LispString_t) + cmp2 = SCHAR(seq2.data.string[off2]); + else + cmp2 = seq2.data.vector[off2]; + if (key != UNSPEC) { + cmp1 = APPLY1(key, cmp1); + cmp2 = APPLY1(key, cmp2); + } + + /* Compare elements */ + value = FCOMPARE(lambda, cmp1, cmp2, code); + if (value != expect) + break; + + /* Update offsets */ + ++off1; + ++off2; + if (seq1.type != LispString_t) + list1 = CDR(list1); + } + + /* If all elements matched */ + if (off1 == end1) { + offset = off2 - length1; + break; + } + + /* Update offset */ + --end2; + } + + if (seq2.type != LispString_t) + LispFree(seq2.data.vector); + } + + return (offset == -1 ? NIL : FIXNUM(offset)); +} + +/* + * ext::getenv + */ +LispObj * +Lisp_Setenv(LispBuiltin *builtin) +/* + setenv name value &optional overwrite + */ +{ + char *name, *value; + + LispObj *oname, *ovalue, *overwrite; + + overwrite = ARGUMENT(2); + ovalue = ARGUMENT(1); + oname = ARGUMENT(0); + + CHECK_STRING(oname); + name = THESTR(oname); + + CHECK_STRING(ovalue); + value = THESTR(ovalue); + + setenv(name, value, overwrite != UNSPEC && overwrite != NIL); + value = getenv(name); + + return (value ? STRING(value) : NIL); +} + +LispObj * +Lisp_Set(LispBuiltin *builtin) +/* + set symbol value + */ +{ + LispAtom *atom; + LispObj *symbol, *value; + + value = ARGUMENT(1); + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + atom = symbol->data.atom; + if (atom->dyn) + LispSetVar(symbol, value); + else if (atom->watch || !atom->a_object) + LispSetAtomObjectProperty(atom, value); + else { + CHECK_CONSTANT(symbol); + SETVALUE(atom, value); + } + + return (value); +} + +LispObj * +Lisp_SetDifference(LispBuiltin *builtin) +/* + set-difference list1 list2 &key test test-not key + */ +{ + return (LispListSet(builtin, SETDIFFERENCE)); +} + +LispObj * +Lisp_SetExclusiveOr(LispBuiltin *builtin) +/* + set-exclusive-or list1 list2 &key test test-not key + */ +{ + return (LispListSet(builtin, SETEXCLUSIVEOR)); +} + +LispObj * +Lisp_NsetExclusiveOr(LispBuiltin *builtin) +/* + nset-exclusive-or list1 list2 &key test test-not key + */ +{ + return (LispListSet(builtin, NSETEXCLUSIVEOR)); +} + +LispObj * +Lisp_SetQ(LispBuiltin *builtin) +/* + setq &rest form + */ +{ + LispObj *result, *variable, *form; + + form = ARGUMENT(0); + + result = NIL; + for (; CONSP(form); form = CDR(form)) { + variable = CAR(form); + CHECK_SYMBOL(variable); + CHECK_CONSTANT(variable); + form = CDR(form); + if (!CONSP(form)) + LispDestroy("%s: odd number of arguments", STRFUN(builtin)); + result = EVAL(CAR(form)); + LispSetVar(variable, result); + } + + return (result); +} + +LispObj * +Lisp_Psetq(LispBuiltin *builtin) +/* + psetq &rest form + */ +{ + GC_ENTER(); + int base = gc__protect; + LispObj *value, *symbol, *list, *form; + + form = ARGUMENT(0); + + /* parallel setq, first pass evaluate values and basic error checking */ + for (list = form; CONSP(list); list = CDR(list)) { + symbol = CAR(list); + CHECK_SYMBOL(symbol); + list = CDR(list); + if (!CONSP(list)) + LispDestroy("%s: odd number of arguments", STRFUN(builtin)); + value = EVAL(CAR(list)); + GC_PROTECT(value); + } + + /* second pass, assign values */ + for (; CONSP(form); form = CDDR(form)) { + symbol = CAR(form); + CHECK_CONSTANT(symbol); + LispSetVar(symbol, lisp__data.protect.objects[base++]); + } + GC_LEAVE(); + + return (NIL); +} + +LispObj * +Lisp_Setf(LispBuiltin *builtin) +/* + setf &rest form + */ +{ + LispAtom *atom; + LispObj *setf, *place, *value, *result = NIL, *data; + + LispObj *form; + + form = ARGUMENT(0); + + for (; CONSP(form); form = CDR(form)) { + place = CAR(form); + form = CDR(form); + if (!CONSP(form)) + LispDestroy("%s: odd number of arguments", STRFUN(builtin)); + value = CAR(form); + + if (!POINTERP(place)) + goto invalid_place; + if (XSYMBOLP(place)) { + CHECK_CONSTANT(place); + result = EVAL(value); + (void)LispSetVar(place, result); + } + else if (XCONSP(place)) { + /* it really should not be required to protect any object + * evaluated here, but is done for safety in case one of + * the evaluated forms returns data not gc protected, what + * could cause surprises if the object is garbage collected + * before finishing setf. */ + GC_ENTER(); + + setf = CAR(place); + if (!SYMBOLP(setf)) + goto invalid_place; + if (!CONSP(CDR(place))) + goto invalid_place; + + value = EVAL(value); + GC_PROTECT(value); + + atom = setf->data.atom; + if (atom->a_defsetf == 0) { + if (atom->a_defstruct && + atom->property->structure.function >= 0) { + /* Use a default setf method for the structure field, as + * if this definition have been done + * (defsetf THE-STRUCT-FIELD (struct) (value) + * `(lisp::struct-store 'THE-STRUCT-FIELD ,struct ,value)) + */ + place = CDR(place); + data = CAR(place); + if (CONSP(CDR(place))) + goto invalid_place; + data = EVAL(data); + GC_PROTECT(data); + result = APPLY3(Ostruct_store, setf, data, value); + GC_LEAVE(); + continue; + } + /* Must also expand macros */ + else if (atom->a_function && + atom->property->fun.function->funtype == LispMacro) { + result = LispRunSetfMacro(atom, CDR(place), value); + continue; + } + goto invalid_place; + } + + place = CDR(place); + setf = setf->data.atom->property->setf; + if (SYMBOLP(setf)) { + LispObj *arguments, *cons; + + if (!CONSP(CDR(place))) { + arguments = EVAL(CAR(place)); + GC_PROTECT(arguments); + result = APPLY2(setf, arguments, value); + } + else if (!CONSP(CDDR(place))) { + arguments = EVAL(CAR(place)); + GC_PROTECT(arguments); + cons = EVAL(CADR(place)); + GC_PROTECT(cons); + result = APPLY3(setf, arguments, cons, value); + } + else { + arguments = cons = CONS(EVAL(CAR(place)), NIL); + GC_PROTECT(arguments); + for (place = CDR(place); CONSP(place); place = CDR(place)) { + RPLACD(cons, CONS(EVAL(CAR(place)), NIL)); + cons = CDR(cons); + } + RPLACD(cons, CONS(value, NIL)); + result = APPLY(setf, arguments); + } + } + else + result = LispRunSetf(atom->property->salist, setf, place, value); + GC_LEAVE(); + } + else + goto invalid_place; + } + + return (result); +invalid_place: + LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +Lisp_Psetf(LispBuiltin *builtin) +/* + psetf &rest form + */ +{ + int base; + GC_ENTER(); + LispAtom *atom; + LispObj *setf, *place = NIL, *value, *data; + + LispObj *form; + + form = ARGUMENT(0); + + /* parallel setf, first pass evaluate values and basic error checking */ + base = gc__protect; + for (setf = form; CONSP(setf); setf = CDR(setf)) { + if (!POINTERP(CAR(setf))) + goto invalid_place; + setf = CDR(setf); + if (!CONSP(setf)) + LispDestroy("%s: odd number of arguments", STRFUN(builtin)); + value = EVAL(CAR(setf)); + GC_PROTECT(value); + } + + /* second pass, assign values */ + for (; CONSP(form); form = CDDR(form)) { + place = CAR(form); + value = lisp__data.protect.objects[base++]; + + if (XSYMBOLP(place)) { + CHECK_CONSTANT(place); + (void)LispSetVar(place, value); + } + else if (XCONSP(place)) { + LispObj *arguments, *cons; + int xbase = lisp__data.protect.length; + + setf = CAR(place); + if (!SYMBOLP(setf)) + goto invalid_place; + if (!CONSP(CDR(place))) + goto invalid_place; + + atom = setf->data.atom; + if (atom->a_defsetf == 0) { + if (atom->a_defstruct && + atom->property->structure.function >= 0) { + place = CDR(place); + data = CAR(place); + if (CONSP(CDR(place))) + goto invalid_place; + data = EVAL(data); + GC_PROTECT(data); + (void)APPLY3(Ostruct_store, setf, data, value); + lisp__data.protect.length = xbase; + continue; + } + else if (atom->a_function && + atom->property->fun.function->funtype == LispMacro) { + (void)LispRunSetfMacro(atom, CDR(place), value); + lisp__data.protect.length = xbase; + continue; + } + goto invalid_place; + } + + place = CDR(place); + setf = setf->data.atom->property->setf; + if (SYMBOLP(setf)) { + if (!CONSP(CDR(place))) { + arguments = EVAL(CAR(place)); + GC_PROTECT(arguments); + (void)APPLY2(setf, arguments, value); + } + else if (!CONSP(CDDR(place))) { + arguments = EVAL(CAR(place)); + GC_PROTECT(arguments); + cons = EVAL(CADR(place)); + GC_PROTECT(cons); + (void)APPLY3(setf, arguments, cons, value); + } + else { + arguments = cons = CONS(EVAL(CAR(place)), NIL); + GC_PROTECT(arguments); + for (place = CDR(place); CONSP(place); place = CDR(place)) { + RPLACD(cons, CONS(EVAL(CAR(place)), NIL)); + cons = CDR(cons); + } + RPLACD(cons, CONS(value, NIL)); + (void)APPLY(setf, arguments); + } + lisp__data.protect.length = xbase; + } + else + (void)LispRunSetf(atom->property->salist, setf, place, value); + } + else + goto invalid_place; + } + GC_LEAVE(); + + return (NIL); +invalid_place: + LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +Lisp_Sleep(LispBuiltin *builtin) +/* + sleep seconds + */ +{ + long sec, msec; + double value, dsec; + + LispObj *seconds; + + seconds = ARGUMENT(0); + + value = -1.0; + switch (OBJECT_TYPE(seconds)) { + case LispFixnum_t: + value = FIXNUM_VALUE(seconds); + break; + case LispDFloat_t: + value = DFLOAT_VALUE(seconds); + break; + default: + break; + } + + if (value < 0.0 || value > MOST_POSITIVE_FIXNUM) + LispDestroy("%s: %s is not a positive fixnum", + STRFUN(builtin), STROBJ(seconds)); + + msec = modf(value, &dsec) * 1e6; + sec = dsec; + + if (sec) + sleep(sec); + if (msec) + usleep(msec); + + return (NIL); +} + +/* + * This function is called recursively, but the contents of "list2" are + * kept gc protected until it returns to LispSort. This is required partly + * because the "gc protection logic" protects an object, not the contents + * of the c pointer. + */ +static LispObj * +LispMergeSort(LispObj *list, LispObj *predicate, LispObj *key, int code) +{ + int protect; + LispObj *list1, *list2, *left, *right, *result, *cons; + + /* Check if list length is larger than 1 */ + if (!CONSP(list) || !CONSP(CDR(list))) + return (list); + + list1 = list2 = list; + for (;;) { + list = CDR(list); + if (!CONSP(list)) + break; + list = CDR(list); + if (!CONSP(list)) + break; + list2 = CDR(list2); + } + cons = list2; + list2 = CDR(list2); + RPLACD(cons, NIL); + + protect = 0; + if (lisp__data.protect.length + 2 >= lisp__data.protect.space) + LispMoreProtects(); + lisp__data.protect.objects[lisp__data.protect.length++] = list2; + list1 = LispMergeSort(list1, predicate, key, code); + list2 = LispMergeSort(list2, predicate, key, code); + + left = CAR(list1); + right = CAR(list2); + if (key != UNSPEC) { + protect = lisp__data.protect.length; + left = APPLY1(key, left); + lisp__data.protect.objects[protect] = left; + right = APPLY1(key, right); + lisp__data.protect.objects[protect + 1] = right; + } + + result = NIL; + for (;;) { + if ((FCOMPARE(predicate, left, right, code)) == 0 && + (FCOMPARE(predicate, right, left, code)) == 1) { + /* right is "smaller" */ + if (result == NIL) + result = list2; + else + RPLACD(cons, list2); + cons = list2; + list2 = CDR(list2); + if (!CONSP(list2)) { + RPLACD(cons, list1); + break; + } + right = CAR(list2); + if (key != UNSPEC) { + right = APPLY1(key, right); + lisp__data.protect.objects[protect + 1] = right; + } + } + else { + /* left is "smaller" */ + if (result == NIL) + result = list1; + else + RPLACD(cons, list1); + cons = list1; + list1 = CDR(list1); + if (!CONSP(list1)) { + RPLACD(cons, list2); + break; + } + left = CAR(list1); + if (key != UNSPEC) { + left = APPLY1(key, left); + lisp__data.protect.objects[protect] = left; + } + } + } + if (key != UNSPEC) + lisp__data.protect.length = protect; + + return (result); +} + +/* XXX The first version made a copy of the list and then adjusted + * the CARs of the list. To minimize GC time now it is now doing + * the sort inplace. So, instead of writing just (sort variable) + * now it is required to write (setq variable (sort variable)) + * if the variable should always keep all elements. + */ +LispObj * +Lisp_Sort(LispBuiltin *builtin) +/* + sort sequence predicate &key key + */ +{ + GC_ENTER(); + int istring, code; + long length; + char *string; + + LispObj *list, *work, *cons = NULL; + + LispObj *sequence, *predicate, *key; + + key = ARGUMENT(2); + predicate = ARGUMENT(1); + sequence = ARGUMENT(0); + + length = LispLength(sequence); + if (length < 2) + return (sequence); + + list = sequence; + istring = XSTRINGP(sequence); + if (istring) { + CHECK_STRING_WRITABLE(sequence); + /* Convert string to list */ + string = THESTR(sequence); + work = cons = CONS(SCHAR(string[0]), NIL); + GC_PROTECT(work); + for (++string; *string; ++string) { + RPLACD(cons, CONS(SCHAR(*string), NIL)); + cons = CDR(cons); + } + } + else if (ARRAYP(list)) + work = list->data.array.list; + else + work = list; + + FUNCTION_CHECK(predicate); + code = FCODE(predicate); + work = LispMergeSort(work, predicate, key, code); + + if (istring) { + /* Convert list to string */ + string = THESTR(sequence); + for (; CONSP(work); ++string, work = CDR(work)) + *string = SCHAR_VALUE(CAR(work)); + } + else if (ARRAYP(list)) + list->data.array.list = work; + else + sequence = work; + GC_LEAVE(); + + return (sequence); +} + +LispObj * +Lisp_Subseq(LispBuiltin *builtin) +/* + subseq sequence start &optional end + */ +{ + long start, end, length, seqlength; + + LispObj *sequence, *ostart, *oend, *result; + + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + sequence = ARGUMENT(0); + + LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, + &start, &end, &length); + + seqlength = end - start; + + if (sequence == NIL) + result = NIL; + else if (XSTRINGP(sequence)) { + char *string = LispMalloc(seqlength + 1); + + memcpy(string, THESTR(sequence) + start, seqlength); + string[seqlength] = '\0'; + result = STRING2(string); + } + else { + GC_ENTER(); + LispObj *object; + + if (end > start) { + /* list or array */ + int count; + LispObj *cons; + + if (ARRAYP(sequence)) + object = sequence->data.array.list; + else + object = sequence; + /* goto first element to copy */ + for (count = 0; count < start; count++, object = CDR(object)) + ; + result = cons = CONS(CAR(object), NIL); + GC_PROTECT(result); + for (++count, object = CDR(object); count < end; count++, + object = CDR(object)) { + RPLACD(cons, CONS(CAR(object), NIL)); + cons = CDR(cons); + } + } + else + result = NIL; + + if (ARRAYP(sequence)) { + object = LispNew(NIL, NIL); + GC_PROTECT(object); + object->type = LispArray_t; + object->data.array.list = result; + object->data.array.dim = CONS(FIXNUM(seqlength), NIL); + object->data.array.rank = 1; + object->data.array.type = sequence->data.array.type; + object->data.array.zero = length == 0; + result = object; + } + GC_LEAVE(); + } + + return (result); +} + +LispObj * +Lisp_Subsetp(LispBuiltin *builtin) +/* + subsetp list1 list2 &key test test-not key + */ +{ + return (LispListSet(builtin, SUBSETP)); +} + + +LispObj * +Lisp_Substitute(LispBuiltin *builtin) +/* + substitute newitem olditem sequence &key from-end test test-not start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, NONE)); +} + +LispObj * +Lisp_SubstituteIf(LispBuiltin *builtin) +/* + substitute-if newitem test sequence &key from-end start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IF)); +} + +LispObj * +Lisp_SubstituteIfNot(LispBuiltin *builtin) +/* + substitute-if-not newitem test sequence &key from-end start end count key + */ +{ + return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IFNOT)); +} + +LispObj * +Lisp_Symbolp(LispBuiltin *builtin) +/* + symbolp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (SYMBOLP(object) ? T : NIL); +} + +LispObj * +Lisp_SymbolFunction(LispBuiltin *builtin) +/* + symbol-function symbol + */ +{ + LispObj *symbol; + + symbol = ARGUMENT(0); + CHECK_SYMBOL(symbol); + + return (LispSymbolFunction(symbol)); +} + +LispObj * +Lisp_SymbolName(LispBuiltin *builtin) +/* + symbol-name symbol + */ +{ + LispObj *symbol; + + symbol = ARGUMENT(0); + CHECK_SYMBOL(symbol); + + return (LispSymbolName(symbol)); +} + +LispObj * +Lisp_SymbolPackage(LispBuiltin *builtin) +/* + symbol-package symbol + */ +{ + LispObj *symbol; + + symbol = ARGUMENT(0); + CHECK_SYMBOL(symbol); + + symbol = symbol->data.atom->package; + + return (symbol ? symbol : NIL); +} + +LispObj * +Lisp_SymbolPlist(LispBuiltin *builtin) +/* + symbol-plist symbol + */ +{ + LispObj *symbol; + + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + + return (symbol->data.atom->a_property ? + symbol->data.atom->property->properties : NIL); +} + +LispObj * +Lisp_SymbolValue(LispBuiltin *builtin) +/* + symbol-value symbol + */ +{ + LispAtom *atom; + LispObj *symbol; + + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + atom = symbol->data.atom; + if (!atom->a_object || atom->property->value == UNBOUND) { + if (atom->package == lisp__data.keyword) + return (symbol); + LispDestroy("%s: the symbol %s has no value", + STRFUN(builtin), STROBJ(symbol)); + } + + return (atom->dyn ? LispGetVar(symbol) : atom->property->value); +} + +LispObj * +Lisp_Tagbody(LispBuiltin *builtin) +/* + tagbody &rest body + */ +{ + GC_ENTER(); + int stack, lex, length; + LispObj *list, *body, *ptr, *tag, *labels, *map, + **p_list, **p_body, **p_labels; + LispBlock *block; + + body = ARGUMENT(0); + + /* Save environment information */ + stack = lisp__data.stack.length; + lex = lisp__data.env.lex; + length = lisp__data.env.length; + + /* Since the body may be large, and the code may iterate several + * thousand times, it is not a bad idea to avoid checking all + * elements of the body to verify if it is a tag. */ + for (labels = map = NIL, ptr = body; CONSP(ptr); ptr = CDR(ptr)) { + tag = CAR(ptr); + switch (OBJECT_TYPE(tag)) { + case LispNil_t: + case LispAtom_t: + case LispFixnum_t: + /* Don't allow duplicated labels */ + for (list = labels; CONSP(list); list = CDDR(list)) { + if (CAR(list) == tag) + LispDestroy("%s: tag %s specified more than once", + STRFUN(builtin), STROBJ(tag)); + } + if (labels == NIL) { + labels = CONS(tag, CONS(NIL, NIL)); + map = CDR(labels); + GC_PROTECT(labels); + } + else { + RPLACD(map, CONS(tag, CONS(NIL, NIL))); + map = CDDR(map); + } + break; + case LispCons_t: + /* Restart point for tag */ + if (map != NIL && CAR(map) == NIL) + RPLACA(map, ptr); + break; + default: + break; + } + } + /* Check for consecutive labels without code between them */ + for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) { + if (CADR(ptr) == NIL) { + for (map = CDDR(ptr); CONSP(map); map = CDDR(map)) { + if (CADR(map) != NIL) { + RPLACA(CDR(ptr), CADR(map)); + break; + } + } + } + } + + /* Initialize */ + list = body; + p_list = &list; + p_body = &body; + p_labels = &labels; + block = LispBeginBlock(NIL, LispBlockBody); + + /* Loop */ + if (setjmp(block->jmp) != 0) { + /* Restore environment */ + lisp__data.stack.length = stack; + lisp__data.env.lex = lex; + lisp__data.env.head = lisp__data.env.length = length; + + tag = lisp__data.block.block_ret; + for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) { + map = CAR(ptr); + if (map == tag) + break; + } + + if (!CONSP(ptr)) + LispDestroy("%s: no such tag %s", STRFUN(builtin), STROBJ(tag)); + + *p_body = CADR(ptr); + } + + /* Execute code */ + for (; CONSP(body); body = CDR(body)) { + LispObj *form = CAR(body); + + if (CONSP(form)) + EVAL(form); + } + /* If got here, (go) not called, else, labels will be candidate to gc + * when GC_LEAVE() be called by the code in the bottom of the stack. */ + GC_LEAVE(); + + /* Finished */ + LispEndBlock(block); + + /* Always return NIL */ + return (NIL); +} + +LispObj * +Lisp_The(LispBuiltin *builtin) +/* + the value-type form + */ +{ + LispObj *value_type, *form; + + form = ARGUMENT(1); + value_type = ARGUMENT(0); + + form = EVAL(form); + + return (LispCoerce(builtin, form, value_type)); +} + +LispObj * +Lisp_Throw(LispBuiltin *builtin) +/* + throw tag result + */ +{ + unsigned blevel = lisp__data.block.block_level; + + LispObj *tag, *result; + + result = ARGUMENT(1); + tag = ARGUMENT(0); + + tag = EVAL(tag); + + if (blevel == 0) + LispDestroy("%s: not within a block", STRFUN(builtin)); + + while (blevel) { + LispBlock *block = lisp__data.block.block[--blevel]; + + if (block->type == LispBlockCatch && tag == block->tag) { + lisp__data.block.block_ret = EVAL(result); + LispBlockUnwind(block); + BLOCKJUMP(block); + } + } + LispDestroy("%s: %s is not a valid tag", STRFUN(builtin), STROBJ(tag)); + + /*NOTREACHED*/ + return (NIL); +} + +static LispObj * +LispTreeEqual(LispObj *left, LispObj *right, LispObj *test, int expect) +{ + LispObj *cmp_left, *cmp_right; + + if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right))) + return (NIL); + if (CONSP(left)) { + for (; CONSP(left) && CONSP(right); + left = CDR(left), right = CDR(right)) { + cmp_left = CAR(left); + cmp_right = CAR(right); + if ((OBJECT_TYPE(cmp_left)) ^ (OBJECT_TYPE(cmp_right))) + return (NIL); + if (CONSP(cmp_left)) { + if (LispTreeEqual(cmp_left, cmp_right, test, expect) == NIL) + return (NIL); + } + else { + if (POINTERP(cmp_left) && + (XQUOTEP(cmp_left) || XBACKQUOTEP(cmp_left))) { + cmp_left = cmp_left->data.quote; + cmp_right = cmp_right->data.quote; + } + else if (COMMAP(cmp_left)) { + cmp_left = cmp_left->data.comma.eval; + cmp_right = cmp_right->data.comma.eval; + } + if ((APPLY2(test, cmp_left, cmp_right) != NIL) != expect) + return (NIL); + } + } + if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right))) + return (NIL); + } + + if (POINTERP(left) && (XQUOTEP(left) || XBACKQUOTEP(left))) { + left = left->data.quote; + right = right->data.quote; + } + else if (COMMAP(left)) { + left = left->data.comma.eval; + right = right->data.comma.eval; + } + + return ((APPLY2(test, left, right) != NIL) == expect ? T : NIL); +} + +LispObj * +Lisp_TreeEqual(LispBuiltin *builtin) +/* + tree-equal tree-1 tree-2 &key test test-not + */ +{ + int expect; + LispObj *compare; + + LispObj *tree_1, *tree_2, *test, *test_not; + + test_not = ARGUMENT(3); + test = ARGUMENT(2); + tree_2 = ARGUMENT(1); + tree_1 = ARGUMENT(0); + + CHECK_TEST_0(); + if (test_not != UNSPEC) { + expect = 0; + compare = test_not; + } + else { + if (test == UNSPEC) + test = Oeql; + expect = 1; + compare = test; + } + + return (LispTreeEqual(tree_1, tree_2, compare, expect)); +} + +LispObj * +Lisp_Typep(LispBuiltin *builtin) +/* + typep object type + */ +{ + LispObj *result = NULL; + + LispObj *object, *type; + + type = ARGUMENT(1); + object = ARGUMENT(0); + + if (SYMBOLP(type)) { + Atom_id atom = ATOMID(type); + + if (OBJECT_TYPE(object) == LispStruct_t) + result = ATOMID(CAR(object->data.struc.def)) == atom ? T : NIL; + else if (type->data.atom->a_defstruct && + type->data.atom->property->structure.function == STRUCT_NAME) + result = NIL; + else if (atom == Snil) + result = object == NIL ? T : NIL; + else if (atom == St) + result = object == T ? T : NIL; + else if (atom == Satom) + result = !CONSP(object) ? T : NIL; + else if (atom == Ssymbol) + result = SYMBOLP(object) || object == NIL || object == T ? T : NIL; + else if (atom == Sinteger) + result = INTEGERP(object) ? T : NIL; + else if (atom == Srational) + result = RATIONALP(object) ? T : NIL; + else if (atom == Scons || atom == Slist) + result = CONSP(object) ? T : NIL; + else if (atom == Sstring) + result = STRINGP(object) ? T : NIL; + else if (atom == Scharacter) + result = SCHARP(object) ? T : NIL; + else if (atom == Scomplex) + result = COMPLEXP(object) ? T : NIL; + else if (atom == Svector || atom == Sarray) + result = ARRAYP(object) ? T : NIL; + else if (atom == Skeyword) + result = KEYWORDP(object) ? T : NIL; + else if (atom == Sfunction) + result = LAMBDAP(object) ? T : NIL; + else if (atom == Spathname) + result = PATHNAMEP(object) ? T : NIL; + else if (atom == Sopaque) + result = OPAQUEP(object) ? T : NIL; + } + else if (CONSP(type)) { + if (OBJECT_TYPE(object) == LispStruct_t && + SYMBOLP(CAR(type)) && ATOMID(CAR(type)) == Sstruct && + SYMBOLP(CAR(CDR(type))) && CDR(CDR(type)) == NIL) { + result = ATOMID(CAR(object->data.struc.def)) == + ATOMID(CAR(CDR(type))) ? T : NIL; + } + } + else if (type == NIL) + result = object == NIL ? T : NIL; + else if (type == T) + result = object == T ? T : NIL; + if (result == NULL) + LispDestroy("%s: bad type specification %s", + STRFUN(builtin), STROBJ(type)); + + return (result); +} + +LispObj * +Lisp_Union(LispBuiltin *builtin) +/* + union list1 list2 &key test test-not key + */ +{ + return (LispListSet(builtin, UNION)); +} + +LispObj * +Lisp_Nunion(LispBuiltin *builtin) +/* + nunion list1 list2 &key test test-not key + */ +{ + return (LispListSet(builtin, NUNION)); +} + +LispObj * +Lisp_Unless(LispBuiltin *builtin) +/* + unless test &rest body + */ +{ + LispObj *result, *test, *body; + + body = ARGUMENT(1); + test = ARGUMENT(0); + + result = NIL; + test = EVAL(test); + RETURN_COUNT = 0; + if (test == NIL) { + for (; CONSP(body); body = CDR(body)) + result = EVAL(CAR(body)); + } + + return (result); +} + +/* + * ext::until + */ +LispObj * +Lisp_Until(LispBuiltin *builtin) +/* + until test &rest body + */ +{ + LispObj *result, *test, *body, *prog; + + body = ARGUMENT(1); + test = ARGUMENT(0); + + result = NIL; + for (;;) { + if ((result = EVAL(test)) == NIL) { + for (prog = body; CONSP(prog); prog = CDR(prog)) + (void)EVAL(CAR(prog)); + } + else + break; + } + + return (result); +} + +LispObj * +Lisp_UnwindProtect(LispBuiltin *builtin) +/* + unwind-protect protect &rest cleanup + */ +{ + LispObj *result, **presult = &result; + int did_jump, *pdid_jump = &did_jump, destroyed; + LispBlock *block; + + LispObj *protect, *cleanup, **pcleanup = &cleanup; + + cleanup = ARGUMENT(1); + protect = ARGUMENT(0); + + /* run protected code */ + *presult = NIL; + *pdid_jump = 1; + block = LispBeginBlock(NIL, LispBlockProtect); + if (setjmp(block->jmp) == 0) { + *presult = EVAL(protect); + *pdid_jump = 0; + } + LispEndBlock(block); + if (!lisp__data.destroyed && *pdid_jump) + *presult = lisp__data.block.block_ret; + + destroyed = lisp__data.destroyed; + lisp__data.destroyed = 0; + + /* run cleanup, unprotected code */ + if (CONSP(*pcleanup)) + for (; CONSP(cleanup); cleanup = CDR(cleanup)) + (void)EVAL(CAR(cleanup)); + + if (destroyed) { + /* in case there is another unwind-protect */ + LispBlockUnwind(NULL); + /* if not, just return to the toplevel */ + lisp__data.destroyed = 1; + LispDestroy("."); + } + + return (result); +} + +static LispObj * +LispValuesList(LispBuiltin *builtin, int check_list) +{ + long i, count; + LispObj *result; + + LispObj *list; + + list = ARGUMENT(0); + + count = LispLength(list) - 1; + + if (count >= 0) { + result = CAR(list); + if ((RETURN_CHECK(count)) != count) + LispDestroy("%s: too many values", STRFUN(builtin)); + RETURN_COUNT = count; + for (i = 0, list = CDR(list); count && CONSP(list); + count--, i++, list = CDR(list)) + RETURN(i) = CAR(list); + if (check_list) { + CHECK_LIST(list); + } + } + else { + RETURN_COUNT = -1; + result = NIL; + } + + return (result); +} + +LispObj * +Lisp_Values(LispBuiltin *builtin) +/* + values &rest objects + */ +{ + return (LispValuesList(builtin, 0)); +} + +LispObj * +Lisp_ValuesList(LispBuiltin *builtin) +/* + values-list list + */ +{ + return (LispValuesList(builtin, 1)); +} + +LispObj * +Lisp_Vector(LispBuiltin *builtin) +/* + vector &rest objects + */ +{ + LispObj *objects; + + objects = ARGUMENT(0); + + return (VECTOR(objects)); +} + +LispObj * +Lisp_When(LispBuiltin *builtin) +/* + when test &rest body + */ +{ + LispObj *result, *test, *body; + + body = ARGUMENT(1); + test = ARGUMENT(0); + + result = NIL; + test = EVAL(test); + RETURN_COUNT = 0; + if (test != NIL) { + for (; CONSP(body); body = CDR(body)) + result = EVAL(CAR(body)); + } + + return (result); +} + +/* + * ext::while + */ +LispObj * +Lisp_While(LispBuiltin *builtin) +/* + while test &rest body + */ +{ + LispObj *result, *test, *body, *prog; + + body = ARGUMENT(1); + test = ARGUMENT(0); + + result = NIL; + for (;;) { + if (EVAL(test) != NIL) { + for (prog = body; CONSP(prog); prog = CDR(prog)) + (void)EVAL(CAR(prog)); + } + else + break; + } + + return (NIL); +} + +/* + * ext::unsetenv + */ +LispObj * +Lisp_Unsetenv(LispBuiltin *builtin) +/* + unsetenv name + */ +{ + char *name; + + LispObj *oname; + + oname = ARGUMENT(0); + + CHECK_STRING(oname); + name = THESTR(oname); + + unsetenv(name); + + return (NIL); +} + +LispObj * +Lisp_XeditEltStore(LispBuiltin *builtin) +/* + lisp::elt-store sequence index value + */ +{ + int length, offset; + + LispObj *sequence, *oindex, *value; + + value = ARGUMENT(2); + oindex = ARGUMENT(1); + sequence = ARGUMENT(0); + + CHECK_INDEX(oindex); + offset = FIXNUM_VALUE(oindex); + length = LispLength(sequence); + + if (offset >= length) + LispDestroy("%s: index %d too large for sequence length %d", + STRFUN(builtin), offset, length); + + if (STRINGP(sequence)) { + int ch; + + CHECK_STRING_WRITABLE(sequence); + CHECK_SCHAR(value); + ch = SCHAR_VALUE(value); + if (ch < 0 || ch > 255) + LispDestroy("%s: cannot represent character %d", + STRFUN(builtin), ch); + THESTR(sequence)[offset] = ch; + } + else { + if (ARRAYP(sequence)) + sequence = sequence->data.array.list; + + for (; offset > 0; offset--, sequence = CDR(sequence)) + ; + RPLACA(sequence, value); + } + + return (value); +} + +LispObj * +Lisp_XeditPut(LispBuiltin *builtin) +/* + lisp::put symbol indicator value + */ +{ + LispObj *symbol, *indicator, *value; + + value = ARGUMENT(2); + indicator = ARGUMENT(1); + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + + return (CAR(LispPutAtomProperty(symbol->data.atom, indicator, value))); +} + +LispObj * +Lisp_XeditSetSymbolPlist(LispBuiltin *builtin) +/* + lisp::set-symbol-plist symbol list + */ +{ + LispObj *symbol, *list; + + list = ARGUMENT(1); + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + + return (LispReplaceAtomPropertyList(symbol->data.atom, list)); +} + +LispObj * +Lisp_XeditVectorStore(LispBuiltin *builtin) +/* + lisp::vector-store array &rest values + */ +{ + LispObj *value, *list, *object; + long rank, count, sequence, offset, accum; + + LispObj *array, *values; + + values = ARGUMENT(1); + array = ARGUMENT(0); + + /* check for errors */ + for (rank = 0, list = values; + CONSP(list) && CONSP(CDR(list)); + list = CDR(list), rank++) { + CHECK_INDEX(CAR(values)); + } + + if (rank == 0) + LispDestroy("%s: too few subscripts", STRFUN(builtin)); + value = CAR(list); + + if (STRINGP(array) && rank == 1) { + long ch; + long length = STRLEN(array); + long offset = FIXNUM_VALUE(CAR(values)); + + CHECK_SCHAR(value); + CHECK_STRING_WRITABLE(array); + ch = SCHAR_VALUE(value); + if (offset >= length) + LispDestroy("%s: index %ld too large for sequence length %ld", + STRFUN(builtin), offset, length); + + if (ch < 0 || ch > 255) + LispDestroy("%s: cannot represent character %ld", + STRFUN(builtin), ch); + THESTR(array)[offset] = ch; + + return (value); + } + + CHECK_ARRAY(array); + if (rank != array->data.array.rank) + LispDestroy("%s: too %s subscripts", STRFUN(builtin), + rank < array->data.array.rank ? "few" : "many"); + + for (list = values, object = array->data.array.dim; + CONSP(CDR(list)); + list = CDR(list), object = CDR(object)) { + if (FIXNUM_VALUE(CAR(list)) >= FIXNUM_VALUE(CAR(object))) + LispDestroy("%s: %ld is out of range, index %ld", + STRFUN(builtin), + FIXNUM_VALUE(CAR(list)), + FIXNUM_VALUE(CAR(object))); + } + + for (count = sequence = 0, list = values; + CONSP(CDR(list)); + list = CDR(list), sequence++) { + for (offset = 0, object = array->data.array.dim; + offset < sequence; object = CDR(object), offset++) + ; + for (accum = 1, object = CDR(object); CONSP(object); + object = CDR(object)) + accum *= FIXNUM_VALUE(CAR(object)); + count += accum * FIXNUM_VALUE(CAR(list)); + } + + for (array = array->data.array.list; count > 0; array = CDR(array), count--) + ; + + RPLACA(array, value); + + return (value); +} + +LispObj * +Lisp_XeditDocumentationStore(LispBuiltin *builtin) +/* + lisp::documentation-store symbol type string + */ +{ + LispDocType_t doc_type; + + LispObj *symbol, *type, *string; + + string = ARGUMENT(2); + type = ARGUMENT(1); + symbol = ARGUMENT(0); + + CHECK_SYMBOL(symbol); + + /* type is checked in LispDocumentationType() */ + doc_type = LispDocumentationType(builtin, type); + + if (string == NIL) + /* allow explicitly releasing memory used for documentation */ + LispRemDocumentation(symbol, doc_type); + else { + CHECK_STRING(string); + LispAddDocumentation(symbol, string, doc_type); + } + + return (string); +} diff --git a/lisp/core.h b/lisp/core.h new file mode 100644 index 0000000..403a75a --- /dev/null +++ b/lisp/core.h @@ -0,0 +1,221 @@ +/* + * 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/core.h,v 1.35 2002/12/20 04:32:46 paulo Exp $ */ + +#ifndef Lisp_core_h +#define Lisp_core_h + +#include "internal.h" + +void LispCoreInit(void); + +LispObj *Lisp_Acons(LispBuiltin*); +LispObj *Lisp_Adjoin(LispBuiltin*); +LispObj *Lisp_Append(LispBuiltin*); +LispObj *Lisp_And(LispBuiltin*); +LispObj *Lisp_Aref(LispBuiltin*); +LispObj *Lisp_Assoc(LispBuiltin*); +LispObj *Lisp_AssocIf(LispBuiltin*); +LispObj *Lisp_AssocIfNot(LispBuiltin*); +LispObj *Lisp_Apply(LispBuiltin*); +LispObj *Lisp_Atom(LispBuiltin*); +LispObj *Lisp_Block(LispBuiltin*); +LispObj *Lisp_Boundp(LispBuiltin*); +LispObj *Lisp_Butlast(LispBuiltin*); +LispObj *Lisp_Nbutlast(LispBuiltin*); +LispObj *Lisp_Car(LispBuiltin*); +LispObj *Lisp_Case(LispBuiltin*); +LispObj *Lisp_Catch(LispBuiltin*); +LispObj *Lisp_Cdr(LispBuiltin*); +LispObj *Lisp_C_r(LispBuiltin*); +LispObj *Lisp_Coerce(LispBuiltin*); +LispObj *Lisp_Cond(LispBuiltin*); +LispObj *Lisp_Cons(LispBuiltin*); +LispObj *Lisp_Consp(LispBuiltin*); +LispObj *Lisp_Constantp(LispBuiltin*); +LispObj *Lisp_CopyAlist(LispBuiltin*); +LispObj *Lisp_CopyList(LispBuiltin*); +LispObj *Lisp_CopyTree(LispBuiltin*); +LispObj *Lisp_Defconstant(LispBuiltin*); +LispObj *Lisp_Defmacro(LispBuiltin*); +LispObj *Lisp_Defun(LispBuiltin*); +LispObj *Lisp_Defsetf(LispBuiltin*); +LispObj *Lisp_Defparameter(LispBuiltin*); +LispObj *Lisp_Defvar(LispBuiltin*); +LispObj *Lisp_Delete(LispBuiltin*); +LispObj *Lisp_DeleteDuplicates(LispBuiltin*); +LispObj *Lisp_DeleteIf(LispBuiltin*); +LispObj *Lisp_DeleteIfNot(LispBuiltin*); +LispObj *Lisp_Do(LispBuiltin*); +LispObj *Lisp_DoP(LispBuiltin*); +LispObj *Lisp_Documentation(LispBuiltin*); +LispObj *Lisp_DoList(LispBuiltin*); +LispObj *Lisp_DoTimes(LispBuiltin*); +LispObj *Lisp_Elt(LispBuiltin*); +LispObj *Lisp_Endp(LispBuiltin*); +LispObj *Lisp_Eq(LispBuiltin*); +LispObj *Lisp_Eql(LispBuiltin*); +LispObj *Lisp_Equal(LispBuiltin*); +LispObj *Lisp_Equalp(LispBuiltin*); +LispObj *Lisp_Error(LispBuiltin*); +LispObj *Lisp_Eval(LispBuiltin*); +LispObj *Lisp_Every(LispBuiltin*); +LispObj *Lisp_Some(LispBuiltin*); +LispObj *Lisp_Notevery(LispBuiltin*); +LispObj *Lisp_Notany(LispBuiltin*); +LispObj *Lisp_Fboundp(LispBuiltin*); +LispObj *Lisp_Find(LispBuiltin*); +LispObj *Lisp_FindIf(LispBuiltin*); +LispObj *Lisp_FindIfNot(LispBuiltin*); +LispObj *Lisp_Fill(LispBuiltin*); +LispObj *Lisp_Fmakunbound(LispBuiltin*); +LispObj *Lisp_Functionp(LispBuiltin*); +LispObj *Lisp_Funcall(LispBuiltin*); +LispObj *Lisp_Gc(LispBuiltin*); +LispObj *Lisp_Gensym(LispBuiltin*); +LispObj *Lisp_Get(LispBuiltin*); +LispObj *Lisp_Getenv(LispBuiltin*); +LispObj *Lisp_Go(LispBuiltin*); +LispObj *Lisp_If(LispBuiltin*); +LispObj *Lisp_IgnoreErrors(LispBuiltin*); +LispObj *Lisp_Intersection(LispBuiltin*); +LispObj *Lisp_Nintersection(LispBuiltin*); +LispObj *Lisp_Keywordp(LispBuiltin*); +LispObj *Lisp_Lambda(LispBuiltin*); +LispObj *Lisp_Last(LispBuiltin*); +LispObj *Lisp_Let(LispBuiltin*); +LispObj *Lisp_Length(LispBuiltin*); +LispObj *Lisp_LetP(LispBuiltin*); +LispObj *Lisp_List(LispBuiltin*); +LispObj *Lisp_ListLength(LispBuiltin*); +LispObj *Lisp_ListP(LispBuiltin*); +LispObj *Lisp_Listp(LispBuiltin*); +LispObj *Lisp_Loop(LispBuiltin*); +LispObj *Lisp_MakeArray(LispBuiltin*); +LispObj *Lisp_MakeList(LispBuiltin*); +LispObj *Lisp_MakeSymbol(LispBuiltin*); +LispObj *Lisp_Makunbound(LispBuiltin*); +LispObj *Lisp_Mapc(LispBuiltin*); +LispObj *Lisp_Mapcar(LispBuiltin*); +LispObj *Lisp_Mapcan(LispBuiltin*); +LispObj *Lisp_Mapl(LispBuiltin*); +LispObj *Lisp_Maplist(LispBuiltin*); +LispObj *Lisp_Mapcon(LispBuiltin*); +LispObj *Lisp_Member(LispBuiltin*); +LispObj *Lisp_MemberIf(LispBuiltin*); +LispObj *Lisp_MemberIfNot(LispBuiltin*); +LispObj *Lisp_MultipleValueBind(LispBuiltin*); +LispObj *Lisp_MultipleValueCall(LispBuiltin*); +LispObj *Lisp_MultipleValueProg1(LispBuiltin*); +LispObj *Lisp_MultipleValueList(LispBuiltin*); +LispObj *Lisp_MultipleValueSetq(LispBuiltin*); +LispObj *Lisp_Nconc(LispBuiltin*); +LispObj *Lisp_Nreverse(LispBuiltin*); +LispObj *Lisp_NsetDifference(LispBuiltin*); +LispObj *Lisp_Nsubstitute(LispBuiltin*); +LispObj *Lisp_NsubstituteIf(LispBuiltin*); +LispObj *Lisp_NsubstituteIfNot(LispBuiltin*); +LispObj *Lisp_Nth(LispBuiltin*); +LispObj *Lisp_Nthcdr(LispBuiltin*); +LispObj *Lisp_NthValue(LispBuiltin*); +LispObj *Lisp_Null(LispBuiltin*); +LispObj *Lisp_Or(LispBuiltin*); +LispObj *Lisp_Pairlis(LispBuiltin*); +LispObj *Lisp_Pop(LispBuiltin*); +LispObj *Lisp_Position(LispBuiltin*); +LispObj *Lisp_PositionIf(LispBuiltin*); +LispObj *Lisp_PositionIfNot(LispBuiltin*); +LispObj *Lisp_Proclaim(LispBuiltin*); +LispObj *Lisp_Prog1(LispBuiltin*); +LispObj *Lisp_Prog2(LispBuiltin*); +LispObj *Lisp_Progn(LispBuiltin*); +LispObj *Lisp_Progv(LispBuiltin*); +LispObj *Lisp_Provide(LispBuiltin*); +LispObj *Lisp_Push(LispBuiltin*); +LispObj *Lisp_Pushnew(LispBuiltin*); +LispObj *Lisp_Quit(LispBuiltin*); +LispObj *Lisp_Quote(LispBuiltin*); +LispObj *Lisp_Remove(LispBuiltin*); +LispObj *Lisp_RemoveDuplicates(LispBuiltin*); +LispObj *Lisp_RemoveIf(LispBuiltin*); +LispObj *Lisp_RemoveIfNot(LispBuiltin*); +LispObj *Lisp_Remprop(LispBuiltin*); +LispObj *Lisp_Replace(LispBuiltin*); +LispObj *Lisp_Return(LispBuiltin*); +LispObj *Lisp_ReturnFrom(LispBuiltin*); +LispObj *Lisp_Reverse(LispBuiltin*); +LispObj *Lisp_Rplaca(LispBuiltin*); +LispObj *Lisp_Rplacd(LispBuiltin*); +LispObj *Lisp_Search(LispBuiltin*); +LispObj *Lisp_Setenv(LispBuiltin*); +LispObj *Lisp_Set(LispBuiltin*); +LispObj *Lisp_SetDifference(LispBuiltin*); +LispObj *Lisp_SetExclusiveOr(LispBuiltin*); +LispObj *Lisp_NsetExclusiveOr(LispBuiltin*); +LispObj *Lisp_Setf(LispBuiltin*); +LispObj *Lisp_Psetf(LispBuiltin*); +LispObj *Lisp_SetQ(LispBuiltin*); +LispObj *Lisp_Psetq(LispBuiltin*); +LispObj *Lisp_Sleep(LispBuiltin*); +LispObj *Lisp_Sort(LispBuiltin*); +LispObj *Lisp_Subseq(LispBuiltin*); +LispObj *Lisp_Subsetp(LispBuiltin*); +LispObj *Lisp_Substitute(LispBuiltin*); +LispObj *Lisp_SubstituteIf(LispBuiltin*); +LispObj *Lisp_SubstituteIfNot(LispBuiltin*); +LispObj *Lisp_Symbolp(LispBuiltin*); +LispObj *Lisp_SymbolFunction(LispBuiltin*); +LispObj *Lisp_SymbolName(LispBuiltin*); +LispObj *Lisp_SymbolPackage(LispBuiltin*); +LispObj *Lisp_SymbolPlist(LispBuiltin*); +LispObj *Lisp_SymbolValue(LispBuiltin*); +LispObj *Lisp_Tagbody(LispBuiltin*); +LispObj *Lisp_Throw(LispBuiltin*); +LispObj *Lisp_The(LispBuiltin*); +LispObj *Lisp_TreeEqual(LispBuiltin*); +LispObj *Lisp_Typep(LispBuiltin*); +LispObj *Lisp_Union(LispBuiltin*); +LispObj *Lisp_Nunion(LispBuiltin*); +LispObj *Lisp_Unless(LispBuiltin*); +LispObj *Lisp_Until(LispBuiltin*); +LispObj *Lisp_Unsetenv(LispBuiltin*); +LispObj *Lisp_UnwindProtect(LispBuiltin*); +LispObj *Lisp_Values(LispBuiltin*); +LispObj *Lisp_ValuesList(LispBuiltin*); +LispObj *Lisp_Vector(LispBuiltin*); +LispObj *Lisp_When(LispBuiltin*); +LispObj *Lisp_While(LispBuiltin*); +LispObj *Lisp_XeditEltStore(LispBuiltin*); +LispObj *Lisp_XeditPut(LispBuiltin*); +LispObj *Lisp_XeditSetSymbolPlist(LispBuiltin*); +LispObj *Lisp_XeditVectorStore(LispBuiltin*); +LispObj *Lisp_XeditDocumentationStore(LispBuiltin*); + +#endif diff --git a/lisp/debugger.c b/lisp/debugger.c new file mode 100644 index 0000000..4716699 --- /dev/null +++ b/lisp/debugger.c @@ -0,0 +1,828 @@ +/* + * 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/debugger.c,v 1.24 2002/11/12 06:05:07 paulo Exp $ */ + +#include <ctype.h> +#include "io.h" +#include "debugger.h" +#include "write.h" + +#ifdef DEBUGGER +#define DebuggerHelp 0 +#define DebuggerAbort 1 +#define DebuggerBacktrace 2 +#define DebuggerContinue 3 +#define DebuggerFinish 4 +#define DebuggerFrame 5 +#define DebuggerNext 6 +#define DebuggerPrint 7 +#define DebuggerStep 8 +#define DebuggerBreak 9 +#define DebuggerDelete 10 +#define DebuggerDown 11 +#define DebuggerUp 12 +#define DebuggerInfo 13 +#define DebuggerWatch 14 + +#define DebuggerInfoBreakpoints 0 +#define DebuggerInfoBacktrace 1 + +/* + * Prototypes + */ +static char *format_integer(int); +static void LispDebuggerCommand(LispObj *obj); + +/* + * Initialization + */ +static struct { + char *name; + int action; +} commands[] = { + {"help", DebuggerHelp}, + {"abort", DebuggerAbort}, + {"backtrace", DebuggerBacktrace}, + {"b", DebuggerBreak}, + {"break", DebuggerBreak}, + {"bt", DebuggerBacktrace}, + {"continue", DebuggerContinue}, + {"d", DebuggerDelete}, + {"delete", DebuggerDelete}, + {"down", DebuggerDown}, + {"finish", DebuggerFinish}, + {"frame", DebuggerFrame}, + {"info", DebuggerInfo}, + {"n", DebuggerNext}, + {"next", DebuggerNext}, + {"print", DebuggerPrint}, + {"run", DebuggerContinue}, + {"s", DebuggerStep}, + {"step", DebuggerStep}, + {"up", DebuggerUp}, + {"watch", DebuggerWatch}, +}; + +static struct { + char *name; + int subaction; +} info_commands[] = { + {"breakpoints", DebuggerInfoBreakpoints}, + {"stack", DebuggerInfoBacktrace}, + {"watchpoints", DebuggerInfoBreakpoints}, +}; + +static char debugger_help[] = +"Available commands are:\n\ +\n\ +help - This message.\n\ +abort - Abort the current execution, and return to toplevel.\n\ +backtrace, bt - Print backtrace.\n\ +b, break - Set breakpoint at function name argument.\n\ +continue - Continue execution.\n\ +d, delete - Delete breakpoint(s), all breakpoint if no arguments given.\n\ +down - Set environment to frame called by the current one.\n\ +finish - Executes until current form is finished.\n\ +frame - Set environment to selected frame.\n\ +info - Prints information about the debugger state.\n\ +n, next - Evaluate next form.\n\ +print - Print value of variable name argument.\n\ +run - Continue execution.\n\ +s, step - Evaluate next form, stopping on any subforms.\n\ +up - Set environment to frame that called the current one.\n\ +\n\ +Commands may be abbreviated.\n"; + +static char debugger_info_help[] = +"Available subcommands are:\n\ +\n\ +breakpoints - List and prints status of breakpoints, and watchpoints.\n\ +stack - Backtrace of stack.\n\ +watchpoints - List and prints status of watchpoints, and breakpoints.\n\ +\n\ +Subcommands may be abbreviated.\n"; + +/* Debugger variables layout (if you change it, update description): + * + * DBG + * is a macro for lisp__data.dbglist + * is a NIL terminated list + * every element is a list in the format (NOT NIL terminated): + * (list* NAM ARG ENV HED LEX) + * where + * NAM is an ATOM for the function/macro name + * or NIL for lambda expressions + * ARG is NAM arguments (a LIST) + * ENV is the value of lisp__data.stack.base (a FIXNUM) + * LEN is the value of lisp__data.env.length (a FIXNUM) + * LEX is the value of lisp__data.env.lex (a FIXNUM) + * new elements are added to the beggining of the DBG list + * + * BRK + * is macro for lisp__data.brklist + * is a NIL terminated list + * every element is a list in the format (NIL terminated): + * (list NAM IDX TYP HIT VAR VAL FRM) + * where + * NAM is an ATOM for the name of the object at + * wich the breakpoint was added + * IDX is a FIXNUM, the breakpoint number + * must be stored, as breakpoints may be deleted + * TYP is a FIXNUM that must be an integer of enum LispBreakType + * HIT is a FIXNUM, with the number of times this breakpoint was + * hitted. + * VAR variable to watch a SYMBOL (not needed for breakpoints) + * VAL value of watched variable (not needed for breakpoints) + * FRM frame where variable started being watched + * (not needed for breakpoints) + * new elements are added to the end of the list + */ + +/* + * Implementation + */ +void +LispDebugger(LispDebugCall call, LispObj *name, LispObj *arg) +{ + int force = 0; + LispObj *obj, *prev; + + switch (call) { + case LispDebugCallBegin: + ++lisp__data.debug_level; + GCDisable(); + DBG = CONS(CONS(name, CONS(arg, CONS(FIXNUM(lisp__data.stack.base), + CONS(FIXNUM(lisp__data.env.length), + FIXNUM(lisp__data.env.lex))))), DBG); + GCEnable(); + for (obj = BRK; obj != NIL; obj = CDR(obj)) + if (ATOMID(CAR(CAR(obj))) == ATOMID(name) && + FIXNUM_VALUE(CAR(CDR(CDR(CAR(obj))))) == + LispDebugBreakFunction) + break; + if (obj != NIL) { + long counter; + + /* if not at a fresh line */ + if (LispGetColumn(NIL)) + LispFputc(Stdout, '\n'); + LispFputs(Stdout, "BREAK #"); + LispWriteObject(NIL, CAR(CDR(CAR(obj)))); + LispFputs(Stdout, "> ("); + LispWriteObject(NIL, CAR(CAR(DBG))); + LispFputc(Stdout, ' '); + LispWriteObject(NIL, CAR(CDR(CAR(DBG)))); + LispFputs(Stdout, ")\n"); + force = 1; + /* update hits counter */ + counter = FIXNUM_VALUE(CAR(CDR(CDR(CDR(CAR(obj)))))); + CAR(CDR(CDR(CDR(CAR(obj))))) FIXNUM(counter + 1); + } + break; + case LispDebugCallEnd: + DBG = CDR(DBG); + if (lisp__data.debug_level < lisp__data.debug_step) + lisp__data.debug_step = lisp__data.debug_level; + --lisp__data.debug_level; + break; + case LispDebugCallFatal: + LispDebuggerCommand(NIL); + return; + case LispDebugCallWatch: + break; + } + + /* didn't return, check watchpoints */ + if (call == LispDebugCallEnd || call == LispDebugCallWatch) { +watch_again: + for (prev = obj = BRK; obj != NIL; prev = obj, obj = CDR(obj)) { + if (FIXNUM_VALUE(CAR(CDR(CDR(CAR(obj))))) == + LispDebugBreakVariable) { + /* the variable */ + LispObj *wat = CAR(CDR(CDR(CDR(CDR(CAR(obj)))))); + void *sym = LispGetVarAddr(CAAR(obj)); + LispObj *frm = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(obj)))))))); + + if ((sym == NULL && lisp__data.debug_level <= 0) || + (sym != wat->data.opaque.data && + FIXNUM_VALUE(frm) > lisp__data.debug_level)) { + LispFputs(Stdout, "WATCH #"); + LispFputs(Stdout, format_integer(FIXNUM_VALUE(CAR(CDR(CAR(obj)))))); + LispFputs(Stdout, "> "); + LispFputs(Stdout, STRPTR(CAR(CAR(obj)))); + LispFputs(Stdout, " deleted. Variable does not exist anymore.\n"); + /* force debugger to stop */ + force = 1; + if (obj == prev) { + BRK = CDR(BRK); + goto watch_again; + } + else + RPLACD(prev, CDR(obj)); + obj = prev; + } + else { + /* current value */ + LispObj *cur = *(LispObj**)wat->data.opaque.data; + /* last value */ + LispObj *val = CAR(CDR(CDR(CDR(CDR(CDR(CAR(obj))))))); + if (XEQUAL(val, cur) == NIL) { + long counter; + + LispFputs(Stdout, "WATCH #"); + LispFputs(Stdout, format_integer(FIXNUM_VALUE(CAR(CDR(CAR(obj)))))); + LispFputs(Stdout, "> "); + LispFputs(Stdout, STRPTR(CAR(CAR(obj)))); + LispFputc(Stdout, '\n'); + + LispFputs(Stdout, "OLD: "); + LispWriteObject(NIL, val); + + LispFputs(Stdout, "\nNEW: "); + LispWriteObject(NIL, cur); + LispFputc(Stdout, '\n'); + + /* update current value */ + CAR(CDR(CDR(CDR(CDR(CDR(CAR(obj))))))) = cur; + /* update hits counter */ + counter = FIXNUM_VALUE(CAR(CDR(CDR(CDR(CAR(obj)))))); + CAR(CDR(CDR(CDR(CAR(obj))))) = FIXNUM(counter + 1); + /* force debugger to stop */ + force = 1; + } + } + } + } + + if (call == LispDebugCallWatch) + /* special call, just don't keep gc protected variables that may be + * using a lot of memory... */ + return; + } + + switch (lisp__data.debug) { + case LispDebugUnspec: + LispDebuggerCommand(NIL); + goto debugger_done; + case LispDebugRun: + if (force) + LispDebuggerCommand(NIL); + goto debugger_done; + case LispDebugFinish: + if (!force && + (call != LispDebugCallEnd || + lisp__data.debug_level != lisp__data.debug_step)) + goto debugger_done; + break; + case LispDebugNext: + if (call == LispDebugCallBegin) { + if (!force && lisp__data.debug_level != lisp__data.debug_step) + goto debugger_done; + } + else if (call == LispDebugCallEnd) { + if (!force && lisp__data.debug_level >= lisp__data.debug_step) + goto debugger_done; + } + break; + case LispDebugStep: + break; + } + + if (call == LispDebugCallBegin) { + LispFputc(Stdout, '#'); + LispFputs(Stdout, format_integer(lisp__data.debug_level)); + LispFputs(Stdout, "> ("); + LispWriteObject(NIL, CAR(CAR(DBG))); + LispFputc(Stdout, ' '); + LispWriteObject(NIL, CAR(CDR(CAR(DBG)))); + LispFputs(Stdout, ")\n"); + LispDebuggerCommand(NIL); + } + else if (call == LispDebugCallEnd) { + LispFputc(Stdout, '#'); + LispFputs(Stdout, format_integer(lisp__data.debug_level + 1)); + LispFputs(Stdout, "= "); + LispWriteObject(NIL, arg); + LispFputc(Stdout, '\n'); + LispDebuggerCommand(NIL); + } + else if (force) + LispDebuggerCommand(arg); + +debugger_done: + return; +} + +static void +LispDebuggerCommand(LispObj *args) +{ + LispObj *obj, *frm, *curframe; + int i = 0, frame, matches, action = -1, subaction = 0; + char *cmd, *arg, *ptr, line[256]; + + int envbase = lisp__data.stack.base, + envlen = lisp__data.env.length, + envlex = lisp__data.env.lex; + + frame = lisp__data.debug_level; + curframe = CAR(DBG); + + line[0] = '\0'; + arg = line; + for (;;) { + LispFputs(Stdout, DBGPROMPT); + LispFflush(Stdout); + if (LispFgets(Stdin, line, sizeof(line)) == NULL) { + LispFputc(Stdout, '\n'); + return; + } + /* get command */ + ptr = line; + while (*ptr && isspace(*ptr)) + ++ptr; + cmd = ptr; + while (*ptr && !isspace(*ptr)) + ++ptr; + if (*ptr) + *ptr++ = '\0'; + + if (*cmd) { /* if *cmd is nul, then arg may be still set */ + /* get argument(s) */ + while (*ptr && isspace(*ptr)) + ++ptr; + arg = ptr; + /* goto end of line */ + if (*ptr) { + while (*ptr) + ++ptr; + --ptr; + while (*ptr && isspace(*ptr)) + --ptr; + if (*ptr) + *++ptr = '\0'; + } + } + + if (*cmd == '\0') { + if (action < 0) { + if (lisp__data.debug == LispDebugFinish) + action = DebuggerFinish; + else if (lisp__data.debug == LispDebugNext) + action = DebuggerNext; + else if (lisp__data.debug == LispDebugStep) + action = DebuggerStep; + else if (lisp__data.debug == LispDebugRun) + action = DebuggerContinue; + else + continue; + } + } + else { + for (i = matches = 0; i < sizeof(commands) / sizeof(commands[0]); + i++) { + char *str = commands[i].name; + + ptr = cmd; + while (*ptr && *ptr == *str) { + ++ptr; + ++str; + } + if (*ptr == '\0') { + action = commands[i].action; + if (*str == '\0') { + matches = 1; + break; + } + ++matches; + } + } + if (matches == 0) { + LispFputs(Stdout, "* Command unknown: "); + LispFputs(Stdout, cmd); + LispFputs(Stdout, ". Type help for help.\n"); + continue; + } + else if (matches > 1) { + LispFputs(Stdout, "* Command is ambiguous: "); + LispFputs(Stdout, cmd); + LispFputs(Stdout, ". Type help for help.\n"); + continue; + } + } + + switch (action) { + case DebuggerHelp: + LispFputs(Stdout, debugger_help); + break; + case DebuggerInfo: + if (*arg == '\0') { + LispFputs(Stdout, debugger_info_help); + break; + } + + for (i = matches = 0; + i < sizeof(info_commands) / sizeof(info_commands[0]); + i++) { + char *str = info_commands[i].name; + + ptr = arg; + while (*ptr && *ptr == *str) { + ++ptr; + ++str; + } + if (*ptr == '\0') { + subaction = info_commands[i].subaction; + if (*str == '\0') { + matches = 1; + break; + } + ++matches; + } + } + if (matches == 0) { + LispFputs(Stdout, "* Command unknown: "); + LispFputs(Stdout, arg); + LispFputs(Stdout, ". Type info for help.\n"); + continue; + } + else if (matches > 1) { + LispFputs(Stdout, "* Command is ambiguous: "); + LispFputs(Stdout, arg); + LispFputs(Stdout, ". Type info for help.\n"); + continue; + } + + switch (subaction) { + case DebuggerInfoBreakpoints: + LispFputs(Stdout, "Num\tHits\tType\t\tWhat\n"); + for (obj = BRK; obj != NIL; obj = CDR(obj)) { + /* breakpoint number */ + LispFputc(Stdout, '#'); + LispWriteObject(NIL, CAR(CDR(CAR(obj)))); + + /* number of hits */ + LispFputc(Stdout, '\t'); + LispWriteObject(NIL, CAR(CDR(CDR(CDR(CAR(obj)))))); + + /* breakpoint type */ + LispFputc(Stdout, '\t'); + switch ((int)FIXNUM_VALUE(CAR(CDR(CDR(CAR(obj)))))) { + case LispDebugBreakFunction: + LispFputs(Stdout, "Function"); + break; + case LispDebugBreakVariable: + LispFputs(Stdout, "Variable"); + break; + } + + /* breakpoint object */ + LispFputc(Stdout, '\t'); + LispWriteObject(NIL, CAR(CAR(obj))); + LispFputc(Stdout, '\n'); + } + break; + case DebuggerInfoBacktrace: + goto debugger_print_backtrace; + } + break; + case DebuggerAbort: + 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; + LispTopLevel(); + if (!lisp__data.running) { + LispMessage("*** Fatal: nowhere to longjmp."); + abort(); + } + /* don't need to restore environment */ + siglongjmp(lisp__data.jmp, 1); + /*NOTREACHED*/ + break; + case DebuggerBreak: + for (ptr = arg; *ptr; ptr++) { + if (isspace(*ptr)) + break; + else + *ptr = toupper(*ptr); + } + + if (!*arg || *ptr || strchr(arg, '(') || strchr(arg, '(') || + strchr(arg, ';')) { + LispFputs(Stdout, "* Bad function name '"); + LispFputs(Stdout, arg); + LispFputs(Stdout, "' specified.\n"); + } + else { + for (obj = frm = BRK; obj != NIL; frm = obj, obj = CDR(obj)) + ; + i = lisp__data.debug_break; + ++lisp__data.debug_break; + GCDisable(); + obj = CONS(ATOM(arg), + CONS(FIXNUM(i), + CONS(FIXNUM(LispDebugBreakFunction), + CONS(FIXNUM(0), NIL)))); + if (BRK == NIL) + BRK = CONS(obj, NIL); + else + RPLACD(frm, CONS(obj, NIL)); + GCEnable(); + } + break; + case DebuggerWatch: { + void *sym; + int vframe; + LispObj *val, *atom; + + /* make variable name uppercase, an ATOM */ + ptr = arg; + while (*ptr) { + *ptr = toupper(*ptr); + ++ptr; + } + atom = ATOM(arg); + val = LispGetVar(atom); + if (val == NULL) { + LispFputs(Stdout, "* No variable named '"); + LispFputs(Stdout, arg); + LispFputs(Stdout, "' in the selected frame.\n"); + break; + } + + /* variable is available at the current frame */ + sym = LispGetVarAddr(atom); + + /* find the lowest frame where the variable is visible */ + vframe = 0; + if (frame > 0) { + for (; vframe < frame; vframe++) { + for (frm = DBG, i = lisp__data.debug_level; i > vframe; + frm = CDR(frm), i--) + ; + obj = CAR(frm); + lisp__data.stack.base = FIXNUM_VALUE(CAR(CDR(CDR(obj)))); + lisp__data.env.length = FIXNUM_VALUE(CAR(CDR(CDR(CDR(obj))))); + lisp__data.env.lex = FIXNUM_VALUE(CDR(CDR(CDR(CDR(obj))))); + + if (LispGetVarAddr(atom) == sym) + /* got variable initial frame */ + break; + } + vframe = i; + if (vframe != frame) { + /* restore environment */ + for (frm = DBG, i = lisp__data.debug_level; i > frame; + frm = CDR(frm), i--) + ; + obj = CAR(frm); + lisp__data.stack.base = FIXNUM_VALUE(CAR(CDR(CDR(obj)))); + lisp__data.env.length = FIXNUM_VALUE(CAR(CDR(CDR(CDR(obj))))); + lisp__data.env.lex = FIXNUM_VALUE(CDR(CDR(CDR(CDR(obj))))); + } + } + + i = lisp__data.debug_break; + ++lisp__data.debug_break; + for (obj = frm = BRK; obj != NIL; frm = obj, obj = CDR(obj)) + ; + + GCDisable(); + obj = CONS(atom, /* NAM */ + CONS(FIXNUM(i), /* IDX */ + CONS(FIXNUM(LispDebugBreakVariable), /* TYP */ + CONS(FIXNUM(0), /* HIT */ + CONS(OPAQUE(sym, 0), /* VAR */ + CONS(val, /* VAL */ + CONS(FIXNUM(vframe),/* FRM */ + NIL))))))); + + /* add watchpoint */ + if (BRK == NIL) + BRK = CONS(obj, NIL); + else + RPLACD(frm, CONS(obj, NIL)); + GCEnable(); + } break; + case DebuggerDelete: + if (*arg == 0) { + int confirm = 0; + + for (;;) { + int ch; + + LispFputs(Stdout, "* Delete all breakpoints? (y or n) "); + LispFflush(Stdout); + if ((ch = LispFgetc(Stdin)) == '\n') + continue; + while ((i = LispFgetc(Stdin)) != '\n' && i != EOF) + ; + if (tolower(ch) == 'n') + break; + else if (tolower(ch) == 'y') { + confirm = 1; + break; + } + } + if (confirm) + BRK = NIL; + } + else { + for (ptr = arg; *ptr;) { + while (*ptr && isdigit(*ptr)) + ++ptr; + if (*ptr && !isspace(*ptr)) { + *ptr = '\0'; + LispFputs(Stdout, "* Bad breakpoint number '"); + LispFputs(Stdout, arg); + LispFputs(Stdout, "' specified.\n"); + break; + } + i = atoi(arg); + for (obj = frm = BRK; frm != NIL; + obj = frm, frm = CDR(frm)) + if (FIXNUM_VALUE(CAR(CDR(CAR(frm)))) == i) + break; + if (frm == NIL) { + LispFputs(Stdout, "* No breakpoint number "); + LispFputs(Stdout, arg); + LispFputs(Stdout, " available.\n"); + break; + } + if (obj == frm) + BRK = CDR(BRK); + else + RPLACD(obj, CDR(frm)); + while (*ptr && isspace(*ptr)) + ++ptr; + arg = ptr; + } + } + break; + case DebuggerFrame: + i = -1; + ptr = arg; + if (*ptr) { + i = 0; + while (*ptr && isdigit(*ptr)) { + i *= 10; + i += *ptr - '0'; + ++ptr; + } + if (*ptr) { + LispFputs(Stdout, "* Frame identifier must " + "be a positive number.\n"); + break; + } + } + else + goto debugger_print_frame; + if (i >= 0 && i <= lisp__data.debug_level) + goto debugger_new_frame; + LispFputs(Stdout, "* No such frame "); + LispFputs(Stdout, format_integer(i)); + LispFputs(Stdout, ".\n"); + break; + case DebuggerDown: + if (frame + 1 > lisp__data.debug_level) { + LispFputs(Stdout, "* Cannot go down.\n"); + break; + } + i = frame + 1; + goto debugger_new_frame; + break; + case DebuggerUp: + if (frame == 0) { + LispFputs(Stdout, "* Cannot go up.\n"); + break; + } + i = frame - 1; + goto debugger_new_frame; + break; + case DebuggerPrint: + ptr = arg; + while (*ptr) { + *ptr = toupper(*ptr); + ++ptr; + } + obj = LispGetVar(ATOM(arg)); + if (obj != NULL) { + LispWriteObject(NIL, obj); + LispFputc(Stdout, '\n'); + } + else { + LispFputs(Stdout, "* No variable named '"); + LispFputs(Stdout, arg); + LispFputs(Stdout, "' in the selected frame.\n"); + } + break; + case DebuggerBacktrace: +debugger_print_backtrace: + if (DBG == NIL) { + LispFputs(Stdout, "* No stack.\n"); + break; + } + DBG = LispReverse(DBG); + for (obj = DBG, i = 0; obj != NIL; obj = CDR(obj), i++) { + frm = CAR(obj); + LispFputc(Stdout, '#'); + LispFputs(Stdout, format_integer(i)); + LispFputs(Stdout, "> ("); + LispWriteObject(NIL, CAR(frm)); + LispFputc(Stdout, ' '); + LispWriteObject(NIL, CAR(CDR(frm))); + LispFputs(Stdout, ")\n"); + } + DBG = LispReverse(DBG); + break; + case DebuggerContinue: + lisp__data.debug = LispDebugRun; + goto debugger_command_done; + case DebuggerFinish: + if (lisp__data.debug != LispDebugFinish) { + lisp__data.debug_step = lisp__data.debug_level - 2; + lisp__data.debug = LispDebugFinish; + } + else + lisp__data.debug_step = lisp__data.debug_level - 1; + goto debugger_command_done; + case DebuggerNext: + if (lisp__data.debug != LispDebugNext) { + lisp__data.debug = LispDebugNext; + lisp__data.debug_step = lisp__data.debug_level + 1; + } + goto debugger_command_done; + case DebuggerStep: + lisp__data.debug = LispDebugStep; + goto debugger_command_done; + } + continue; + +debugger_new_frame: + /* goto here with i as the new frame value, after error checking */ + if (i != frame) { + frame = i; + for (frm = DBG, i = lisp__data.debug_level; + i > frame; frm = CDR(frm), i--) + ; + curframe = CAR(frm); + lisp__data.stack.base = FIXNUM_VALUE(CAR(CDR(CDR(curframe)))); + lisp__data.env.length = FIXNUM_VALUE(CAR(CDR(CDR(CDR(curframe))))); + lisp__data.env.lex = FIXNUM_VALUE(CDR(CDR(CDR(CDR(curframe))))); + } +debugger_print_frame: + LispFputc(Stdout, '#'); + LispFputs(Stdout, format_integer(frame)); + LispFputs(Stdout, "> ("); + LispWriteObject(NIL, CAR(curframe)); + LispFputc(Stdout, ' '); + LispWriteObject(NIL, CAR(CDR(curframe))); + LispFputs(Stdout, ")\n"); + } + +debugger_command_done: + lisp__data.stack.base = envbase; + lisp__data.env.length = envlen; + lisp__data.env.lex = envlex; +} + +static char * +format_integer(int integer) +{ + static char buffer[16]; + + sprintf(buffer, "%d", integer); + + return (buffer); +} + +#endif /* DEBUGGER */ diff --git a/lisp/debugger.h b/lisp/debugger.h new file mode 100644 index 0000000..98bd962 --- /dev/null +++ b/lisp/debugger.h @@ -0,0 +1,72 @@ +/* + * 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/debugger.h,v 1.7 2002/11/08 08:00:56 paulo Exp $ */ + +#ifndef Lisp_debugger_h +#define Lisp_debugger_h + +/* + * Definitions + */ +#define DBGPROMPT "DEBUG> " +#ifdef DEBUGGER + +/* + * Types + */ +typedef enum _LispDebugState { + LispDebugUnspec, /* initial state */ + LispDebugRun, /* just run, until breakpoint or error */ + LispDebugFinish, /* evaluates until selected form is finished */ + LispDebugNext, /* evaluate form */ + LispDebugStep /* evaluate form, and step on subforms */ +} LispDebugState; + +typedef enum _LispDebugCall { + LispDebugCallBegin, + LispDebugCallEnd, + LispDebugCallFatal, + LispDebugCallWatch /* just remove watched variables that lost context */ +} LispDebugCall; + +typedef enum _LispDebugBreak { + LispDebugBreakFunction, + LispDebugBreakVariable +} LispDebugBreak; + +#include "private.h" + +/* + * Prototypes + */ +void LispDebugger(LispDebugCall, LispObj*, LispObj*); + +#endif /* DEBUGGER */ +#endif /* Lisp_debugger_h */ diff --git a/lisp/env.c b/lisp/env.c new file mode 100644 index 0000000..a5da90c --- /dev/null +++ b/lisp/env.c @@ -0,0 +1,151 @@ +/* + * Provide setenv() and unsetenv() on platforms that don't have them. + * From FreeBSD's libc. + */ + +/* + * Copyright (c) 1987, 1993 + * The Regents of the University of California. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +/* $XFree86: xc/programs/xedit/lisp/env.c,v 1.1 2002/03/05 03:52:34 dawes Exp $ */ + + +#include <stdlib.h> +#include <stddef.h> +#include <string.h> + +extern char **environ; + +extern int setenv(const char *name, const char *value, int overwrite); +extern void unsetenv(const char *name); + +static char * +findenv(const char *name, int *offset) +{ + int len, i; + const char *np; + char **p, *cp; + + if (name == NULL || environ == NULL) + return NULL; + + for (np = name; *np && *np != '='; ++np) + continue; + len = np - name; + for (p = environ; (cp = *p) != NULL; ++p) { + for (np = name, i = len; i && *cp; i--) + if (*cp++ != *np++) + break; + if (i == 0 && *cp++ == '=') { + *offset = p - environ; + return cp; + } + } + return NULL; +} + +/* + * setenv -- + * Set the value of the environmental variable "name" to be + * "value". If overwrite is set, replace any current value. + */ + +int +setenv(const char *name, const char *value, int overwrite) +{ + static char **alloced; /* if allocated space before */ + char *c; + int l_value, offset; + + if (*value == '=') /* no '=' in value */ + ++value; + l_value = strlen(value); + if ((c = findenv(name, &offset))) { /* find if already exists */ + if (!overwrite) + return 0; + if (strlen(c) >= l_value) { /* old larger; copy over */ + while ((*c++ = *value++)) + ; + return 0; + } + } else { /* create new slot */ + int cnt; + char **p; + + for (p = environ, cnt = 0; *p; ++p, ++cnt) + ; + if (alloced == environ) { /* just increase size */ + p = (char **)realloc((char *)environ, + sizeof(char *) * (cnt + 2)); + if (!p) + return -1; + alloced = environ = p; + } else { /* get new space */ + /* copy old entries into it */ + p = malloc(sizeof(char *) * (cnt + 2)); + if (!p) + return -1; + memcpy(p, environ, cnt * sizeof(char *)); + alloced = environ = p; + } + environ[cnt + 1] = NULL; + offset = cnt; + } + for (c = (char *)name; *c && *c != '='; ++c) /* no '=' in name */ + ; + if (!(environ[offset] = /* name + '=' + value */ + malloc((int)(c - name) + l_value + 2))) + return -1; + for (c = environ[offset]; (*c = *name++) && *c != '='; ++c) + ; + for (*c++ = '='; (*c++ = *value++); ) + ; + return 0; +} + +/* + * unsetenv(name) -- + * Delete environmental variable "name". + */ + +void +unsetenv(const char *name) +{ + char **p; + int offset; + + while (findenv(name, &offset)) /* if set multiple times */ + for (p = &environ[offset];; ++p) + if (!(*p = *(p + 1))) + break; +} + diff --git a/lisp/format.c b/lisp/format.c new file mode 100644 index 0000000..aa593d6 --- /dev/null +++ b/lisp/format.c @@ -0,0 +1,2121 @@ +/* + * Copyright (c) 2002 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/format.c,v 1.28 2002/11/30 23:13:11 paulo Exp $ */ + +#include "io.h" +#include "write.h" +#include "format.h" +#include <ctype.h> + +#define MAXFMT 8 +#define NOERROR 0 + +/* parse error codes */ +#define PARSE_2MANYPARM 1 /* too many directive parameters */ +#define PARSE_2MANYATS 2 /* more than one @ in directive */ +#define PARSE_2MANYCOLS 3 /* more than one : in directive */ +#define PARSE_NOARGSLEFT 4 /* no arguments left to format */ +#define PARSE_BADFMTARG 5 /* argument is not an integer or char */ +#define PARSE_BADDIRECTIVE 6 /* unknown format directive */ +#define PARSE_BADINTEGER 7 /* bad integer representation */ + +/* merge error codes */ +#define MERGE_2MANY 1 /* too many parameters to directive */ +#define MERGE_NOCHAR 2 /* parameter must be a character */ +#define MERGE_NOINT 3 /* parameter must be an integer */ + +/* generic error codes */ +#define GENERIC_RADIX 1 /* radix not in range 2-36 */ +#define GENERIC_NEGATIVE 2 /* parameter is negative */ +#define GENERIC_BADSTRING 3 /* argument is not a string */ +#define GENERIC_BADLIST 4 /* argument is not a list */ + +#define IF_SPECIFIED(arg) (arg).specified ? &((arg).value) : NULL + +#define UPANDOUT_NORMAL 1 +#define UPANDOUT_COLLON 2 +#define UPANDOUT_HASH 4 /* only useful inside a ~{ iteration + * forces loop finalization. */ + +#define ITERATION_NORMAL 1 +#define ITERATION_LAST 2 + +/* + * Types + */ +/* parameter to format */ +typedef struct { + unsigned int achar : 1; /* value was specified as a character */ + unsigned int specified : 1; /* set if value was specified */ + unsigned int offset : 30; /* offset in format string, for error printing */ + int value; +} FmtArg; + +/* information about format parameters */ +typedef struct { + unsigned int atsign : 1; /* @ specified */ + unsigned int collon : 1; /* : specified */ + unsigned int command : 8; /* the format command */ + unsigned int count : 4; /* number of arguments processed */ + unsigned int offset : 10; /* offset in format string, for error printing */ + char *base, *format; + FmtArg arguments[MAXFMT]; +} FmtArgs; + +/* used for combining default format parameter values */ +typedef struct { + int achar; + int value; +} FmtDef; + +/* number of default format parameter values and defaults */ +typedef struct { + int count; + FmtDef defaults[MAXFMT]; +} FmtDefs; + +/* used on recursive calls to LispFormat */ +typedef struct { + FmtArgs args; + LispObj *base_arguments; /* pointer to first format argument */ + int total_arguments; /* number of objects in base_arguments */ + char **format; /* if need to update format string pointer */ + LispObj **object; /* CAR(arguments), for plural check */ + LispObj **arguments; /* current element of base_arguments */ + int *num_arguments; /* number of arguments after arguments */ + int upandout; /* information for recursive calls */ + int iteration; /* only set if in ~:{... or ~:@{ and in the + * last argument list, hint for upandout */ +} FmtInfo; + +/* + * Prototypes + */ +static void merge_arguments(FmtArgs*, FmtDefs*, int*); +static char *parse_arguments(char*, FmtArgs*, int*, LispObj**, int*); +static void merge_error(FmtArgs*, int); +static void parse_error(FmtArgs*, int); +static void generic_error(FmtArgs*, int); +static void format_error(FmtArgs*, char*); + +static int format_object(LispObj*, LispObj*); + +static void format_ascii(LispObj*, LispObj*, FmtArgs*); +static void format_in_radix(LispObj*, LispObj*, int, FmtArgs*); +static void format_radix_special(LispObj*, LispObj*, FmtArgs*); +static void format_roman(LispObj*, LispObj*, FmtArgs*); +static void format_english(LispObj*, LispObj*, FmtArgs*); +static void format_character(LispObj*, LispObj*, FmtArgs*); +static void format_fixed_float(LispObj*, LispObj*, FmtArgs*); +static void format_exponential_float(LispObj*, LispObj*, FmtArgs*); +static void format_general_float(LispObj*, LispObj*, FmtArgs*); +static void format_dollar_float(LispObj*, LispObj*, FmtArgs*); +static void format_tabulate(LispObj*, FmtArgs*); + +static void format_goto(FmtInfo*); +static void format_indirection(LispObj*, LispObj*, FmtInfo*); + +static void list_formats(FmtInfo*, int, char**, char***, int*, int*, int*, int*); +static void free_formats(char**, int); + +static void format_case_conversion(LispObj*, FmtInfo*); +static void format_conditional(LispObj*, FmtInfo*); +static void format_iterate(LispObj*, FmtInfo*); +static void format_justify(LispObj*, FmtInfo*); + +static void LispFormat(LispObj*, FmtInfo*); + +/* + * Initialization + */ +static FmtDefs AsciiDefs = { + 4, + { + {0, 0}, /* mincol */ + {0, 1}, /* colinc */ + {0, 0}, /* minpad */ + {1, ' '}, /* padchar */ + }, +}; + +static FmtDefs IntegerDefs = { + 4, + { + {0, 0}, /* mincol */ + {1, ' '}, /* padchar */ + {1, ','}, /* commachar */ + {0, 3}, /* commainterval */ + }, +}; + +static FmtDefs RadixDefs = { + 5, + { + {0, 10}, /* radix */ + {0, 0}, /* mincol */ + {1, ' '}, /* padchar */ + {1, ','}, /* commachar */ + {0, 3}, /* commainterval */ + }, +}; + +static FmtDefs NoneDefs = { + 0, +}; + +static FmtDefs FixedFloatDefs = { + 5, + { + {0, 0}, /* w */ + {0, 16}, /* d */ + {0, 0}, /* k */ + {1, '\0'}, /* overflowchar */ + {1, ' '}, /* padchar */ + }, +}; + +static FmtDefs ExponentialFloatDefs = { + 7, + { + {0, 0}, /* w */ + {0, 16}, /* d */ + {0, 0}, /* e */ + {0, 1}, /* k */ + {1, '\0'}, /* overflowchar */ + {1, ' '}, /* padchar */ + {1, 'E'}, /* exponentchar */ + /* XXX if/when more than one float format, + * should default to object type */ + }, +}; + +static FmtDefs DollarFloatDefs = { + 4, + { + {0, 2}, /* d */ + {0, 1}, /* n */ + {0, 0}, /* w */ + {1, ' '}, /* padchar */ + }, +}; + +static FmtDefs OneDefs = { + 1, + { + {0, 1}, + }, +}; + +static FmtDefs TabulateDefs = { + 2, + { + {0, 0}, /* colnum */ + {0, 1}, /* colinc */ + }, +}; + +extern LispObj *Oprint_escape; + +/* + * Implementation + */ +static void +merge_arguments(FmtArgs *arguments, FmtDefs *defaults, int *code) +{ + int count; + FmtDef *defaul; + FmtArg *argument; + + defaul = &(defaults->defaults[0]); + argument = &(arguments->arguments[0]); + for (count = 0; count < defaults->count; count++, argument++, defaul++) { + if (count >= arguments->count) + argument->specified = 0; + if (argument->specified) { + if (argument->achar != defaul->achar) { + *code = defaul->achar ? MERGE_NOCHAR : MERGE_NOINT; + arguments->offset = argument->offset; + return; + } + } + else { + argument->specified = 0; + argument->achar = defaul->achar; + argument->value = defaul->value; + } + } + + /* check if extra arguments were provided */ + if (arguments->count > defaults->count) + *code = MERGE_2MANY; +} + +/* the pointer arguments may be null, useful when just testing/parsing + * the directive parameters */ +static char * +parse_arguments(char *format, FmtArgs *arguments, + int *num_objects, LispObj **objects, int *code) +{ + int test; + char *ptr; + FmtArg *argument; + unsigned int tmpcmd = 0; + + /* initialize */ + test = objects == NULL || code == NULL || num_objects == NULL; + ptr = format; + argument = &(arguments->arguments[0]); + arguments->atsign = arguments->collon = arguments->command = 0; + + /* parse format parameters */ + for (arguments->count = 0;; arguments->count++) { + arguments->offset = ptr - format + 1; + if (arguments->count >= MAXFMT) { + if (!test) + *code = PARSE_2MANYPARM; + return (ptr); + } + if (*ptr == '\'') { /* character parameter value */ + ++ptr; /* skip ' */ + argument->achar = argument->specified = 1; + argument->value = *ptr++; + } + else if (*ptr == ',') { /* use default parameter value */ + argument->achar = 0; + argument->specified = 0; + /* don't increment ptr, will be incremented below */ + } + else if (*ptr == '#') { /* number of arguments is value */ + ++ptr; /* skip # */ + argument->achar = 0; + argument->specified = 1; + if (!test) + argument->value = *num_objects; + } + else if (*ptr == 'v' || + *ptr == 'V') { /* format object argument is value */ + LispObj *object; + + ++ptr; /* skip V */ + if (!test) { + if (!CONSP(*objects)) { + *code = PARSE_NOARGSLEFT; + return (ptr); + } + object = CAR((*objects)); + if (FIXNUMP(object)) { + argument->achar = 0; + argument->specified = 1; + argument->value = FIXNUM_VALUE(object); + } + else if (SCHARP(object)) { + argument->achar = argument->specified = 1; + argument->value = SCHAR_VALUE(object); + } + else { + *code = PARSE_BADFMTARG; + return (ptr); + } + *objects = CDR(*objects); + --*num_objects; + } + } + else if (isdigit(*ptr) || + *ptr == '-' || *ptr == '+') { /* integer parameter value */ + int sign; + + argument->achar = 0; + argument->specified = 1; + if (!isdigit(*ptr)) { + sign = *ptr++ == '-'; + } + else + sign = 0; + if (!test && !isdigit(*ptr)) { + *code = PARSE_BADINTEGER; + return (ptr); + } + argument->value = *ptr++ - '0'; + while (isdigit(*ptr)) { + argument->value = (argument->value * 10) + (*ptr++ - '0'); + if (argument->value > 65536) { + if (!test) { + *code = PARSE_BADINTEGER; + return (ptr); + } + } + } + if (sign) + argument->value = -argument->value; + } + else /* no more arguments to format */ + break; + + if (*ptr == ',') + ++ptr; + + /* remember offset of format parameter, for better error printing */ + argument->offset = arguments->offset; + argument++; + } + + /* check for extra flags */ + for (;;) { + if (*ptr == '@') { /* check for special parameter atsign */ + if (arguments->atsign) { + if (!test) { + *code = PARSE_2MANYATS; + return (ptr); + } + } + ++ptr; + ++arguments->offset; + arguments->atsign = 1; + } + else if (*ptr == ':') { /* check for special parameter collon */ + if (arguments->collon) { + if (!test) { + *code = PARSE_2MANYCOLS; + return (ptr); + } + } + ++ptr; + ++arguments->offset; + arguments->collon = 1; + } + else /* next value is format command */ + break; + } + + if (!test) + *code = NOERROR; + arguments->command = *ptr++; + tmpcmd = arguments->command; + if (islower(tmpcmd)) + arguments->command = toupper(tmpcmd); + ++arguments->offset; + + return (ptr); +} + +static void +parse_error(FmtArgs *args, int code) +{ + static char *errors[] = { + NULL, + "too many parameters to directive", + "too many @ parameters", + "too many : parameters", + "no arguments left to format", + "argument is not a fixnum integer or a character", + "unknown format directive", + "parameter is not a fixnum integer", + }; + + format_error(args, errors[code]); +} + +static void +merge_error(FmtArgs *args, int code) +{ + static char *errors[] = { + NULL, + "too many parameters to directive", + "argument must be a character", + "argument must be a fixnum integer", + }; + + format_error(args, errors[code]); +} + +static void +generic_error(FmtArgs *args, int code) +{ + static char *errors[] = { + NULL, + "radix must be in the range 2 to 36, inclusive", + "parameter must be positive", + "argument must be a string", + "argument must be a list", + }; + + format_error(args, errors[code]); +} + +static void +format_error(FmtArgs *args, char *str) +{ + char *message; + int errorlen, formatlen; + + /* number of bytes of format to be printed */ + formatlen = (args->format - args->base) + args->offset; + + /* length of specific error message */ + errorlen = strlen(str) + 1; /* plus '\n' */ + + /* XXX allocate string with LispMalloc, + * so that it will be freed in LispTopLevel */ + message = LispMalloc(formatlen + errorlen + 1); + + sprintf(message, "%s\n", str); + memcpy(message + errorlen, args->base, formatlen); + message[errorlen + formatlen] = '\0'; + + LispDestroy("FORMAT: %s", message); +} + +static int +format_object(LispObj *stream, LispObj *object) +{ + int length; + + length = LispWriteObject(stream, object); + + return (length); +} + +static void +format_ascii(LispObj *stream, LispObj *object, FmtArgs *args) +{ + GC_ENTER(); + LispObj *string = NIL; + int length = 0, + atsign = args->atsign, + collon = args->collon, + mincol = args->arguments[0].value, + colinc = args->arguments[1].value, + minpad = args->arguments[2].value, + padchar = args->arguments[3].value; + + /* check/correct arguments */ + if (mincol < 0) + mincol = 0; + if (colinc < 0) + colinc = 1; + if (minpad < 0) + minpad = 0; + /* XXX pachar can be the null character? */ + + if (object == NIL) + length = collon ? 2 : 3; /* () or NIL */ + + /* left padding */ + if (atsign) { + /* if length not yet known */ + if (object == NIL) { + string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); + GC_PROTECT(string); + length = LispWriteObject(string, object); + } + + /* output minpad characters at left */ + if (minpad) { + length += minpad; + LispWriteChars(stream, padchar, minpad); + } + + if (colinc) { + /* puts colinc spaces at a time, + * until at least mincol chars out */ + while (length < mincol) { + LispWriteChars(stream, padchar, colinc); + length += colinc; + } + } + } + + if (object == NIL) { + if (collon) + LispWriteStr(stream, "()", 2); + else + LispWriteStr(stream, Snil, 3); + } + else { + /* if string is not NIL, atsign was specified + * and object printed to string */ + if (string == NIL) + length = format_object(stream, object); + else { + int size; + char *str = LispGetSstring(SSTREAMP(string), &size); + + LispWriteStr(stream, str, size); + } + } + + /* right padding */ + if (!atsign) { + /* output minpad characters at left */ + if (minpad) { + length += minpad; + LispWriteChars(stream, padchar, minpad); + } + if (colinc) { + /* puts colinc spaces at a time, + * until at least mincol chars out */ + while (length < mincol) { + LispWriteChars(stream, padchar, colinc); + length += colinc; + } + } + } + + GC_LEAVE(); +} + +/* assumes radix is 0 or in range 2 - 36 */ +static void +format_in_radix(LispObj *stream, LispObj *object, int radix, FmtArgs *args) +{ + if (INTEGERP(object)) { + int i, check, atsign, collon, mincol, padchar, commachar, commainterval; + + i = check = (radix == 0); + atsign = args->atsign; + collon = args->collon; + if (radix == 0) { + radix = args->arguments[0].value; + if (radix < 2 || radix > 36) { + args->offset = args->arguments[0].offset; + generic_error(args, GENERIC_RADIX); + } + } + mincol = args->arguments[i++].value; + padchar = args->arguments[i++].value; + commachar = args->arguments[i++].value; + commainterval = args->arguments[i++].value; + + LispFormatInteger(stream, object, radix, atsign, collon, + mincol, padchar, commachar, commainterval); + } + else + format_object(stream, object); +} + +static void +format_radix_special(LispObj *stream, LispObj *object, FmtArgs *args) +{ + if (FIXNUMP(object)) { + if (args->atsign) + format_roman(stream, object, args); + else + format_english(stream, object, args); + } + else + format_object(stream, object); +} + +static void +format_roman(LispObj *stream, LispObj *object, FmtArgs *args) +{ + long value = 0; + int cando, new_roman = args->collon == 0; + + if (FIXNUMP(object)) { + value = FIXNUM_VALUE(object); + if (new_roman) + cando = value >= 1 && value <= 3999; + else + cando = value >= 1 && value <= 4999; + } + else + cando = 0; + + if (cando) + LispFormatRomanInteger(stream, value, new_roman); + else + format_object(stream, object); +} + +static void +format_english(LispObj *stream, LispObj *object, FmtArgs *args) +{ + int cando; + long number = 0; + + if (FIXNUMP(object)) { + number = FIXNUM_VALUE(object); + cando = number >= -999999999 && number <= 999999999; + } + else + cando = 0; + + if (cando) + LispFormatEnglishInteger(stream, number, args->collon); + else + format_object(stream, object); +} + +static void +format_character(LispObj *stream, LispObj *object, FmtArgs *args) +{ + if (SCHARP(object)) + LispFormatCharacter(stream, object, args->atsign, args->collon); + else + format_object(stream, object); +} + +static void +format_fixed_float(LispObj *stream, LispObj *object, FmtArgs *args) +{ + if (FLOATP(object)) + LispFormatFixedFloat(stream, object, args->atsign, + args->arguments[0].value, + IF_SPECIFIED(args->arguments[1]), + args->arguments[2].value, + args->arguments[3].value, + args->arguments[4].value); + else + format_object(stream, object); +} + +static void +format_exponential_float(LispObj *stream, LispObj *object, FmtArgs *args) +{ + if (FLOATP(object)) + LispFormatExponentialFloat(stream, object, args->atsign, + args->arguments[0].value, + IF_SPECIFIED(args->arguments[1]), + args->arguments[2].value, + args->arguments[3].value, + args->arguments[4].value, + args->arguments[5].value, + args->arguments[6].value); + else + format_object(stream, object); +} + +static void +format_general_float(LispObj *stream, LispObj *object, FmtArgs *args) +{ + if (FLOATP(object)) + LispFormatGeneralFloat(stream, object, args->atsign, + args->arguments[0].value, + IF_SPECIFIED(args->arguments[1]), + args->arguments[2].value, + args->arguments[3].value, + args->arguments[4].value, + args->arguments[5].value, + args->arguments[6].value); + else + format_object(stream, object); +} + +static void +format_dollar_float(LispObj *stream, LispObj *object, FmtArgs *args) +{ + if (FLOATP(object)) + LispFormatDollarFloat(stream, object, + args->atsign, args->collon, + args->arguments[0].value, + args->arguments[1].value, + args->arguments[2].value, + args->arguments[3].value); + else + format_object(stream, object); +} + +static void +format_tabulate(LispObj *stream, FmtArgs *args) +{ + int atsign = args->atsign, + colnum = args->arguments[0].value, + colinc = args->arguments[1].value, + column; + + column = LispGetColumn(stream); + + if (atsign) { + /* relative tabulation */ + if (colnum > 0) { + LispWriteChars(stream, ' ', colnum); + column += colnum; + } + /* tabulate until at a multiple of colinc */ + if (colinc > 0) + LispWriteChars(stream, ' ', colinc - (column % colinc)); + } + else { + /* if colinc not specified, just move to given column */ + if (colinc <= 0) + LispWriteChars(stream, ' ', column - colnum); + else { + /* always output at least colinc spaces */ + do { + LispWriteChars(stream, ' ', colinc); + colnum -= colinc; + } while (colnum > column); + } + } +} + +static void +format_goto(FmtInfo *info) +{ + int count, num_arguments; + LispObj *object, *arguments; + + /* number of arguments to ignore or goto offset */ + count = info->args.arguments[0].value; + if (count < 0) + generic_error(&(info->args), GENERIC_NEGATIVE); + + if (info->args.atsign) { + /* absolute goto */ + + /* if not specified, defaults to zero */ + if (!(info->args.arguments[0].specified)) + count = 0; + + /* if offset too large */ + if (count > info->total_arguments) + parse_error(&(info->args), PARSE_NOARGSLEFT); + else if (count != info->total_arguments - *(info->num_arguments)) { + /* calculate new parameters */ + object = NIL; + arguments = info->base_arguments; + num_arguments = info->total_arguments - count; + + for (; count > 0; count--, arguments = CDR(arguments)) + object = CAR(arguments); + + /* update format information */ + *(info->object) = object; + *(info->arguments) = arguments; + *(info->num_arguments) = num_arguments; + } + } + else if (count) { + /* relative goto, ignore or go back count arguments */ + + /* prepare to update parameters */ + arguments = *(info->arguments); + num_arguments = *(info->num_arguments); + + /* go back count arguments? */ + if (info->args.collon) + count = -count; + + num_arguments -= count; + + if (count > 0) { + if (count > *(info->num_arguments)) + parse_error(&(info->args), PARSE_NOARGSLEFT); + + object = *(info->object); + for (; count > 0; count--, arguments = CDR(arguments)) + object = CAR(arguments); + } + else { /* count < 0 */ + if (info->total_arguments + count - *(info->num_arguments) < 0) + parse_error(&(info->args), PARSE_NOARGSLEFT); + + object = NIL; + arguments = info->base_arguments; + for (count = 0; count < info->total_arguments - num_arguments; + count++, arguments = CDR(arguments)) + object = CAR(arguments); + } + + /* update format parameters */ + *(info->object) = object; + *(info->arguments) = arguments; + *(info->num_arguments) = num_arguments; + } +} + +static void +format_indirection(LispObj *stream, LispObj *format, FmtInfo *info) +{ + char *string; + LispObj *object; + FmtInfo indirect_info; + + if (!STRINGP(format)) + generic_error(&(info->args), GENERIC_BADSTRING); + string = THESTR(format); + + /* most information is the same */ + memcpy(&indirect_info, info, sizeof(FmtInfo)); + + /* set new format string */ + indirect_info.args.base = indirect_info.args.format = string; + indirect_info.format = &string; + + if (info->args.atsign) { + /* use current arguments */ + + /* do the indirect format */ + LispFormat(stream, &indirect_info); + } + else { + /* next argument is the recursive call arguments */ + + int num_arguments; + + /* it is valid to not have a list following string, as string may + * not have format directives */ + if (CONSP(*(indirect_info.arguments))) + object = CAR(*(indirect_info.arguments)); + else + object = NIL; + + if (!LISTP(object) || !CONSP(*(info->arguments))) + generic_error(&(info->args), GENERIC_BADLIST); + + /* update information now */ + *(info->object) = object; + *(info->arguments) = CDR(*(info->arguments)); + *(info->num_arguments) -= 1; + + /* set arguments for recursive call */ + indirect_info.base_arguments = object; + indirect_info.arguments = &object; + for (num_arguments = 0; CONSP(object); object = CDR(object)) + ++num_arguments; + + /* note that indirect_info.arguments is a pointer to "object", + * keep it pointing to the correct object */ + object = indirect_info.base_arguments; + indirect_info.total_arguments = num_arguments; + indirect_info.num_arguments = &num_arguments; + + /* do the indirect format */ + LispFormat(stream, &indirect_info); + } +} + +/* update pointers to a list of format strings: + * for '(' and '{' only one list is required + * for '[' and '<' more than one may be returned + * has_default is only meaningful for '[' and '<' + * comma_width and line_width are only meaningful to '<', and + * only valid if has_default set + * if the string is finished prematurely, LispDestroy is called + * format_ptr is updated to the correct pointer in the "main" format string + */ +static void +list_formats(FmtInfo *info, int command, char **format_ptr, + char ***format_list, int *format_count, int *has_default, + int *comma_width, int *line_width) +{ + /* instead of processing the directives recursively, just separate the + * input formats in separate strings, then see if one of then need to + * be used */ + FmtArgs args; + int counters[] = { 0, 0, 0, 0}; + /* '[', '(', '{', '<' */ + char *format, *next_format, *start, **formats; + int num_formats, format_index, separator, add_format; + + /* initialize */ + formats = NULL; + num_formats = format_index = 0; + if (has_default != NULL) + *has_default = 0; + if (comma_width != NULL) + *comma_width = 0; + if (line_width != NULL) + *line_width = 0; + format = start = next_format = *format_ptr; + switch (command) { + case '[': counters[0] = 1; format_index = 0; break; + case '(': counters[1] = 1; format_index = 1; break; + case '{': counters[2] = 1; format_index = 2; break; + case '<': counters[3] = 1; format_index = 3; break; + } + +#define LIST_FORMATS_ADD 1 +#define LIST_FORMATS_DONE 2 + + /* fill list of format options to conditional */ + while (*format) { + if (*format == '~') { + separator = add_format = 0; + args.format = format + 1; + next_format = parse_arguments(format + 1, &args, NULL, NULL, NULL); + switch (args.command) { + case '[': ++counters[0]; break; + case ']': --counters[0]; break; + case '(': ++counters[1]; break; + case ')': --counters[1]; break; + case '{': ++counters[2]; break; + case '}': --counters[2]; break; + case '<': ++counters[3]; break; + case '>': --counters[3]; break; + case ';': separator = 1; break; + } + + /* check if a new format string must be added */ + if (separator && counters[format_index] == 1 && + (command == '[' || command == '<')) + add_format = LIST_FORMATS_ADD; + else if (counters[format_index] == 0) + add_format = LIST_FORMATS_DONE; + + if (add_format) { + int length = format - start; + + formats = LispRealloc(formats, + (num_formats + 1) * sizeof(char*)); + + formats[num_formats] = LispMalloc(length + 1); + strncpy(formats[num_formats], start, length); + formats[num_formats][length] = '\0'; + ++num_formats; + /* loop finished? */ + if (add_format == LIST_FORMATS_DONE) + break; + else if (command == '[' && has_default != NULL) + /* will be set only for the last parameter, what is + * expected, just don't warn about it in the incorrect + * place */ + *has_default = args.collon != 0; + else if (command == '<' && num_formats == 1) { + /* if the first parameter to '<', there may be overrides + * to comma-width and line-width */ + if (args.collon && has_default != NULL) { + *has_default = 1; + if (comma_width != NULL && + args.arguments[0].specified && + !args.arguments[0].achar) + *comma_width = args.arguments[0].value; + if (line_width != NULL && + args.arguments[1].specified && + !args.arguments[1].achar) + *line_width = args.arguments[1].value; + } + } + start = next_format; + } + format = next_format; + } + else + ++format; + } + + /* check if format string did not finish prematurely */ + if (counters[format_index] != 0) { + char error_message[64]; + + sprintf(error_message, "expecting ~%c", command); + format_error(&(info->args), error_message); + } + + /* update pointers */ + *format_list = formats; + *format_count = num_formats; + *format_ptr = next_format; +} + +static void +free_formats(char **formats, int num_formats) +{ + if (num_formats) { + while (--num_formats >= 0) + LispFree(formats[num_formats]); + LispFree(formats); + } +} + +static void +format_case_conversion(LispObj *stream, FmtInfo *info) +{ + GC_ENTER(); + LispObj *string; + FmtInfo case_info; + char *str, *ptr; + char *format, *next_format, **formats; + int atsign, collon, num_formats, length; + + atsign = info->args.atsign; + collon = info->args.collon; + + /* output to a string, before case conversion */ + string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); + GC_PROTECT(string); + + /* most information is the same */ + memcpy(&case_info, info, sizeof(FmtInfo)); + + /* list formats */ + next_format = *(info->format); + list_formats(info, '(', &next_format, &formats, &num_formats, + NULL, NULL, NULL); + + /* set new format string */ + format = formats[0]; + case_info.args.base = case_info.args.format = format; + case_info.format = &format; + + /* format text to string */ + LispFormat(string, &case_info); + + str = ptr = LispGetSstring(SSTREAMP(string), &length); + + /* do case conversion */ + if (!atsign && !collon) { + /* convert all upercase to lowercase */ + for (; *ptr; ptr++) { + if (isupper(*ptr)) + *ptr = tolower(*ptr); + } + } + else if (atsign && collon) { + /* convert all lowercase to upercase */ + for (; *ptr; ptr++) { + if (islower(*ptr)) + *ptr = toupper(*ptr); + } + } + else { + int upper = 1; + + /* skip non-alphanumeric characters */ + for (; *ptr; ptr++) + if (isalnum(*ptr)) + break; + + /* capitalize words */ + for (; *ptr; ptr++) { + if (isalnum(*ptr)) { + if (upper) { + if (islower(*ptr)) + *ptr = toupper(*ptr); + upper = 0; + } + else if (isupper(*ptr)) + *ptr = tolower(*ptr); + } + else + upper = collon; + /* if collon, capitalize all words, else just first word */ + } + } + + /* output case converted string */ + LispWriteStr(stream, str, length); + + /* temporary string stream is not necessary anymore */ + GC_LEAVE(); + + /* free temporary memory */ + free_formats(formats, num_formats); + + /* this information always updated */ + *(info->format) = next_format; +} + +static void +format_conditional(LispObj *stream, FmtInfo *info) +{ + LispObj *object, *arguments; + char *format, *next_format, **formats; + int choice, num_formats, has_default, num_arguments; + + /* save information that may change */ + object = *(info->object); + arguments = *(info->arguments); + num_arguments = *(info->num_arguments); + + /* initialize */ + choice = -1; + next_format = *(info->format); + + /* list formats */ + list_formats(info, '[', + &next_format, &formats, &num_formats, &has_default, NULL, NULL); + + /* ~:[false;true] */ + if (info->args.collon) { + /* one argument always consumed */ + if (!CONSP(arguments)) + parse_error(&(info->args), PARSE_NOARGSLEFT); + object = CAR(arguments); + arguments = CDR(arguments); + --num_arguments; + choice = object == NIL ? 0 : 1; + } + /* ~@[true] */ + else if (info->args.atsign) { + /* argument consumed only if nil, but one must be available */ + if (!CONSP(arguments)) + parse_error(&(info->args), PARSE_NOARGSLEFT); + if (CAR(arguments) != NIL) + choice = 0; + else { + object = CAR(arguments); + arguments = CDR(arguments); + --num_arguments; + } + } + /* ~n[...~] */ + else if (info->args.arguments[0].specified) + /* no arguments consumed */ + choice = info->args.arguments[0].value; + /* ~[...~] */ + else { + /* one argument consumed, it is the index in the available formats */ + if (!CONSP(arguments)) + parse_error(&(info->args), PARSE_NOARGSLEFT); + object = CAR(arguments); + arguments = CDR(arguments); + --num_arguments; + /* no error if it isn't a number? */ + if (FIXNUMP(object)) + choice = FIXNUM_VALUE(object); + } + + /* update anything that may have changed */ + *(info->object) = object; + *(info->arguments) = arguments; + *(info->num_arguments) = num_arguments; + + /* if choice is out of range check if there is a default choice */ + if (has_default && (choice < 0 || choice >= num_formats)) + choice = num_formats - 1; + + /* if one of the formats must be parsed */ + if (choice >= 0 && choice < num_formats) { + FmtInfo conditional_info; + + /* most information is the same */ + memcpy(&conditional_info, info, sizeof(FmtInfo)); + + /* set new format string */ + format = formats[choice]; + conditional_info.args.base = conditional_info.args.format = format; + conditional_info.format = &format; + + /* do the conditional format */ + LispFormat(stream, &conditional_info); + } + + /* free temporary memory */ + free_formats(formats, num_formats); + + /* this information always updated */ + *(info->format) = next_format; +} + +static void +format_iterate(LispObj *stream, FmtInfo *info) +{ + FmtInfo iterate_info; + LispObj *object, *arguments, *iarguments, *iobject; + char *format, *next_format, *loop_format, **formats; + int num_arguments, iterate, iterate_max, has_max, has_min, inum_arguments, + num_formats; + + /* save information that may change */ + object = *(info->object); + arguments = *(info->arguments); + num_arguments = *(info->num_arguments); + + /* initialize */ + iterate = has_min = 0; + next_format = *(info->format); + + /* if has_max set, iterate at most iterate_max times */ + has_max = info->args.arguments[0].specified; + iterate_max = info->args.arguments[0].value; + + /* list formats */ + list_formats(info, '{', &next_format, &formats, &num_formats, + NULL, NULL, NULL); + loop_format = formats[0]; + + /* most information is the same */ + memcpy(&iterate_info, info, sizeof(FmtInfo)); + + /* ~{...~} */ + if (!info->args.atsign && !info->args.collon) { + /* next argument is the argument list for the iteration */ + + /* fetch argument list, must exist */ + if (!CONSP(arguments)) + parse_error(&(info->args), PARSE_NOARGSLEFT); + iarguments = object = CAR(arguments); + object = CAR(arguments); + arguments = CDR(arguments); + --num_arguments; + + inum_arguments = 0; + if (CONSP(object)) { + /* count arguments to format */ + for (iobject = object; CONSP(iobject); iobject = CDR(iobject)) + ++inum_arguments; + } + else if (object != NIL) + generic_error(&(info->args), GENERIC_BADLIST); + + iobject = NIL; + + /* set new arguments to recursive calls */ + iarguments = object; + iterate_info.base_arguments = iarguments; + iterate_info.total_arguments = inum_arguments; + iterate_info.object = &iobject; + iterate_info.arguments = &iarguments; + iterate_info.num_arguments = &inum_arguments; + + /* iterate */ + for (;; iterate++) { + /* if maximum iterations done or all arguments consumed */ + if (has_max && iterate > iterate_max) + break; + else if (inum_arguments == 0 && (!has_min || iterate > 0)) + break; + + format = loop_format; + + /* set new format string */ + iterate_info.args.base = iterate_info.args.format = format; + iterate_info.format = &format; + + /* information for possible ~^, in this case ~:^ is a noop */ + iterate_info.iteration = ITERATION_NORMAL; + + /* do the format */ + LispFormat(stream, &iterate_info); + + /* check for forced loop break */ + if (iterate_info.upandout & UPANDOUT_HASH) + break; + } + } + /* ~:@{...~} */ + else if (info->args.atsign && info->args.collon) { + /* every following argument is the argument list for the iteration */ + + /* iterate */ + for (;; iterate++) { + /* if maximum iterations done or all arguments consumed */ + if (has_max && iterate > iterate_max) + break; + else if (num_arguments == 0 && (!has_min || iterate > 0)) + break; + + /* fetch argument list, must exist */ + if (!CONSP(arguments)) + parse_error(&(info->args), PARSE_NOARGSLEFT); + iarguments = object = CAR(arguments); + object = CAR(arguments); + arguments = CDR(arguments); + --num_arguments; + + inum_arguments = 0; + if (CONSP(object)) { + /* count arguments to format */ + for (iobject = object; CONSP(iobject); iobject = CDR(iobject)) + ++inum_arguments; + } + else if (object != NIL) + generic_error(&(info->args), GENERIC_BADLIST); + + iobject = NIL; + + /* set new arguments to recursive calls */ + iarguments = object; + iterate_info.base_arguments = iarguments; + iterate_info.total_arguments = inum_arguments; + iterate_info.object = &iobject; + iterate_info.arguments = &iarguments; + iterate_info.num_arguments = &inum_arguments; + + format = loop_format; + + /* set new format string */ + iterate_info.args.base = iterate_info.args.format = format; + iterate_info.format = &format; + + /* information for possible ~^ */ + iterate_info.iteration = + num_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST; + + /* do the format */ + LispFormat(stream, &iterate_info); + + /* check for forced loop break */ + if (iterate_info.upandout & UPANDOUT_HASH) + break; + } + } + /* ~:{...~} */ + else if (info->args.collon) { + /* next argument is a list of lists */ + + LispObj *sarguments, *sobject; + int snum_arguments; + + /* fetch argument list, must exist */ + if (!CONSP(arguments)) + parse_error(&(info->args), PARSE_NOARGSLEFT); + sarguments = object = CAR(arguments); + object = CAR(arguments); + arguments = CDR(arguments); + --num_arguments; + + snum_arguments = 0; + if (CONSP(object)) { + /* count arguments to format */ + for (sobject = object; CONSP(sobject); sobject = CDR(sobject)) + ++snum_arguments; + } + else + generic_error(&(info->args), GENERIC_BADLIST); + + /* iterate */ + for (;; iterate++) { + /* if maximum iterations done or all arguments consumed */ + if (has_max && iterate > iterate_max) + break; + else if (snum_arguments == 0 && (!has_min || iterate > 0)) + break; + + /* fetch argument list, must exist */ + if (!CONSP(sarguments)) + parse_error(&(info->args), PARSE_NOARGSLEFT); + iarguments = sobject = CAR(sarguments); + sobject = CAR(sarguments); + sarguments = CDR(sarguments); + --snum_arguments; + + inum_arguments = 0; + if (CONSP(object)) { + /* count arguments to format */ + for (iobject = sobject; CONSP(iobject); iobject = CDR(iobject)) + ++inum_arguments; + } + else if (sobject != NIL) + generic_error(&(info->args), GENERIC_BADLIST); + + iobject = NIL; + + /* set new arguments to recursive calls */ + iarguments = sobject; + iterate_info.base_arguments = iarguments; + iterate_info.total_arguments = inum_arguments; + iterate_info.object = &iobject; + iterate_info.arguments = &iarguments; + iterate_info.num_arguments = &inum_arguments; + + format = loop_format; + + /* set new format string */ + iterate_info.args.base = iterate_info.args.format = format; + iterate_info.format = &format; + + /* information for possible ~^ */ + iterate_info.iteration = + snum_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST; + + /* do the format */ + LispFormat(stream, &iterate_info); + + /* check for forced loop break */ + if (iterate_info.upandout & UPANDOUT_HASH) + break; + } + } + /* ~@{...~} */ + else if (info->args.atsign) { + /* current argument list is used */ + + /* set new arguments to recursive calls */ + iterate_info.base_arguments = info->base_arguments; + iterate_info.total_arguments = info->total_arguments; + iterate_info.object = &object; + iterate_info.arguments = &arguments; + iterate_info.num_arguments = &num_arguments; + + for (;; iterate++) { + /* if maximum iterations done or all arguments consumed */ + if (has_max && iterate > iterate_max) + break; + else if (num_arguments == 0 && (!has_min || iterate > 0)) + break; + + format = loop_format; + + /* set new format string */ + iterate_info.args.base = iterate_info.args.format = format; + iterate_info.format = &format; + + /* information for possible ~^, in this case ~:^ is a noop */ + iterate_info.iteration = ITERATION_NORMAL; + + /* do the format */ + LispFormat(stream, &iterate_info); + + /* check for forced loop break */ + if (iterate_info.upandout & UPANDOUT_HASH) + break; + } + } + + /* free temporary memory */ + free_formats(formats, num_formats); + + /* update anything that may have changed */ + *(info->object) = object; + *(info->arguments) = arguments; + *(info->num_arguments) = num_arguments; + + /* this information always updated */ + *(info->format) = next_format; +} + +static void +format_justify(LispObj *stream, FmtInfo *info) +{ + GC_ENTER(); + FmtInfo justify_info; + char **formats, *format, *next_format, *str; + LispObj *string, *strings = NIL, *cons; + int atsign = info->args.atsign, + collon = info->args.collon, + mincol = info->args.arguments[0].value, + colinc = info->args.arguments[1].value, + minpad = info->args.arguments[2].value, + padchar = info->args.arguments[3].value; + int i, k, total_length, length, padding, num_formats, has_default, + comma_width, line_width, size, extra; + + next_format = *(info->format); + + /* list formats */ + list_formats(info, '<', &next_format, &formats, &num_formats, + &has_default, &comma_width, &line_width); + + /* initialize list of strings streams */ + if (num_formats) { + string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); + strings = cons = CONS(string, NIL); + GC_PROTECT(strings); + for (i = 1; i < num_formats; i++) { + string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); + RPLACD(cons, CONS(string, NIL)); + cons = CDR(cons); + } + } + + /* most information is the same */ + memcpy(&justify_info, info, sizeof(FmtInfo)); + + /* loop formating strings */ + for (i = 0, cons = strings; i < num_formats; i++, cons = CDR(cons)) { + /* set new format string */ + format = formats[i]; + justify_info.args.base = justify_info.args.format = format; + justify_info.format = &format; + + /* format string, maybe consuming arguments */ + LispFormat(CAR(cons), &justify_info); + + /* if format was aborted, it is discarded */ + if (justify_info.upandout) + RPLACA(cons, NIL); + /* check if the entire "main" iteration must be aborted */ + if (justify_info.upandout & UPANDOUT_COLLON) { + for (cons = CDR(cons); i < num_formats; i++, cons = CDR(cons)) + RPLACA(cons, NIL); + break; + } + } + + /* free temporary format strings */ + free_formats(formats, num_formats); + + /* remove aborted formats */ + /* first remove leading discarded formats */ + if (CAR(strings) == NIL) { + while (CAR(strings) == NIL) { + strings = CDR(strings); + --num_formats; + } + /* keep strings gc protected, discarding first entries */ + lisp__data.protect.objects[gc__protect] = strings; + } + /* now remove intermediary discarded formats */ + cons = strings; + while (CONSP(cons)) { + if (CONSP(CDR(cons)) && CAR(CDR(cons)) == NIL) { + RPLACD(cons, CDR(CDR(cons))); + --num_formats; + } + else + cons = CDR(cons); + } + + /* calculate total length required for output */ + if (has_default) + cons = CDR(strings); /* if has_defaults, strings is surely a list */ + else + cons = strings; + for (total_length = 0; CONSP(cons); cons = CDR(cons)) + total_length += SSTREAMP(CAR(cons))->length; + + /* initialize pointer to string streams */ + if (has_default) + cons = CDR(strings); + else + cons = strings; + + /* check if padding will need to be printed */ + extra = 0; + padding = mincol - total_length; + if (padding < 0) + k = padding = 0; + else { + int num_fields = num_formats - (has_default != 0); + + if (num_fields > 1) { + /* check if padding is distributed in num_fields or + * num_fields - 1 steps */ + if (!collon) + --num_fields; + } + + if (num_fields) + k = padding / num_fields; + else + k = padding; + + if (k <= 0) + k = colinc; + else if (colinc) + k = k + (k % colinc); + extra = mincol - (num_fields * k + total_length); + if (extra < 0) + extra = 0; + } + if (padding && k < minpad) { + k = minpad; + if (colinc) + k = k + (k % colinc); + } + + /* first check for the special case of only one string being justified */ + if (num_formats - has_default == 1) { + if (has_default && line_width > 0 && comma_width >= 0 && + total_length + comma_width > line_width) { + str = LispGetSstring(SSTREAMP(CAR(strings)), &size); + LispWriteStr(stream, str, size); + } + string = has_default ? CAR(CDR(strings)) : CAR(strings); + /* check if need left padding */ + if (k && !atsign) { + LispWriteChars(stream, padchar, k); + k = 0; + } + /* check for centralizing text */ + else if (k && atsign && collon) { + LispWriteChars(stream, padchar, k / 2 + ((k / 2) & 1)); + k -= k / 2; + } + str = LispGetSstring(SSTREAMP(string), &size); + LispWriteStr(stream, str, size); + /* if any padding remaining */ + if (k) + LispWriteChars(stream, padchar, k); + } + else { + LispObj *result; + int last, spaces_before, padout; + + /* if has default, need to check output length */ + if (has_default && line_width > 0 && comma_width >= 0) { + result = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); + GC_PROTECT(result); + } + /* else write directly to stream */ + else + result = stream; + + /* loop printing justified text */ + /* padout controls padding for cases where padding is + * is separated in n-1 chunks, where n is the number of + * formatted strings. + */ + for (i = padout = 0; CONSP(cons); i++, cons = CDR(cons), --extra) { + string = CAR(cons); + last = !CONSP(CDR(cons)); + + spaces_before = (i != 0 || collon) && (!last || !atsign); + + if (!spaces_before) { + /* check for special case */ + if (last && atsign && collon && padding > 0) { + int spaces; + + spaces = minpad > colinc ? minpad : colinc; + LispWriteChars(result, padchar, spaces + (extra > 0)); + k -= spaces; + } + str = LispGetSstring(SSTREAMP(string), &size); + LispWriteStr(result, str, size); + padout = 0; + } + if (!padout) + LispWriteChars(result, padchar, k + (extra > 0)); + padout = k; + /* if not first string, or if left padding specified */ + if (spaces_before) { + str = LispGetSstring(SSTREAMP(string), &size); + LispWriteStr(result, str, size); + padout = 0; + } + padding -= k; + } + + if (has_default && line_width > 0 && comma_width >= 0) { + length = SSTREAMP(result)->length + LispGetColumn(stream); + + /* if current line is too large */ + if (has_default && length + comma_width > line_width) { + str = LispGetSstring(SSTREAMP(CAR(strings)), &size); + LispWriteStr(stream, str, size); + } + + /* write result to stream */ + str = LispGetSstring(SSTREAMP(result), &size); + LispWriteStr(stream, str, size); + } + } + + /* unprotect string streams from GC */ + GC_LEAVE(); + + /* this information always updated */ + *(info->format) = next_format; +} + +static void +LispFormat(LispObj *stream, FmtInfo *info) +{ + FmtArgs *args; + FmtDefs *defs = NULL; + LispObj *object, *arguments; + char stk[256], *format, *next_format; + int length, num_arguments, code, need_update, need_argument, hash, head; + + /* arguments that will be updated on function exit */ + format = *(info->format); + object = *(info->object); + arguments = *(info->arguments); + num_arguments = *(info->num_arguments); + + /* initialize */ + length = 0; + args = &(info->args); + info->upandout = 0; + + while (*format) { + if (*format == '~') { + /* flush non formatted characters */ + if (length) { + LispWriteStr(stream, stk, length); + length = 0; + } + + need_argument = need_update = hash = 0; + + /* parse parameters */ + args->format = format + 1; + next_format = parse_arguments(format + 1, args, &num_arguments, + &arguments, &code); + if (code != NOERROR) + parse_error(args, code); + + /* check parameters */ + switch (args->command) { + case 'A': case 'S': + defs = &AsciiDefs; + break; + case 'B': case 'O': case 'D': case 'X': + defs = &IntegerDefs; + break; + case 'R': + defs = &RadixDefs; + break; + case 'P': case 'C': + defs = &NoneDefs; + break; + case 'F': + defs = &FixedFloatDefs; + break; + case 'E': case 'G': + defs = &ExponentialFloatDefs; + break; + case '$': + defs = &DollarFloatDefs; + break; + case '%': case '&': case '|': case '~': case '\n': + defs = &OneDefs; + break; + case 'T': + defs = &TabulateDefs; + break; + case '*': + defs = &OneDefs; + break; + case '?': case '(': + defs = &NoneDefs; + break; + case ')': + /* this is never seen, processed in format_case_conversion */ + format_error(args, "no match for directive ~)"); + case '[': + defs = &OneDefs; + break; + case ']': + /* this is never seen, processed in format_conditional */ + format_error(args, "no match for directive ~]"); + case '{': + defs = &OneDefs; + break; + case '}': + /* this is never seen, processed in format_iterate */ + format_error(args, "no match for directive ~}"); + case '<': + defs = &AsciiDefs; + break; + case '>': + /* this is never seen, processed in format_justify */ + format_error(args, "no match for directive ~>"); + case ';': + /* this is never seen here */ + format_error(args, "misplaced directive ~;"); + case '#': + /* special handling for ~#^ */ + if (*next_format == '^') { + ++next_format; + hash = 1; + defs = &NoneDefs; + args->command = '^'; + break; + } + parse_error(args, PARSE_BADDIRECTIVE); + case '^': + defs = &NoneDefs; + break; + default: + parse_error(args, PARSE_BADDIRECTIVE); + break; + } + merge_arguments(args, defs, &code); + if (code != NOERROR) + merge_error(args, code); + + /* check if an argument is required by directive */ + switch (args->command) { + case 'A': case 'S': + case 'B': case 'O': case 'D': case 'X': case 'R': + need_argument = 1; + break; + case 'P': + /* if collon specified, plural is the last print argument */ + need_argument = !args->collon; + break; + case 'C': + need_argument = 1; + break; + case 'F': case 'E': case 'G': case '$': + need_argument = 1; + break; + case '%': case '&': case '|': case '~': case '\n': + break; + case 'T': + break; + case '*': /* check arguments below */ + need_update = 1; + break; + case '?': + need_argument = need_update = 1; + break; + case '(': case '[': case '{': case '<': + need_update = 1; + break; + case '^': + break; + } + if (need_argument) { + if (!CONSP(arguments)) + parse_error(args, PARSE_NOARGSLEFT); + object = CAR(arguments); + arguments = CDR(arguments); + --num_arguments; + } + + /* will do recursive calls that change info */ + if (need_update) { + *(info->format) = next_format; + *(info->object) = object; + *(info->arguments) = arguments; + *(info->num_arguments) = num_arguments; + } + + /* everything seens fine, print the format directive */ + switch (args->command) { + case 'A': + head = lisp__data.env.length; + LispAddVar(Oprint_escape, NIL); + ++lisp__data.env.head; + format_ascii(stream, object, args); + lisp__data.env.head = lisp__data.env.length = head; + break; + case 'S': + head = lisp__data.env.length; + LispAddVar(Oprint_escape, T); + ++lisp__data.env.head; + format_ascii(stream, object, args); + lisp__data.env.head = lisp__data.env.length = head; + break; + case 'B': + format_in_radix(stream, object, 2, args); + break; + case 'O': + format_in_radix(stream, object, 8, args); + break; + case 'D': + format_in_radix(stream, object, 10, args); + break; + case 'X': + format_in_radix(stream, object, 16, args); + break; + case 'R': + /* if a single argument specified */ + if (args->count) + format_in_radix(stream, object, 0, args); + else + format_radix_special(stream, object, args); + break; + case 'P': + if (args->atsign) { + if (FIXNUMP(object) && FIXNUM_VALUE(object) == 1) + LispWriteChar(stream, 'y'); + else + LispWriteStr(stream, "ies", 3); + } + else if (!FIXNUMP(object) || FIXNUM_VALUE(object) != 1) + LispWriteChar(stream, 's'); + break; + case 'C': + format_character(stream, object, args); + break; + case 'F': + format_fixed_float(stream, object, args); + break; + case 'E': + format_exponential_float(stream, object, args); + break; + case 'G': + format_general_float(stream, object, args); + break; + case '$': + format_dollar_float(stream, object, args); + break; + case '&': + if (LispGetColumn(stream) == 0) + --args->arguments[0].value; + case '%': + LispWriteChars(stream, '\n', args->arguments[0].value); + break; + case '|': + LispWriteChars(stream, '\f', args->arguments[0].value); + break; + case '~': + LispWriteChars(stream, '~', args->arguments[0].value); + break; + case '\n': + if (!args->collon) { + if (args->atsign) + LispWriteChar(stream, '\n'); + /* ignore newline and following spaces */ + while (*next_format && isspace(*next_format)) + ++next_format; + } + break; + case 'T': + format_tabulate(stream, args); + break; + case '*': + format_goto(info); + break; + case '?': + format_indirection(stream, object, info); + need_update = 1; + break; + case '(': + format_case_conversion(stream, info); + /* next_format if far from what is set now */ + next_format = *(info->format); + break; + case '[': + format_conditional(stream, info); + /* next_format if far from what is set now */ + next_format = *(info->format); + break; + case '{': + format_iterate(stream, info); + /* next_format if far from what is set now */ + next_format = *(info->format); + break; + case '<': + format_justify(stream, info); + /* next_format if far from what is set now */ + next_format = *(info->format); + break; + case '^': + if (args->collon) { + if (hash && num_arguments == 0) { + info->upandout = UPANDOUT_HASH; + goto format_up_and_out; + } + if (info->iteration && + info->iteration == ITERATION_NORMAL) + /* not exactly an error, but in this case, + * command is ignored */ + break; + info->upandout = UPANDOUT_COLLON; + goto format_up_and_out; + } + else if (num_arguments == 0) { + info->upandout = UPANDOUT_NORMAL; + goto format_up_and_out; + } + break; + } + + if (need_update) { + object = *(info->object); + arguments = *(info->arguments); + num_arguments = *(info->num_arguments); + } + + format = next_format; + } + else { + if (length >= sizeof(stk)) { + LispWriteStr(stream, stk, length); + length = 0; + } + stk[length++] = *format++; + } + } + + /* flush any peding output */ + if (length) + LispWriteStr(stream, stk, length); + +format_up_and_out: + /* update for recursive call */ + *(info->format) = format; + *(info->object) = object; + *(info->arguments) = arguments; + *(info->num_arguments) = num_arguments; +} + +LispObj * +Lisp_Format(LispBuiltin *builtin) +/* + format destination control-string &rest arguments + */ +{ + GC_ENTER(); + FmtInfo info; + LispObj *object; + char *control_string; + int num_arguments; + + LispObj *stream, *format, *arguments; + + arguments = ARGUMENT(2); + format = ARGUMENT(1); + stream = ARGUMENT(0); + + /* check format and stream */ + CHECK_STRING(format); + if (stream == NIL) { /* return a string */ + stream = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); + GC_PROTECT(stream); + } + else if (stream == T || /* print directly to *standard-output* */ + stream == STANDARD_OUTPUT) + stream = NIL; + else { + CHECK_STREAM(stream); + if (!stream->data.stream.writable) + LispDestroy("%s: stream %s is not writable", + STRFUN(builtin), STROBJ(stream)); + } + + /* count number of arguments */ + for (object = arguments, num_arguments = 0; CONSP(object); + object = CDR(object), num_arguments++) + ; + + /* initialize plural/argument info */ + object = NIL; + + /* the format string */ + control_string = THESTR(format); + + /* arguments to recursive calls */ + info.args.base = control_string; + info.base_arguments = arguments; + info.total_arguments = num_arguments; + info.format = &control_string; + info.object = &object; + info.arguments = &arguments; + info.num_arguments = &num_arguments; + info.iteration = 0; + + /* format arguments */ + LispFormat(stream, &info); + + /* if printing to stdout */ + if (stream == NIL) + LispFflush(Stdout); + /* else if printing to string-stream, return a string */ + else if (stream->data.stream.type == LispStreamString) { + int length; + char *string; + + string = LispGetSstring(SSTREAMP(stream), &length); + stream = LSTRING(string, length); + } + + GC_LEAVE(); + + return (stream); +} diff --git a/lisp/format.h b/lisp/format.h new file mode 100644 index 0000000..7ca14b9 --- /dev/null +++ b/lisp/format.h @@ -0,0 +1,42 @@ +/* + * 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/format.h,v 1.3 2002/11/08 08:00:56 paulo Exp $ */ + +#ifndef Lisp_format_h +#define Lisp_format_h + +#include "private.h" + +/* + * Prototypes + */ +LispObj *Lisp_Format(LispBuiltin*); + +#endif /* Lisp_format_h */ diff --git a/lisp/hash.c b/lisp/hash.c new file mode 100644 index 0000000..3d32f07 --- /dev/null +++ b/lisp/hash.c @@ -0,0 +1,657 @@ +/* + * Copyright (c) 2002 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/hash.c,v 1.4 2002/11/23 08:26:48 paulo Exp $ */ + +#include "hash.h" + +/* A simple hash-table implementation + * TODO: implement SXHASH and WITH-HASH-TABLE-ITERATOR + * May need a rewrite for better performance, and will + * need a rewrite if images/bytecode saved on disk. + */ + +#define GET_HASH 1 +#define PUT_HASH 2 +#define REM_HASH 3 + +/* + * Prototypes + */ +static unsigned long LispHashKey(LispObj*, int); +static LispObj *LispHash(LispBuiltin*, int); +static void LispRehash(LispHashTable*); +static void LispFreeHashEntries(LispHashEntry*, long); + +/* + * Initialization + */ +extern LispObj *Oeq, *Oeql, *Oequal, *Oequalp; + +/* Hash tables will have one of these sizes, unless the user + * specified a very large size */ +static long some_primes[] = { + 5, 11, 17, 23, + 31, 47, 71, 97, + 139, 199, 307, 401, + 607, 809, 1213, 1619, + 2437, 3251, 4889, 6521 +}; + +/* + * Implementation + */ +static unsigned long +LispHashKey(LispObj *object, int function) +{ + mpi *bigi; + char *string; + long i, length; + unsigned long key = ((unsigned long)object) >> 4; + + /* Must be the same object for EQ */ + if (function == FEQ) + goto hash_key_done; + + if (function == FEQUALP) { + switch (OBJECT_TYPE(object)) { + case LispSChar_t: + key = (unsigned long)toupper(SCHAR_VALUE(object)); + goto hash_key_done; + case LispString_t: + string = THESTR(object); + length = STRLEN(object); + if (length > 32) + length = 32; + for (i = 0, key = 0; i < length; i++) + key = (key << 1) ^ toupper(string[i]); + goto hash_key_done; + default: + break; + } + } + + /* Function is EQL, EQUAL or EQUALP */ + switch (OBJECT_TYPE(object)) { + case LispFixnum_t: + case LispSChar_t: + key = (unsigned long)FIXNUM_VALUE(object); + goto hash_key_done; + case LispInteger_t: + key = (unsigned long)INT_VALUE(object); + goto hash_key_done; + case LispRatio_t: + key = (object->data.ratio.numerator << 16) ^ + object->data.ratio.denominator; + goto hash_key_done; + case LispDFloat_t: + key = (unsigned long)DFLOAT_VALUE(object); + break; + case LispComplex_t: + key = (LispHashKey(object->data.complex.imag, function) << 16) ^ + LispHashKey(object->data.complex.real, function); + goto hash_key_done; + case LispBignum_t: + bigi = object->data.mp.integer; + length = bigi->size; + if (length > 8) + length = 8; + key = bigi->sign; + for (i = 0; i < length; i++) + key = (key << 8) ^ bigi->digs[i]; + goto hash_key_done; + case LispBigratio_t: + bigi = mpr_num(object->data.mp.ratio); + length = bigi->size; + if (length > 4) + length = 4; + key = bigi->sign; + for (i = 0; i < length; i++) + key = (key << 4) ^ bigi->digs[i]; + bigi = mpr_den(object->data.mp.ratio); + length = bigi->size; + if (length > 4) + length = 4; + for (i = 0; i < length; i++) + key = (key << 4) ^ bigi->digs[i]; + goto hash_key_done; + default: + break; + } + + /* Anything else must be the same object for EQL */ + if (function == FEQL) + goto hash_key_done; + + switch (OBJECT_TYPE(object)) { + case LispString_t: + string = THESTR(object); + length = STRLEN(object); + if (length > 32) + length = 32; + for (i = 0, key = 0; i < length; i++) + key = (key << 1) ^ string[i]; + break; + case LispCons_t: + key = (LispHashKey(CAR(object), function) << 16) ^ + LispHashKey(CDR(object), function); + break; + case LispQuote_t: + case LispBackquote_t: + case LispPathname_t: + key = LispHashKey(object->data.pathname, function); + break; + case LispRegex_t: + key = LispHashKey(object->data.regex.pattern, function); + break; + default: + break; + } + +hash_key_done: + return (key); +} + +static LispObj * +LispHash(LispBuiltin *builtin, int code) +{ + LispHashEntry *entry; + LispHashTable *hash; + unsigned long key; + LispObj *result; + int found; + long i; + + LispObj *okey, *hash_table, *value; + + if (code == REM_HASH) + value = NIL; + else { + value = ARGUMENT(2); + if (value == UNSPEC) + value = NIL; + } + hash_table = ARGUMENT(1); + okey = ARGUMENT(0); + + CHECK_HASHTABLE(hash_table); + + /* get hash entry */ + hash = hash_table->data.hash.table; + key = LispHashKey(okey, hash->function) % hash->num_entries; + entry = hash->entries + key; + + /* search entry in the hash table */ + if (entry->count == 0) + i = 0; + else { + if (hash->function == FEQ) { + for (i = entry->cache; i >= 0; i--) { + if (entry->keys[i] == okey) + goto found_key; + } + for (i = entry->cache + 1; i < entry->count; i++) { + if (entry->keys[i] == okey) + break; + } + } + else { + for (i = entry->cache; i >= 0; i--) { + if (LispObjectCompare(entry->keys[i], okey, + hash->function) == T) + goto found_key; + } + for (i = entry->cache + 1; i < entry->count; i++) { + if (LispObjectCompare(entry->keys[i], okey, + hash->function) == T) + break; + } + } + } + +found_key: + result = value; + if ((found = i < entry->count) == 0) + i = entry->count; + + switch (code) { + case GET_HASH: + RETURN_COUNT = 1; + if (found) { + RETURN(0) = T; + entry->cache = i; + result = entry->values[i]; + } + else + RETURN(0) = NIL; + break; + case PUT_HASH: + entry->cache = i; + if (found) + /* Just replace current entry */ + entry->values[i] = value; + else { + if ((i % 4) == 0) { + LispObj **keys, **values; + + keys = realloc(entry->keys, sizeof(LispObj*) * (i + 4)); + if (keys == NULL) + LispDestroy("out of memory"); + values = realloc(entry->values, sizeof(LispObj*) * (i + 4)); + if (values == NULL) { + free(keys); + LispDestroy("out of memory"); + } + entry->keys = keys; + entry->values = values; + } + entry->keys[i] = okey; + entry->values[i] = value; + ++entry->count; + ++hash->count; + if (hash->count > hash->rehash_threshold * hash->num_entries) + LispRehash(hash); + } + break; + case REM_HASH: + if (found) { + result = T; + --entry->count; + --hash->count; + if (i < entry->count) { + memmove(entry->keys + i, entry->keys + i + 1, + (entry->count - i) * sizeof(LispObj*)); + memmove(entry->values + i, entry->values + i + 1, + (entry->count - i) * sizeof(LispObj*)); + } + if (entry->cache && entry->cache == entry->count) + --entry->cache; + } + break; + } + + return (result); +} + +static void +LispRehash(LispHashTable *hash) +{ + unsigned long key; + LispHashEntry *entries, *nentry, *entry, *last; + long i, size = hash->num_entries * hash->rehash_size; + + for (i = 0; i < sizeof(some_primes) / sizeof(some_primes[0]); i++) + if (some_primes[i] >= size) { + size = some_primes[i]; + break; + } + + entries = calloc(1, sizeof(LispHashEntry) * size); + if (entries == NULL) + goto out_of_memory; + + for (entry = hash->entries, last = entry + hash->num_entries; + entry < last; entry++) { + for (i = 0; i < entry->count; i++) { + key = LispHashKey(entry->keys[i], hash->function) % size; + nentry = entries + key; + if ((nentry->count % 4) == 0) { + LispObj **keys, **values; + + keys = realloc(nentry->keys, sizeof(LispObj*) * (i + 4)); + if (keys == NULL) + goto out_of_memory; + values = realloc(nentry->values, sizeof(LispObj*) * (i + 4)); + if (values == NULL) { + free(keys); + goto out_of_memory; + } + nentry->keys = keys; + nentry->values = values; + } + nentry->keys[nentry->count] = entry->keys[i]; + nentry->values[nentry->count] = entry->values[i]; + ++nentry->count; + + } + } + LispFreeHashEntries(hash->entries, hash->num_entries); + hash->entries = entries; + hash->num_entries = size; + return; + +out_of_memory: + if (entries) + LispFreeHashEntries(entries, size); + LispDestroy("out of memory"); +} + +static void +LispFreeHashEntries(LispHashEntry *entries, long num_entries) +{ + LispHashEntry *entry, *last; + + for (entry = entries, last = entry + num_entries; entry < last; entry++) { + free(entry->keys); + free(entry->values); + } + free(entries); +} + +void +LispFreeHashTable(LispHashTable *hash) +{ + LispFreeHashEntries(hash->entries, hash->num_entries); + free(hash); +} + +LispObj * +Lisp_Clrhash(LispBuiltin *builtin) +/* + clrhash hash-table + */ +{ + LispHashTable *hash; + LispHashEntry *entry, *last; + + LispObj *hash_table = ARGUMENT(0); + + CHECK_HASHTABLE(hash_table); + + hash = hash_table->data.hash.table; + for (entry = hash->entries, last = entry + hash->num_entries; + entry < last; entry++) { + free(entry->keys); + free(entry->values); + entry->keys = entry->values = NULL; + entry->count = entry->cache = 0; + } + hash->count = 0; + + return (hash_table); +} + +LispObj * +Lisp_Gethash(LispBuiltin *builtin) +/* + gethash key hash-table &optional default + */ +{ + return (LispHash(builtin, GET_HASH)); +} + +LispObj * +Lisp_HashTableP(LispBuiltin *builtin) +/* + hash-table-p object + */ +{ + LispObj *object = ARGUMENT(0); + + return (HASHTABLEP(object) ? T : NIL); +} + +LispObj * +Lisp_HashTableCount(LispBuiltin *builtin) +/* + hash-table-count hash-table + */ +{ + LispObj *hash_table = ARGUMENT(0); + + CHECK_HASHTABLE(hash_table); + + return (FIXNUM(hash_table->data.hash.table->count)); +} + +LispObj * +Lisp_HashTableRehashSize(LispBuiltin *builtin) +/* + hash-table-rehash-size hash-table + */ +{ + LispObj *hash_table = ARGUMENT(0); + + CHECK_HASHTABLE(hash_table); + + return (DFLOAT(hash_table->data.hash.table->rehash_size)); +} + +LispObj * +Lisp_HashTableRehashThreshold(LispBuiltin *builtin) +/* + hash-table-rehash-threshold hash-table + */ +{ + LispObj *hash_table = ARGUMENT(0); + + CHECK_HASHTABLE(hash_table); + + return (DFLOAT(hash_table->data.hash.table->rehash_threshold)); +} + +LispObj * +Lisp_HashTableSize(LispBuiltin *builtin) +/* + hash-table-size hash-table + */ +{ + LispObj *hash_table = ARGUMENT(0); + + CHECK_HASHTABLE(hash_table); + + return (FIXNUM(hash_table->data.hash.table->num_entries)); +} + +LispObj * +Lisp_HashTableTest(LispBuiltin *builtin) +/* + hash-table-test hash-table + */ +{ + LispObj *hash_table = ARGUMENT(0); + + CHECK_HASHTABLE(hash_table); + + return (hash_table->data.hash.test); +} + +LispObj * +Lisp_Maphash(LispBuiltin *builtin) +/* + maphash function hash-table + */ +{ + long i; + LispHashEntry *entry, *last; + + LispObj *function, *hash_table; + + hash_table = ARGUMENT(1); + function = ARGUMENT(0); + + CHECK_HASHTABLE(hash_table); + + for (entry = hash_table->data.hash.table->entries, + last = entry + hash_table->data.hash.table->num_entries; + entry < last; entry++) { + for (i = 0; i < entry->count; i++) + APPLY2(function, entry->keys[i], entry->values[i]); + } + + return (NIL); +} + +LispObj * +Lisp_MakeHashTable(LispBuiltin *builtin) +/* + make-hash-table &key test size rehash-size rehash-threshold initial-contents + */ +{ + int function = FEQL; + unsigned long i, isize, xsize; + double drsize, drthreshold; + LispHashTable *hash_table; + LispObj *cons, *result; + + LispObj *test, *size, *rehash_size, *rehash_threshold, *initial_contents; + + initial_contents = ARGUMENT(4); + rehash_threshold = ARGUMENT(3); + rehash_size = ARGUMENT(2); + size = ARGUMENT(1); + test = ARGUMENT(0); + + if (test != UNSPEC) { + if (test == Oeq) + function = FEQ; + else if (test == Oeql) + function = FEQL; + else if (test == Oequal) + function = FEQUAL; + else if (test == Oequalp) + function = FEQUALP; + else + LispDestroy("%s: :TEST must be EQ, EQL, EQUAL, " + "or EQUALP, not %s", STRFUN(builtin), STROBJ(test)); + } + else + test = Oeql; + + if (size != UNSPEC) { + CHECK_INDEX(size); + isize = FIXNUM_VALUE(size); + } + else + isize = 1; + + if (rehash_size != UNSPEC) { + CHECK_DFLOAT(rehash_size); + if (DFLOAT_VALUE(rehash_size) <= 1.0) + LispDestroy("%s: :REHASH-SIZE must a float > 1, not %s", + STRFUN(builtin), STROBJ(rehash_size)); + drsize = DFLOAT_VALUE(rehash_size); + } + else + drsize = 1.5; + + if (rehash_threshold != UNSPEC) { + CHECK_DFLOAT(rehash_threshold); + if (DFLOAT_VALUE(rehash_threshold) < 0.0 || + DFLOAT_VALUE(rehash_threshold) > 1.0) + LispDestroy("%s: :REHASH-THRESHOLD must a float " + "in the range 0.0 - 1.0, not %s", + STRFUN(builtin), STROBJ(rehash_threshold)); + drthreshold = DFLOAT_VALUE(rehash_threshold); + } + else + drthreshold = 0.75; + + if (initial_contents == UNSPEC) + initial_contents = NIL; + CHECK_LIST(initial_contents); + for (xsize = 0, cons = initial_contents; + CONSP(cons); + xsize++, cons = CDR(cons)) + CHECK_CONS(CAR(cons)); + + if (xsize > isize) + isize = xsize; + + for (i = 0; i < sizeof(some_primes) / sizeof(some_primes[0]); i++) + if (some_primes[i] >= isize) { + isize = some_primes[i]; + break; + } + + hash_table = LispMalloc(sizeof(LispHashTable)); + hash_table->entries = LispCalloc(1, sizeof(LispHashEntry) * isize); + hash_table->num_entries = isize; + hash_table->count = 0; + hash_table->function = function; + hash_table->rehash_size = drsize; + hash_table->rehash_threshold = drthreshold; + + result = LispNew(NIL, NIL); + result->type = LispHashTable_t; + result->data.hash.table = hash_table; + result->data.hash.test = test; + + LispMused(hash_table); + LispMused(hash_table->entries); + + if (initial_contents != UNSPEC) { + unsigned long key; + LispHashEntry *entry; + + for (cons = initial_contents; CONSP(cons); cons = CDR(cons)) { + key = LispHashKey(CAAR(cons), function) % isize; + entry = hash_table->entries + key; + + if ((entry->count % 4) == 0) { + LispObj **keys, **values; + + keys = realloc(entry->keys, sizeof(LispObj*) * (i + 4)); + if (keys == NULL) + LispDestroy("out of memory"); + values = realloc(entry->values, sizeof(LispObj*) * (i + 4)); + if (values == NULL) { + free(keys); + LispDestroy("out of memory"); + } + entry->keys = keys; + entry->values = values; + } + entry->keys[entry->count] = CAAR(cons); + entry->values[entry->count] = CDAR(cons); + ++entry->count; + } + hash_table->count = xsize; + } + + return (result); +} + +LispObj * +Lisp_Remhash(LispBuiltin *builtin) +/* + remhash key hash-table + */ +{ + return (LispHash(builtin, REM_HASH)); +} + +LispObj * +Lisp_XeditPuthash(LispBuiltin *builtin) +/* + lisp::puthash key hash-table value + */ +{ + return (LispHash(builtin, PUT_HASH)); +} diff --git a/lisp/hash.h b/lisp/hash.h new file mode 100644 index 0000000..df74c96 --- /dev/null +++ b/lisp/hash.h @@ -0,0 +1,71 @@ +/* + * Copyright (c) 2002 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/hash.h,v 1.2 2002/11/08 08:00:56 paulo Exp $ */ + +#ifndef Lisp_hash_h +#define Lisp_hash_h + +#include "private.h" + +typedef struct _LispHashEntry { + LispObj **keys; + LispObj **values; + long cache; + long count; +} LispHashEntry; + +struct _LispHashTable { + LispHashEntry *entries; + long num_entries; + long count; + int function; /* Function is EQ, EQL, EQUAL, or EQUALP */ + double rehash_size; + double rehash_threshold; +}; + +/* + * Prototypes + */ +void LispFreeHashTable(LispHashTable*); + +LispObj *Lisp_Clrhash(LispBuiltin*); +LispObj *Lisp_Gethash(LispBuiltin*); +LispObj *Lisp_HashTableCount(LispBuiltin*); +LispObj *Lisp_HashTableP(LispBuiltin*); +LispObj *Lisp_HashTableRehashSize(LispBuiltin*); +LispObj *Lisp_HashTableRehashThreshold(LispBuiltin*); +LispObj *Lisp_HashTableSize(LispBuiltin*); +LispObj *Lisp_HashTableTest(LispBuiltin*); +LispObj *Lisp_Maphash(LispBuiltin*); +LispObj *Lisp_MakeHashTable(LispBuiltin*); +LispObj *Lisp_Remhash(LispBuiltin*); +LispObj *Lisp_XeditPuthash(LispBuiltin*); + +#endif /* Lisp_hash_h */ diff --git a/lisp/helper.c b/lisp/helper.c new file mode 100644 index 0000000..65749c5 --- /dev/null +++ b/lisp/helper.c @@ -0,0 +1,1124 @@ +/* + * 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/helper.c,v 1.47 2002/11/26 04:06:28 paulo Exp $ */ + +#include "helper.h" +#include "pathname.h" +#include "package.h" +#include "read.h" +#include "stream.h" +#include "write.h" +#include "hash.h" +#include <ctype.h> +#include <fcntl.h> +#include <errno.h> +#include <math.h> +#include <sys/stat.h> + +/* + * Prototypes + */ +static LispObj *LispReallyDo(LispBuiltin*, int); +static LispObj *LispReallyDoListTimes(LispBuiltin*, int); + +/* in math.c */ +extern LispObj *LispFloatCoerce(LispBuiltin*, LispObj*); + +/* + * Implementation + */ +LispObj * +LispObjectCompare(LispObj *left, LispObj *right, int function) +{ + LispType ltype, rtype; + LispObj *result = left == right ? T : NIL; + + /* If left and right are the same object, or if function is EQ */ + if (result == T || function == FEQ) + return (result); + + ltype = OBJECT_TYPE(left); + rtype = OBJECT_TYPE(right); + + /* Equalp requires that numeric objects be compared by value, and + * strings or characters comparison be case insenstive */ + if (function == FEQUALP) { + switch (ltype) { + case LispFixnum_t: + case LispInteger_t: + case LispBignum_t: + case LispDFloat_t: + case LispRatio_t: + case LispBigratio_t: + case LispComplex_t: + switch (rtype) { + case LispFixnum_t: + case LispInteger_t: + case LispBignum_t: + case LispDFloat_t: + case LispRatio_t: + case LispBigratio_t: + case LispComplex_t: + result = APPLY2(Oequal_, left, right); + break; + default: + break; + } + goto compare_done; + case LispSChar_t: + if (rtype == LispSChar_t && + toupper(SCHAR_VALUE(left)) == toupper(SCHAR_VALUE(right))) + result = T; + goto compare_done; + case LispString_t: + if (rtype == LispString_t && STRLEN(left) == STRLEN(right)) { + long i = STRLEN(left); + char *sl = THESTR(left), *sr = THESTR(right); + + for (--i; i >= 0; i--) + if (toupper(sl[i]) != toupper(sr[i])) + break; + if (i < 0) + result = T; + } + goto compare_done; + case LispArray_t: + if (rtype == LispArray_t && + left->data.array.type == right->data.array.type && + left->data.array.rank == right->data.array.rank && + LispObjectCompare(left->data.array.dim, + right->data.array.dim, + FEQUAL) != NIL) { + LispObj *llist = left->data.array.list, + *rlist = right->data.array.list; + + for (; CONSP(llist); llist = CDR(llist), rlist = CDR(rlist)) + if (LispObjectCompare(CAR(llist), CAR(rlist), + FEQUALP) == NIL) + break; + if (!CONSP(llist)) + result = T; + } + goto compare_done; + case LispStruct_t: + if (rtype == LispStruct_t && + left->data.struc.def == right->data.struc.def) { + LispObj *lfield = left->data.struc.fields, + *rfield = right->data.struc.fields; + + for (; CONSP(lfield); + lfield = CDR(lfield), rfield = CDR(rfield)) { + if (LispObjectCompare(CAR(lfield), CAR(rfield), + FEQUALP) != T) + break; + } + if (!CONSP(lfield)) + result = T; + } + goto compare_done; + case LispHashTable_t: + if (rtype == LispHashTable_t && + left->data.hash.table->count == + right->data.hash.table->count && + left->data.hash.test == right->data.hash.test) { + unsigned long i; + LispObj *test = left->data.hash.test; + LispHashEntry *lentry = left->data.hash.table->entries, + *llast = lentry + + left->data.hash.table->num_entries, + *rentry = right->data.hash.table->entries; + + for (; lentry < llast; lentry++, rentry++) { + if (lentry->count != rentry->count) + break; + for (i = 0; i < lentry->count; i++) { + if (APPLY2(test, + lentry->keys[i], + rentry->keys[i]) == NIL || + LispObjectCompare(lentry->values[i], + rentry->values[i], + FEQUALP) == NIL) + break; + } + if (i < lentry->count) + break; + } + if (lentry == llast) + result = T; + } + goto compare_done; + default: + break; + } + } + + /* Function is EQL or EQUAL, or EQUALP on arguments with the same rules */ + if (ltype == rtype) { + switch (ltype) { + case LispFixnum_t: + case LispSChar_t: + if (FIXNUM_VALUE(left) == FIXNUM_VALUE(right)) + result = T; + break; + case LispInteger_t: + if (INT_VALUE(left) == INT_VALUE(right)) + result = T; + break; + case LispDFloat_t: + if (DFLOAT_VALUE(left) == DFLOAT_VALUE(right)) + result = T; + break; + case LispRatio_t: + if (left->data.ratio.numerator == + right->data.ratio.numerator && + left->data.ratio.denominator == + right->data.ratio.denominator) + result = T; + break; + case LispComplex_t: + if (LispObjectCompare(left->data.complex.real, + right->data.complex.real, + function) == T && + LispObjectCompare(left->data.complex.imag, + right->data.complex.imag, + function) == T) + result = T; + break; + case LispBignum_t: + if (mpi_cmp(left->data.mp.integer, right->data.mp.integer) == 0) + result = T; + break; + case LispBigratio_t: + if (mpr_cmp(left->data.mp.ratio, right->data.mp.ratio) == 0) + result = T; + break; + default: + break; + } + + /* Next types must be the same object for EQL */ + if (function == FEQL) + goto compare_done; + + switch (ltype) { + case LispString_t: + if (STRLEN(left) == STRLEN(right) && + memcmp(THESTR(left), THESTR(right), STRLEN(left)) == 0) + result = T; + break; + case LispCons_t: + if (LispObjectCompare(CAR(left), CAR(right), function) == T && + LispObjectCompare(CDR(left), CDR(right), function) == T) + result = T; + break; + case LispQuote_t: + case LispBackquote_t: + case LispPathname_t: + result = LispObjectCompare(left->data.pathname, + right->data.pathname, function); + break; + case LispLambda_t: + result = LispObjectCompare(left->data.lambda.name, + right->data.lambda.name, + function); + break; + case LispOpaque_t: + if (left->data.opaque.data == right->data.opaque.data) + result = T; + break; + case LispRegex_t: + /* If the regexs are guaranteed to generate the same matches */ + if (left->data.regex.options == right->data.regex.options) + result = LispObjectCompare(left->data.regex.pattern, + right->data.regex.pattern, + function); + break; + default: + break; + } + } + +compare_done: + return (result); +} + +void +LispCheckSequenceStartEnd(LispBuiltin *builtin, + LispObj *sequence, LispObj *start, LispObj *end, + long *pstart, long *pend, long *plength) +{ + /* Calculate length of sequence and check it's type */ + *plength = LispLength(sequence); + + /* Check start argument */ + if (start == UNSPEC || start == NIL) + *pstart = 0; + else { + CHECK_INDEX(start); + *pstart = FIXNUM_VALUE(start); + } + + /* Check end argument */ + if (end == UNSPEC || end == NIL) + *pend = *plength; + else { + CHECK_INDEX(end); + *pend = FIXNUM_VALUE(end); + } + + /* Check start argument */ + if (*pstart > *pend) + LispDestroy("%s: :START %ld is larger than :END %ld", + STRFUN(builtin), *pstart, *pend); + + /* Check end argument */ + if (*pend > *plength) + LispDestroy("%s: :END %ld is larger then sequence length %ld", + STRFUN(builtin), *pend, *plength); +} + +long +LispLength(LispObj *sequence) +{ + long length; + + if (sequence == NIL) + return (0); + switch (OBJECT_TYPE(sequence)) { + case LispString_t: + length = STRLEN(sequence); + break; + case LispArray_t: + if (sequence->data.array.rank != 1) + goto not_a_sequence; + sequence = sequence->data.array.list; + /*FALLTROUGH*/ + case LispCons_t: + for (length = 0; + CONSP(sequence); + length++, sequence = CDR(sequence)) + ; + break; + default: +not_a_sequence: + LispDestroy("LENGTH: %s is not a sequence", STROBJ(sequence)); + /*NOTREACHED*/ + length = 0; + } + + return (length); +} + +LispObj * +LispCharacterCoerce(LispBuiltin *builtin, LispObj *object) +{ + if (SCHARP(object)) + return (object); + else if (STRINGP(object) && STRLEN(object) == 1) + return (SCHAR(THESTR(object)[0])); + else if (SYMBOLP(object) && ATOMID(object)[1] == '\0') + return (SCHAR(ATOMID(object)[0])); + else if (INDEXP(object)) { + int c = FIXNUM_VALUE(object); + + if (c <= 0xff) + return (SCHAR(c)); + } + else if (object == T) + return (SCHAR('T')); + + LispDestroy("%s: cannot convert %s to character", + STRFUN(builtin), STROBJ(object)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +LispStringCoerce(LispBuiltin *builtin, LispObj *object) +{ + if (STRINGP(object)) + return (object); + else if (SYMBOLP(object)) + return (LispSymbolName(object)); + else if (SCHARP(object)) { + char string[1]; + + string[0] = SCHAR_VALUE(object); + return (LSTRING(string, 1)); + } + else if (object == NIL) + return (LSTRING(Snil, 3)); + else if (object == T) + return (LSTRING(St, 1)); + else + LispDestroy("%s: cannot convert %s to string", + STRFUN(builtin), STROBJ(object)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +LispCoerce(LispBuiltin *builtin, + LispObj *object, LispObj *result_type) +{ + LispObj *result = NIL; + LispType type = LispNil_t; + + if (result_type == NIL) + /* not even NIL can be converted to NIL? */ + LispDestroy("%s: cannot convert %s to NIL", + STRFUN(builtin), STROBJ(object)); + + else if (result_type == T) + /* no conversion */ + return (object); + + else if (!SYMBOLP(result_type)) + /* only know about simple types */ + LispDestroy("%s: bad argument %s", + STRFUN(builtin), STROBJ(result_type)); + + else { + /* check all known types */ + + Atom_id atom = ATOMID(result_type); + + if (atom == Satom) { + if (CONSP(object)) + goto coerce_fail; + return (object); + } + /* only convert ATOM to SYMBOL */ + + if (atom == Sfloat) + type = LispDFloat_t; + else if (atom == Sinteger) + type = LispInteger_t; + else if (atom == Scons || atom == Slist) { + if (object == NIL) + return (object); + type = LispCons_t; + } + else if (atom == Sstring) + type = LispString_t; + else if (atom == Scharacter) + type = LispSChar_t; + else if (atom == Scomplex) + type = LispComplex_t; + else if (atom == Svector || atom == Sarray) + type = LispArray_t; + else if (atom == Sopaque) + type = LispOpaque_t; + else if (atom == Srational) + type = LispRatio_t; + else if (atom == Spathname) + type = LispPathname_t; + else + LispDestroy("%s: invalid type specification %s", + STRFUN(builtin), ATOMID(result_type)); + } + + if (OBJECT_TYPE(object) == LispOpaque_t) { + switch (type) { + case LispAtom_t: + result = ATOM(object->data.opaque.data); + break; + case LispString_t: + result = STRING(object->data.opaque.data); + break; + case LispSChar_t: + result = SCHAR((unsigned long)object->data.opaque.data); + break; + case LispDFloat_t: + result = DFLOAT((double)((long)object->data.opaque.data)); + break; + case LispInteger_t: + result = INTEGER(((long)object->data.opaque.data)); + break; + case LispOpaque_t: + result = OPAQUE(object->data.opaque.data, 0); + break; + default: + goto coerce_fail; + break; + } + } + + else if (OBJECT_TYPE(object) != type) { + switch (type) { + case LispInteger_t: + if (INTEGERP(object)) + result = object; + else if (DFLOATP(object)) { + if ((long)DFLOAT_VALUE(object) == DFLOAT_VALUE(object)) + result = INTEGER((long)DFLOAT_VALUE(object)); + else { + mpi *integer = LispMalloc(sizeof(mpi)); + + mpi_init(integer); + mpi_setd(integer, DFLOAT_VALUE(object)); + if (mpi_getd(integer) != DFLOAT_VALUE(object)) { + mpi_clear(integer); + LispFree(integer); + goto coerce_fail; + } + result = BIGNUM(integer); + } + } + else + goto coerce_fail; + break; + case LispRatio_t: + if (DFLOATP(object)) { + mpr *ratio = LispMalloc(sizeof(mpr)); + + mpr_init(ratio); + mpr_setd(ratio, DFLOAT_VALUE(object)); + if (mpr_fiti(ratio)) { + result = RATIO(mpi_geti(mpr_num(ratio)), + mpi_geti(mpr_den(ratio))); + mpr_clear(ratio); + LispFree(ratio); + } + else + result = BIGRATIO(ratio); + } + else if (RATIONALP(object)) + result = object; + else + goto coerce_fail; + break; + case LispDFloat_t: + result = LispFloatCoerce(builtin, object); + break; + case LispComplex_t: + if (NUMBERP(object)) + result = object; + else + goto coerce_fail; + break; + case LispString_t: + if (object == NIL) + result = STRING(""); + else + result = LispStringCoerce(builtin, object); + break; + case LispSChar_t: + result = LispCharacterCoerce(builtin, object); + break; + case LispArray_t: + if (LISTP(object)) + result = VECTOR(object); + else + goto coerce_fail; + break; + case LispCons_t: + if (ARRAYP(object) && object->data.array.rank == 1) + result = object->data.array.list; + else + goto coerce_fail; + break; + case LispPathname_t: + result = APPLY1(Oparse_namestring, object); + break; + default: + goto coerce_fail; + } + } + else + result = object; + + return (result); + +coerce_fail: + LispDestroy("%s: cannot convert %s to %s", + STRFUN(builtin), STROBJ(object), ATOMID(result_type)); + /* NOTREACHED */ + return (NIL); +} + +static LispObj * +LispReallyDo(LispBuiltin *builtin, int refs) +/* + do init test &rest body + do* init test &rest body + */ +{ + GC_ENTER(); + int stack, lex, head; + LispObj *list, *symbol, *value, *values, *cons; + + LispObj *init, *test, *body; + + body = ARGUMENT(2); + test = ARGUMENT(1); + init = ARGUMENT(0); + + if (!CONSP(test)) + LispDestroy("%s: end test condition must be a list, not %s", + STRFUN(builtin), STROBJ(init)); + + CHECK_LIST(init); + + /* Save state */ + stack = lisp__data.stack.length; + lex = lisp__data.env.lex; + head = lisp__data.env.length; + + values = cons = NIL; + for (list = init; CONSP(list); list = CDR(list)) { + symbol = CAR(list); + if (!SYMBOLP(symbol)) { + CHECK_CONS(symbol); + value = CDR(symbol); + symbol = CAR(symbol); + CHECK_SYMBOL(symbol); + CHECK_CONS(value); + value = EVAL(CAR(value)); + } + else + value = NIL; + + CHECK_CONSTANT(symbol); + + LispAddVar(symbol, value); + + /* Bind variable now */ + if (refs) { + ++lisp__data.env.head; + } + else { + if (values == NIL) { + values = cons = CONS(NIL, NIL); + GC_PROTECT(values); + } + else { + RPLACD(cons, CONS(NIL, NIL)); + cons = CDR(cons); + } + } + } + if (!refs) + lisp__data.env.head = lisp__data.env.length; + + for (;;) { + if (EVAL(CAR(test)) != NIL) + break; + + /* TODO Run this code in an implicit tagbody */ + for (list = body; CONSP(list); list = CDR(list)) + (void)EVAL(CAR(list)); + + /* Error checking already done in the initialization */ + for (list = init, cons = values; CONSP(list); list = CDR(list)) { + symbol = CAR(list); + if (CONSP(symbol)) { + value = CDDR(symbol); + symbol = CAR(symbol); + if (CONSP(value)) + value = EVAL(CAR(value)); + else + value = NIL; + } + else + value = NIL; + + if (refs) + LispSetVar(symbol, value); + else { + RPLACA(cons, value); + cons = CDR(cons); + } + } + if (!refs) { + for (list = init, cons = values; + CONSP(list); + list = CDR(list), cons = CDR(cons)) { + symbol = CAR(list); + if (CONSP(symbol)) { + if (CONSP(CDR(symbol))) + LispSetVar(CAR(symbol), CAR(cons)); + } + } + } + } + + if (CONSP(CDR(test))) + value = EVAL(CADR(test)); + else + value = NIL; + + /* Restore state */ + lisp__data.stack.length = stack; + lisp__data.env.lex = lex; + lisp__data.env.head = lisp__data.env.length = head; + GC_LEAVE(); + + return (value); +} + +LispObj * +LispDo(LispBuiltin *builtin, int refs) +/* + do init test &rest body + do* init test &rest body + */ +{ + int jumped, *pjumped; + LispObj *result, **presult; + LispBlock *block; + + jumped = 1; + result = NIL; + presult = &result; + pjumped = &jumped; + block = LispBeginBlock(NIL, LispBlockTag); + if (setjmp(block->jmp) == 0) { + result = LispReallyDo(builtin, refs); + jumped = 0; + } + LispEndBlock(block); + if (jumped) + result = lisp__data.block.block_ret; + + return (result); +} + +static LispObj * +LispReallyDoListTimes(LispBuiltin *builtin, int times) +/* + dolist init &rest body + dotimes init &rest body + */ +{ + GC_ENTER(); + int head = lisp__data.env.length; + long count = 0, end = 0; + LispObj *symbol, *value = NIL, *result = NIL, *init, *body, *object; + + body = ARGUMENT(1); + init = ARGUMENT(0); + + /* Parse arguments */ + CHECK_CONS(init); + symbol = CAR(init); + CHECK_SYMBOL(symbol); + init = CDR(init); + + if (init == NIL) { + if (times) + LispDestroy("%s: NIL is not a number", STRFUN(builtin)); + } + else { + CHECK_CONS(init); + value = CAR(init); + init = CDR(init); + if (init != NIL) { + CHECK_CONS(init); + result = CAR(init); + } + + value = EVAL(value); + + if (times) { + CHECK_INDEX(value); + end = FIXNUM_VALUE(value); + } + else { + CHECK_LIST(value); + /* Protect iteration control from gc */ + GC_PROTECT(value); + } + } + + /* The variable is only bound inside the loop, so it is safe to optimize + * it out if there is no code to execute. But the result form may reference + * the bound variable. */ + if (!CONSP(body)) { + if (times) + count = end; + else + value = NIL; + } + + /* Initialize counter */ + CHECK_CONSTANT(symbol); + if (times) + LispAddVar(symbol, FIXNUM(count)); + else + LispAddVar(symbol, CONSP(value) ? CAR(value) : value); + ++lisp__data.env.head; + + if (!CONSP(body) || (times && count >= end) || (!times && !CONSP(value))) + goto loop_done; + + /* Execute iterations */ + for (;;) { + for (object = body; CONSP(object); object = CDR(object)) + (void)EVAL(CAR(object)); + + /* Update symbols and check exit condition */ + if (times) { + ++count; + LispSetVar(symbol, FIXNUM(count)); + if (count >= end) + break; + } + else { + value = CDR(value); + if (!CONSP(value)) { + LispSetVar(symbol, NIL); + break; + } + LispSetVar(symbol, CAR(value)); + } + } + +loop_done: + result = EVAL(result); + lisp__data.env.head = lisp__data.env.length = head; + GC_LEAVE(); + + return (result); +} + +LispObj * +LispDoListTimes(LispBuiltin *builtin, int times) +/* + dolist init &rest body + dotimes init &rest body + */ +{ + int did_jump, *pdid_jump = &did_jump; + LispObj *result, **presult = &result; + LispBlock *block; + + *presult = NIL; + *pdid_jump = 1; + block = LispBeginBlock(NIL, LispBlockTag); + if (setjmp(block->jmp) == 0) { + result = LispReallyDoListTimes(builtin, times); + did_jump = 0; + } + LispEndBlock(block); + if (did_jump) + result = lisp__data.block.block_ret; + + return (result); +} + +LispObj * +LispLoadFile(LispObj *filename, int verbose, int print, int ifdoesnotexist) +{ + LispObj *stream, *cod, *obj, *result; + int ch; + + LispObj *savepackage; + LispPackage *savepack; + + if (verbose) + LispMessage("; Loading %s", THESTR(filename)); + + if (ifdoesnotexist) { + GC_ENTER(); + result = CONS(filename, CONS(Kif_does_not_exist, CONS(Kerror, NIL))); + GC_PROTECT(result); + stream = APPLY(Oopen, result); + GC_LEAVE(); + } + else + stream = APPLY1(Oopen, filename); + + if (stream == NIL) + return (NIL); + + result = NIL; + LispPushInput(stream); + ch = LispGet(); + if (ch != '#') + LispUnget(ch); + else if ((ch = LispGet()) == '!') { + for (;;) { + ch = LispGet(); + if (ch == '\n' || ch == EOF) + break; + } + } + else { + LispUnget(ch); + LispUnget('#'); + } + + /* Save package environment */ + savepackage = PACKAGE; + savepack = lisp__data.pack; + + cod = COD; + + /*CONSTCOND*/ + while (1) { + if ((obj = LispRead()) != NULL) { + result = EVAL(obj); + COD = cod; + if (print) { + int i; + + if (RETURN_COUNT >= 0) + LispPrint(result, NIL, 1); + for (i = 0; i < RETURN_COUNT; i++) + LispPrint(RETURN(i), NIL, 1); + } + } + if (lisp__data.eof) + break; + } + LispPopInput(stream); + + /* Restore package environment */ + PACKAGE = savepackage; + lisp__data.pack = savepack; + + APPLY1(Oclose, stream); + + return (T); +} + +void +LispGetStringArgs(LispBuiltin *builtin, + char **string1, char **string2, + long *start1, long *end1, long *start2, long *end2) +{ + long length1, length2; + LispObj *ostring1, *ostring2, *ostart1, *oend1, *ostart2, *oend2; + + oend2 = ARGUMENT(5); + ostart2 = ARGUMENT(4); + oend1 = ARGUMENT(3); + ostart1 = ARGUMENT(2); + ostring2 = ARGUMENT(1); + ostring1 = ARGUMENT(0); + + CHECK_STRING(ostring1); + *string1 = THESTR(ostring1); + length1 = STRLEN(ostring1); + + CHECK_STRING(ostring2); + *string2 = THESTR(ostring2); + length2 = STRLEN(ostring2); + + if (ostart1 == UNSPEC) + *start1 = 0; + else { + CHECK_INDEX(ostart1); + *start1 = FIXNUM_VALUE(ostart1); + } + if (oend1 == UNSPEC) + *end1 = length1; + else { + CHECK_INDEX(oend1); + *end1 = FIXNUM_VALUE(oend1); + } + + if (ostart2 == UNSPEC) + *start2 = 0; + else { + CHECK_INDEX(ostart2); + *start2 = FIXNUM_VALUE(ostart2); + } + + if (oend2 == UNSPEC) + *end2 = length2; + else { + CHECK_INDEX(oend2); + *end2 = FIXNUM_VALUE(oend2); + } + + if (*start1 > *end1) + LispDestroy("%s: :START1 %ld larger than :END1 %ld", + STRFUN(builtin), *start1, *end1); + if (*start2 > *end2) + LispDestroy("%s: :START2 %ld larger than :END2 %ld", + STRFUN(builtin), *start2, *end2); + if (*end1 > length1) + LispDestroy("%s: :END1 %ld larger than string length %ld", + STRFUN(builtin), *end1, length1); + if (*end2 > length2) + LispDestroy("%s: :END2 %ld larger than string length %ld", + STRFUN(builtin), *end2, length2); +} + +LispObj * +LispPathnameField(int field, int string) +{ + int offset = field; + LispObj *pathname, *result, *object; + + pathname = ARGUMENT(0); + + if (PATHNAMEP(pathname)) + pathname = APPLY1(Oparse_namestring, pathname); + + result = pathname->data.pathname; + while (offset) { + result = CDR(result); + --offset; + } + object = result; + result = CAR(result); + + if (string) { + if (!STRINGP(result)) { + if (result == NIL) + result = STRING(""); + else if (field == PATH_DIRECTORY) { + char *name = THESTR(CAR(pathname->data.pathname)), *ptr; + + ptr = strrchr(name, PATH_SEP); + if (ptr) { + int length = ptr - name + 1; + char data[PATH_MAX]; + + if (length > PATH_MAX - 1) + length = PATH_MAX - 1; + strncpy(data, name, length); + data[length] = '\0'; + result = STRING(data); + } + else + result = STRING(""); + } + else + result = Kunspecific; + } + else if (field == PATH_NAME) { + object = CAR(CDR(object)); + if (STRINGP(object)) { + int length; + char name[PATH_MAX + 1]; + + strcpy(name, THESTR(result)); + length = STRLEN(result); + if (length + 1 < sizeof(name)) { + name[length++] = PATH_TYPESEP; + name[length] = '\0'; + } + if (STRLEN(object) + length < sizeof(name)) + strcpy(name + length, THESTR(object)); + /* else LispDestroy ... */ + result = STRING(name); + } + } + } + + return (result); +} + +LispObj * +LispProbeFile(LispBuiltin *builtin, int probe) +{ + GC_ENTER(); + LispObj *result; + char *name = NULL, resolved[PATH_MAX + 1]; + struct stat st; + + LispObj *pathname; + + pathname = ARGUMENT(0); + + if (!POINTERP(pathname)) + goto bad_pathname; + + if (XSTRINGP(pathname)) + name = THESTR(pathname); + else if (XPATHNAMEP(pathname)) + name = THESTR(CAR(pathname->data.pathname)); + else if (STREAMP(pathname) && pathname->data.stream.type == LispStreamFile) + name = THESTR(CAR(pathname->data.stream.pathname->data.pathname)); + + if (realpath(name, &resolved[0]) == NULL || + stat(resolved, &st)) { + if (probe) + return (NIL); + LispDestroy("%s: realpath(\"%s\"): %s", + STRFUN(builtin), name, strerror(errno)); + } + + if (S_ISDIR(st.st_mode)) { + int length = strlen(resolved); + + if (!length || resolved[length - 1] != PATH_SEP) { + resolved[length++] = PATH_SEP; + resolved[length] = '\0'; + } + } + + result = STRING(resolved); + GC_PROTECT(result); + result = APPLY1(Oparse_namestring, result); + GC_LEAVE(); + + return (result); + +bad_pathname: + LispDestroy("%s: bad pathname %s", STRFUN(builtin), STROBJ(pathname)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +LispWriteString_(LispBuiltin *builtin, int newline) +/* + write-line string &optional output-stream &key start end + write-string string &optional output-stream &key start end + */ +{ + char *text; + long start, end, length; + + LispObj *string, *output_stream, *ostart, *oend; + + oend = ARGUMENT(3); + ostart = ARGUMENT(2); + output_stream = ARGUMENT(1); + string = ARGUMENT(0); + + CHECK_STRING(string); + LispCheckSequenceStartEnd(builtin, string, ostart, oend, + &start, &end, &length); + if (output_stream == UNSPEC) + output_stream = NIL; + text = THESTR(string); + if (end > start) + LispWriteStr(output_stream, text + start, end - start); + if (newline) + LispWriteChar(output_stream, '\n'); + + return (string); +} diff --git a/lisp/helper.h b/lisp/helper.h new file mode 100644 index 0000000..865f397 --- /dev/null +++ b/lisp/helper.h @@ -0,0 +1,115 @@ +/* + * 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/helper.h,v 1.15 2002/11/25 02:35:30 paulo Exp $ */ + +#ifndef Lisp_helper_h +#define Lisp_helper_h + +#include "private.h" + +/* + * Prototypes + */ +void LispCheckSequenceStartEnd(LispBuiltin*, LispObj*, + LispObj*, LispObj*, long*, long*, long*); +long LispLength(LispObj*); +LispObj *LispCharacterCoerce(LispBuiltin*, LispObj*); +LispObj *LispStringCoerce(LispBuiltin*, LispObj*); +LispObj *LispCoerce(LispBuiltin*, LispObj*, LispObj*); + +/* + do init test &rest body + do* init test &rest body + */ +LispObj *LispDo(LispBuiltin*, int); + +/* + dolist init &rest body + dotimes init &rest body + */ +LispObj *LispDoListTimes(LispBuiltin*, int); + +#define FEQ 1 +#define FEQL 2 +#define FEQUAL 3 +#define FEQUALP 4 +LispObj *LispObjectCompare(LispObj*, LispObj*, int); +#define XEQ(x, y) LispObjectCompare(x, y, FEQ) +#define XEQL(x, y) LispObjectCompare(x, y, FEQL) +#define XEQUAL(x, y) LispObjectCompare(x, y, FEQUAL) +#define XEQUALP(x, y) LispObjectCompare(x, y, FEQUALP) + +LispObj *LispLoadFile(LispObj*, int, int, int); + +/* + string= string1 string2 &key start1 end1 start2 end2 + string< string1 string2 &key start1 end1 start2 end2 + string> string1 string2 &key start1 end1 start2 end2 + string<= string1 string2 &key start1 end1 start2 end2 + string>= string1 string2 &key start1 end1 start2 end2 + string/= string1 string2 &key start1 end1 start2 end2 + string-equal string1 string2 &key start1 end1 start2 end2 + string-lessp string1 string2 &key start1 end1 start2 end2 + string-greaterp string1 string2 &key start1 end1 start2 end2 + string-not-lessp string1 string2 &key start1 end1 start2 end2 + string-not-greaterp string1 string2 &key start1 end1 start2 end2 + string-not-equal string1 string2 &key start1 end1 start2 end2 +*/ +void LispGetStringArgs(LispBuiltin*, + char**, /* string1 */ + char**, /* string2 */ + long*, /* start1 */ + long*, /* end1 */ + long*, /* start2 */ + long*); /* end2 */ + +/* + pathname-host pathname + pathname-device pathname + pathname-directory pathname + pathname-name pathname + pathname-type pathname + pathname-version pathname + */ +LispObj *LispPathnameField(int, int); + +/* + truename pathname + probe-file pathname + */ +LispObj *LispProbeFile(LispBuiltin*, int); + +/* + write-string string &optional output-stream &key start end + write-line string &optional output-stream &key start end + */ +LispObj *LispWriteString_(LispBuiltin*, int); + +#endif /* Lisp_helper_h */ diff --git a/lisp/internal.h b/lisp/internal.h new file mode 100644 index 0000000..1061618 --- /dev/null +++ b/lisp/internal.h @@ -0,0 +1,784 @@ +/* + * 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/internal.h,v 1.49 2002/12/11 04:44:27 paulo Exp $ */ + +#ifndef Lisp_internal_h +#define Lisp_internal_h + +#include <stdio.h> +#include "lisp.h" + +#include "mp.h" +#include "re.h" + +/* + * Defines + */ +typedef struct _LispMac LispMac; + +#define STREAM_READ 0x01 +#define STREAM_WRITE 0x02 +#define STREAM_BINARY 0x20 + +#define RPLACA(cons, object) (CAR(cons) = object) +#define RPLACD(cons, object) (CDR(cons) = object) + +#define CAR(list) ((list)->data.cons.car) +#define CAAR(list) ((list)->data.cons.car->data.cons.car) +#define CADR(list) ((list)->data.cons.cdr->data.cons.car) +#define CDR(list) ((list)->data.cons.cdr) +#define CDAR(list) ((list)->data.cons.car->data.cons.cdr) +#define CDDR(list) ((list)->data.cons.cdr->data.cons.cdr) +#define CONS(car, cdr) LispNewCons(car, cdr) +#define EVAL(list) LispEval(list) +#define APPLY(fun, args) LispFuncall(fun, args, 0) +#define APPLY1(fun, arg) LispApply1(fun, arg) +#define APPLY2(fun, arg1, arg2) LispApply2(fun, arg1, arg2) +#define APPLY3(f, a1, a2, a3) LispApply3(f, a1, a2, a3) +#define EXECUTE(string) LispExecute(string) +#define SYMBOL(atom) LispNewSymbol(atom) +#define ATOM(string) LispNewAtom(string, 1) +#define UNINTERNED_ATOM(string) LispNewAtom(string, 0) +#define FUNCTION(symbol) LispNewFunction(symbol) +#define FUNCTION_QUOTE(symbol) LispNewFunctionQuote(symbol) + + /* atom string is a static variable */ +#define ATOM2(string) LispNewSymbol(LispGetPermAtom(string)) + + /* make a gc never released variable with a static string argument */ +#define STATIC_ATOM(string) LispNewStaticAtom(string) + +#define STRING(str) LispNewString(str, strlen(str), 0) +#define LSTRING(str, size) LispNewString(str, size, 0) + + /* string must be from the LispXXX allocation functions, + * and LispMused not yet called on it */ +#define STRING2(str) LispNewString(str, strlen(str), 1) +#define LSTRING2(str, size) LispNewString(str, size, 1) + +#define VECTOR(objects) LispNewVector(objects) + + /* STRINGSTREAM2 and LSTRINGSTREAM2 require that the + * string be allocated from the LispXXX allocation functions, + * and LispMused not yet called on it */ +#define STRINGSTREAM(str, flag) \ + LispNewStringStream(str, flag, strlen(str), 0) +#define STRINGSTREAM2(str, flag) \ + LispNewStringStream(str, flag, strlen(str), 1) +#define LSTRINGSTREAM(str, flag, length) \ + LispNewStringStream(str, flag, length, 0) +#define LSTRINGSTREAM2(str, flag, length) \ + LispNewStringStream(str, flag, length, 1) + +#define FILESTREAM(file, path, flag) \ + LispNewFileStream(file, path, flag) +#define PIPESTREAM(file, path, flag) \ + LispNewPipeStream(file, path, flag) + +#define CHECKO(obj, typ) \ + ((obj)->type == LispOpaque_t && \ + ((obj)->data.opaque.type == typ || (obj)->data.opaque.type == 0)) +#define PROTECT(key, list) LispProtect(key, list) +#define UPROTECT(key, list) LispUProtect(key, list) + +/* create a new unique static atom string */ +#define GETATOMID(string) LispGetAtomString(string, 1) + +#define GCDisable() ++gcpro +#define GCEnable() --gcpro + + +/* pointer to something unique to all atoms with the same print representation */ +#define ATOMID(object) (object)->data.atom->string + + + +#define NIL_BIT 0x01 +#define FIXNUM_BIT 0x02 +#define FIXNUM_MASK 0x03 +#define SCHAR_BIT 0x04 +#define SCHAR_MASK 0x05 +#define BIT_COUNT 4 +#define BIT_MASK 0x0f +#define POINTERP(object) \ + (((unsigned long)(object) & NIL_BIT) == 0) + +#define MOST_POSITIVE_FIXNUM ((1L << (sizeof(long) * 8 - 5)) - 1) +#define MOST_NEGATIVE_FIXNUM (-1L << (sizeof(long) * 8 - 5)) + +#define SCHAR(value) \ + ((LispObj*)(((long)(value) << BIT_COUNT) | SCHAR_MASK)) +#define SCHAR_VALUE(object) FIXNUM_VALUE(object) +#define SCHARP(object) \ + (((unsigned long)(object) & BIT_MASK) == SCHAR_MASK) +#define CHECK_SCHAR(object) \ + if (!SCHARP(object)) \ + LispDestroy("%s: %s is not a character", \ + STRFUN(builtin), STROBJ(object)) + +#define XOBJECT_TYPE(object) ((object)->type) +#define OBJECT_TYPE(object) \ + (POINTERP(object) ? XOBJECT_TYPE(object) : (long)(object) & BIT_MASK) + + +#define NIL (LispObj*)0x00000001 +#define T (LispObj*)0x00000011 +#define DOT (LispObj*)0x00000021 +/* unmatched ')' */ +#define EOLIST (LispObj*)0x00000031 +#define READLABEL_MASK 0x00000041 +/* unspecified argument */ +#define UNSPEC (LispObj*)0x00000051 +#define INVALIDP(object) \ + ((object) == NULL || (object) == EOLIST || (object) == DOT) + + +/* cons */ +#define XCONSP(object) ((object)->type == LispCons_t) +#define CONSP(object) (POINTERP(object) && XCONSP(object)) +#define CHECK_CONS(object) \ + if (!CONSP(object)) \ + LispDestroy("%s: %s is not of type cons", \ + STRFUN(builtin), STROBJ(object)) +#define LISTP(object) (object == NIL || CONSP(object)) +#define CHECK_LIST(object) \ + if (!LISTP(object)) \ + LispDestroy("%s: %s is not a list", \ + STRFUN(builtin), STROBJ(object)) + +/* fixnum */ +#define FIXNUM(value) \ + ((LispObj*)(((long)(value) << BIT_COUNT) | FIXNUM_MASK)) +#define FIXNUM_VALUE(object) ((long)(object) >> BIT_COUNT) +#define FIXNUMP(object) \ + (((unsigned long)(object) & BIT_MASK) == FIXNUM_MASK) +#define CHECK_FIXNUM(object) \ + if (!FIXNUMP(object)) \ + LispDestroy("%s: %s is not a fixnum", \ + STRFUN(builtin), STROBJ(object)) +#define INDEXP(object) \ + (FIXNUMP(object) && FIXNUM_VALUE(object) >= 0) +#define CHECK_INDEX(object) \ + if (!INDEXP(object)) \ + LispDestroy("%s: %s is not a positive fixnum", \ + STRFUN(builtin), STROBJ(object)) + + +/* long int integer */ +#define XINTP(object) ((object)->type == LispInteger_t) +#define INTP(objet) (POINTERP(object) && XINTP(object)) +#define INT_VALUE(object) (object)->data.integer + + +/* values that fit in a machine long int but not in a fixnum */ +#define LONGINTP(object) \ + (POINTERP(object) ? XINTP(object) : FIXNUMP(object)) +#define LONGINT_VALUE(object) \ + (POINTERP(object) ? INT_VALUE(object) : FIXNUM_VALUE(object)) +#define CHECK_LONGINT(object) \ + if (!LONGINTP(object)) \ + LispDestroy("%s: %s is not an integer", \ + STRFUN(builtin), STROBJ(object)) + + +/* bignum */ +#define XBIGNUMP(object) ((object)->type == LispBignum_t) +#define BIGNUMP(object) (POINTERP(object) && XBIGNUMP(object)) +#define BIGNUM(object) LispNewBignum(object) + + +/* generic integer */ +#define INTEGER(integer) LispNewInteger(integer) +#define INTEGERP(object) \ + (POINTERP(object) ? XINTP(object) || XBIGNUMP(object) : FIXNUMP(object)) +#define CHECK_INTEGER(object) \ + if (!INTEGERP(object)) \ + LispDestroy("%s: %s is not an integer", \ + STRFUN(builtin), STROBJ(object)) + + +/* ratio */ +#define XRATIOP(object) ((object)->type == LispRatio_t) +#define RATIOP(object) (POINTERP(object) && XRATIOP(object)) +#define RATIO(num, den) LispNewRatio(num, den) + + +/* bigratio */ +#define XBIGRATIOP(object) ((object)->type == LispBigratio_t) +#define BIGRATIOP(object) (POINTERP(object) && XBIGRATIOP(object)) +#define BIGRATIO(ratio) LispNewBigratio(ratio) + + +/* generic rational */ +#define RATIONALP(object) \ + (POINTERP(object) ? XINTP(object) || XRATIOP(object) || \ + XBIGNUMP(object) || XBIGRATIOP(object) : \ + FIXNUMP(object)) + + +/* double float */ +#define XDFLOATP(object) ((object)->type == LispDFloat_t) +#define DFLOATP(object) (POINTERP(object) && XDFLOATP(object)) +#define DFLOAT_VALUE(object) (object)->data.dfloat +#define CHECK_DFLOAT(object) \ + if (!DFLOATP(object)) \ + LispDestroy("%s: %s is not a float number", \ + STRFUN(builtin), STROBJ(object)) +#define DFLOAT(value) LispNewDFloat(value) + + +/* generic float - currently only double float supported */ +#define FLOATP(object) DFLOATP(object) + + +/* real number */ +#define REALP(object) \ + (POINTERP(object) ? XINTP(object) || XDFLOATP(object) || \ + XRATIOP(object) || XBIGNUMP(object) || \ + XBIGRATIOP(object) : \ + FIXNUMP(object)) +#define CHECK_REAL(object) \ + if (!REALP(object)) \ + LispDestroy("%s: %s is not a real number", \ + STRFUN(builtin), STROBJ(object)) + + +/* complex */ +#define XCOMPLEXP(object) ((object)->type == LispComplex_t) +#define COMPLEXP(object) (POINTERP(object) && XCOMPLEXP(object)) +#define COMPLEX(real, imag) LispNewComplex(real, imag) + + +/* generic number */ +#define NUMBERP(object) \ + (POINTERP(object) ? XINTP(object) || XDFLOATP(object) || \ + XRATIOP(object) || XBIGNUMP(object) || \ + XBIGRATIOP(object) || XCOMPLEXP(object) : \ + FIXNUMP(object)) +#define CHECK_NUMBER(object) \ + if (!NUMBERP(object)) \ + LispDestroy("%s: %s is not a number", \ + STRFUN(builtin), STROBJ(object)) + + +/* symbol */ +#define XSYMBOLP(object) ((object)->type == LispAtom_t) +#define SYMBOLP(object) (POINTERP(object) && XSYMBOLP(object)) +#define CHECK_SYMBOL(object) \ + if (!SYMBOLP(object)) \ + LispDestroy("%s: %s is not a symbol", \ + STRFUN(builtin), STROBJ(object)) + + +/* keyword */ +#define XKEYWORDP(object) \ + ((object)->data.atom->package == lisp__data.keyword) +#define KEYWORDP(object) \ + (POINTERP(object) && XSYMBOLP(object) && XKEYWORDP(object)) +#define KEYWORD(string) LispNewKeyword(string) +#define CHECK_KEYWORD(object) \ + if (!KEYWORDP(object)) \ + LispDestroy("%s: %s is not a keyword", \ + STRFUN(builtin), STROBJ(object)) +#define CHECK_CONSTANT(object) \ + if ((object)->data.atom->constant) \ + LispDestroy("%s: %s is a constant", \ + STRFUN(builtin), STROBJ(object)) + +#define SETVALUE(atom, object) ((atom)->property->value = object) + + +/* function */ +#define XFUNCTIONP(object) ((object)->type == LispFunction_t) +#define FUNCTIONP(object) (POINTERP(object) && XFUNCTIONP(object)) + + +/* lambda */ +#define XLAMBDAP(object) ((object)->type == LispLambda_t) +#define LAMBDAP(object) (POINTERP(object) && XLAMBDAP(object)) + + +/* string - currently only simple 8 bit characters */ +#define XSTRINGP(object) ((object)->type == LispString_t) +#define STRINGP(object) (POINTERP(object) && XSTRINGP(object)) +#define THESTR(object) (object)->data.string.string +#define STRLEN(object) (object)->data.string.length +#define CHECK_STRING(object) \ + if (!STRINGP(object)) \ + LispDestroy("%s: %s is not a string", \ + STRFUN(builtin), STROBJ(object)) +#define CHECK_STRING_WRITABLE(object) \ + if (!object->data.string.writable) \ + LispDestroy("%s: %s is readonly", \ + STRFUN(builtin), STROBJ(object)) + + +/* array/vector */ +#define XARRAYP(object) ((object)->type == LispArray_t) +#define ARRAYP(object) (POINTERP(object) && XARRAYP(object)) +#define CHECK_ARRAY(object) \ + if (!ARRAYP(object)) \ + LispDestroy("%s: %s is not an array", \ + STRFUN(builtin), STROBJ(object)) + + +/* quote */ +#define XQUOTEP(object) ((object)->type == LispQuote_t) +#define QUOTEP(object) (POINTERP(object) && XQUOTEP(object)) +#define QUOTE(object) LispNewQuote(object) + +#define XBACKQUOTEP(object) ((object)->type == LispBackquote_t) +#define BACKQUOTEP(object) (POINTERP(object) && XBACKQUOTEP(object)) +#define BACKQUOTE(object) LispNewBackquote(object) + +#define XCOMMAP(object) ((object)->type == LispComma_t) +#define COMMAP(object) (POINTERP(object) && XCOMMAP(object)) +#define COMMA(object, at) LispNewComma(object, at) + + +/* package */ +#define XPACKAGEP(object) ((object)->type == LispPackage_t) +#define PACKAGEP(object) (POINTERP(object) && XPACKAGEP(object)) + + +/* pathname */ +#define XPATHNAMEP(object) ((object)->type == LispPathname_t) +#define PATHNAMEP(object) (POINTERP(object) && XPATHNAMEP(object)) +#define PATHNAME(object) LispNewPathname(object) +#define CHECK_PATHNAME(object) \ + if (!PATHNAMEP(object)) \ + LispDestroy("%s: %s is not a pathname", \ + STRFUN(builtin), STROBJ(object)) + + +/* stream */ +#define XSTREAMP(object) ((object)->type == LispStream_t) +#define STREAMP(object) (POINTERP(object) && XSTREAMP(object)) +#define CHECK_STREAM(object) \ + if (!STREAMP(object)) \ + LispDestroy("%s: %s is not a stream", \ + STRFUN(builtin), STROBJ(object)) + + +/* hastable */ +#define XHASHTABLEP(object) ((object)->type == LispHashTable_t) +#define HASHTABLEP(object) (POINTERP(object) && XHASHTABLEP(object)) +#define CHECK_HASHTABLE(object) \ + if (!HASHTABLEP(object)) \ + LispDestroy("%s: %s is not a hash-table", \ + STRFUN(builtin), STROBJ(object)) + + +/* regex */ +#define XREGEXP(object) ((object)->type == LispRegex_t) +#define REGEXP(object) (POINTERP(object) && XREGEXP(object)) +#define CHECK_REGEX(object) \ + if (!REGEXP(object)) \ + LispDestroy("%s: %s is not a regexp", \ + STRFUN(builtin), STROBJ(object)) + + +/* bytecode */ +#define XBYTECODEP(object) ((object)->type == LispBytecode_t) +#define BYTECODEP(object) (POINTERP(object) && XBYTECODEP(object)) + + +/* opaque */ +#define XOPAQUEP(object) ((object)->type == LispOpaque_t) +#define OPAQUEP(object) (POINTERP(object) && XOPAQUEP(object)) +#define OPAQUE(data, type) LispNewOpaque((void*)((long)data), type) + + + +#define SSTREAMP(str) ((str)->data.stream.source.string) + +#define FSTREAMP(str) ((str)->data.stream.source.file) + +#define PSTREAMP(str) ((str)->data.stream.source.program) +#define PIDPSTREAMP(str) ((str)->data.stream.source.program->pid) +#define IPSTREAMP(str) ((str)->data.stream.source.program->input) +#define OPSTREAMP(str) ((str)->data.stream.source.program->output) +#define EPSTREAMP(str) \ + FSTREAMP((str)->data.stream.source.program->errorp) + +#define LispFileno(file) ((file)->descriptor) + +#define STRFUN(builtin) ATOMID(builtin->symbol) +#define STROBJ(obj) LispStrObj(obj) + +/* fetch builtin function/macro argument value + */ +#define ARGUMENT(index) \ + lisp__data.stack.values[lisp__data.stack.base + (index)] + +#define RETURN(index) lisp__data.returns.values[(index)] +#define RETURN_COUNT lisp__data.returns.count +#define RETURN_CHECK(value) \ + value < MULTIPLE_VALUES_LIMIT ? \ + value : MULTIPLE_VALUES_LIMIT + +#define GC_ENTER() int gc__protect = lisp__data.protect.length + +#define GC_PROTECT(object) \ + if (lisp__data.protect.length >= lisp__data.protect.space) \ + LispMoreProtects(); \ + lisp__data.protect.objects[lisp__data.protect.length++] = object + +#define GC_LEAVE() lisp__data.protect.length = gc__protect + + +#define ERROR_CHECK_SPECIAL_FORM(atom) \ + if (atom->property->fun.builtin->compile) \ + LispDestroy("%s: the special form %s cannot be redefined", \ + STRFUN(builtin), atom->string) + + + +#define CONSTANTP(object) \ + (!POINTERP(object) || \ + XOBJECT_TYPE(object) < LispAtom_t || \ + (XSYMBOLP(object) && XKEYWORDP(object))) + +/* slightly faster test, since keywords are very uncommon as eval arguments */ +#define NCONSTANTP(object) \ + (OBJECT_TYPE(object) >= LispAtom_t) + + +/* + * Types + */ +typedef struct _LispObj LispObj; +typedef struct _LispAtom LispAtom; +typedef struct _LispBuiltin LispBuiltin; +typedef struct _LispModuleData LispModuleData; +typedef struct _LispFile LispFile; +typedef struct _LispString LispString; +typedef struct _LispPackage LispPackage; +typedef struct _LispBytecode LispBytecode; +typedef struct _LispHashTable LispHashTable; + +/* Bytecode compiler data */ +typedef struct _LispCom LispCom; + +typedef char *Atom_id; + +typedef enum _LispType { + /* objects encoded in the LispObj pointer */ + LispNil_t = 1, + LispFixnum_t = 3, + LispSChar_t = 5, + + /* objects that have a structure */ + LispInteger_t = 16, + LispDFloat_t, + LispString_t, + LispRatio_t, + LispOpaque_t, + + /* simple access for marking */ + LispBignum_t, + LispBigratio_t, + + LispAtom_t, + LispFunction_t, + LispFunctionQuote_t, + + LispLambda_t, + + LispComplex_t, + LispCons_t, + LispQuote_t, + LispArray_t, + LispStruct_t, + LispStream_t, + LispBackquote_t, + LispComma_t, + LispPathname_t, + LispPackage_t, + LispRegex_t, + LispBytecode_t, + LispHashTable_t +} LispType; + +typedef enum _LispFunType { + LispLambda, + LispFunction, + LispMacro, + LispSetf +} LispFunType; + +typedef enum _LispStreamType { + LispStreamString, + LispStreamFile, + LispStreamStandard, + LispStreamPipe +} LispStreamType; + +typedef struct { + int pid; /* process id of program */ + LispFile *input; /* if READABLE: stdout of program */ + LispFile *output; /* if WRITABLE: stdin of program */ + LispObj *errorp; /* ALWAYS (ONLY) READABLE: stderr of program */ +} LispPipe; + +struct _LispObj { + LispType type : 6; + unsigned int mark : 1; /* gc protected */ + unsigned int prot: 1; /* protection for constant/unamed variables */ + LispFunType funtype : 4; /* this is subject to change in the future */ + union { + LispAtom *atom; + struct { + char *string; + long length; + int writable : 1; + } string; + long integer; + double dfloat; + LispObj *quote; + LispObj *pathname; /* don't use quote generic name, + * to avoid confusing code */ + struct { + long numerator; + long denominator; + } ratio; + union { + mpi *integer; + mpr *ratio; + } mp; + struct { + LispObj *real; + LispObj *imag; + } complex; + struct { + LispObj *car; + LispObj *cdr; + } cons; + struct { + LispObj *name; + LispObj *code; + LispObj *data; /* extra data to protect */ + } lambda; + struct { + LispObj *list; /* stored as a linear list */ + LispObj *dim; /* dimensions of array */ + unsigned int rank : 8; /* i.e. array-rank-limit => 256 */ + unsigned int type : 7; /* converted to LispType, if not + * Lisp_Nil_t only accepts given + * type in array fields */ + unsigned int zero : 1; /* at least one of the dimensions + * is zero */ + } array; + struct { + LispObj *fields; /* structure fields */ + LispObj *def; /* structure definition */ + } struc; + struct { + union { + LispFile *file; + LispPipe *program; + LispString *string; + } source; + LispObj *pathname; + LispStreamType type : 6; + int readable : 1; + int writable : 1; + } stream; + struct { + void *data; + int type; + } opaque; + struct { + LispObj *eval; + int atlist; + } comma; + struct { + LispObj *name; + LispObj *nicknames; + LispPackage *package; + } package; + struct { + re_cod *regex; + LispObj *pattern; /* regex string */ + int options; /* regex compile flags */ + } regex; + struct { + LispBytecode *bytecode; + LispObj *code; /* object used to generate bytecode */ + LispObj *name; /* name of function, or NIL */ + } bytecode; + struct { + LispHashTable *table; + LispObj *test; + } hash; + } data; +}; + +typedef LispObj *(*LispFunPtr)(LispBuiltin*); +typedef void (*LispComPtr)(LispCom*, LispBuiltin*); + +struct _LispBuiltin { + /* these fields must be set */ + LispFunType type; + LispFunPtr function; + char *declaration; + + /* this field is optional, set if the function returns multiple values */ + int multiple_values; + + /* this field is also optional, set if the function should not be exported */ + int internal; + + /* this optional field points to a function of the bytecode compiler */ + LispComPtr compile; + + /* this field is set at runtime */ + LispObj *symbol; +}; + +typedef int (*LispLoadModule)(void); +typedef int (*LispUnloadModule)(void); + +#define LISP_MODULE_VERSION 1 +struct _LispModuleData { + int version; + LispLoadModule load; + LispUnloadModule unload; +}; + +/* + * Prototypes + */ +LispObj *LispEval(LispObj*); +LispObj *LispFuncall(LispObj*, LispObj*, int); +LispObj *LispApply1(LispObj*, LispObj*); +LispObj *LispApply2(LispObj*, LispObj*, LispObj*); +LispObj *LispApply3(LispObj*, LispObj*, LispObj*, LispObj*); + +LispObj *LispNew(LispObj*, LispObj*); +LispObj *LispNewSymbol(LispAtom*); +LispObj *LispNewAtom(char*, int); +LispObj *LispNewFunction(LispObj*); +LispObj *LispNewFunctionQuote(LispObj*); +LispObj *LispNewStaticAtom(char*); +LispObj *LispNewDFloat(double); +LispObj *LispNewString(char*, long, int); +LispObj *LispNewInteger(long); +LispObj *LispNewRatio(long, long); +LispObj *LispNewVector(LispObj*); +LispObj *LispNewQuote(LispObj*); +LispObj *LispNewBackquote(LispObj*); +LispObj *LispNewComma(LispObj*, int); +LispObj *LispNewCons(LispObj*, LispObj*); +LispObj *LispNewLambda(LispObj*, LispObj*, LispObj*, LispFunType); +LispObj *LispNewStruct(LispObj*, LispObj*); +LispObj *LispNewComplex(LispObj*, LispObj*); +LispObj *LispNewOpaque(void*, int); +LispObj *LispNewKeyword(char*); +LispObj *LispNewPathname(LispObj*); +LispObj *LispNewStringStream(char*, int, long, int); +LispObj *LispNewFileStream(LispFile*, LispObj*, int); +LispObj *LispNewPipeStream(LispPipe*, LispObj*, int); +LispObj *LispNewBignum(mpi*); +LispObj *LispNewBigratio(mpr*); + +LispAtom *LispGetAtom(char*); + +/* This function does not allocate a copy of it's argument, but the argument + * itself. The argument string should never change. */ +LispAtom *LispGetPermAtom(char*); + +void *LispMalloc(size_t); +void *LispCalloc(size_t, size_t); +void *LispRealloc(void*, size_t); +char *LispStrdup(char*); +void LispFree(void*); +/* LispMused means memory is now safe from LispDestroy, and should not be + * freed in case of an error */ +void LispMused(void*); + +void LispGC(LispObj*, LispObj*); + +char *LispStrObj(LispObj*); + +#ifdef __GNUC__ +#define PRINTF_FORMAT __attribute__ ((format (printf, 1, 2))) +#else +#define PRINTF_FORMAT /**/ +#endif +void LispDestroy(char *fmt, ...) PRINTF_FORMAT; + /* continuable error */ +void LispContinuable(char *fmt, ...) PRINTF_FORMAT; +void LispMessage(char *fmt, ...) PRINTF_FORMAT; +void LispWarning(char *fmt, ...) PRINTF_FORMAT; +#undef PRINTF_FORMAT + +LispObj *LispSetVariable(LispObj*, LispObj*, char*, int); + +int LispRegisterOpaqueType(char*); + +int LispPrintString(LispObj*, char*); + +void LispProtect(LispObj*, LispObj*); +void LispUProtect(LispObj*, LispObj*); + +/* this function should be called when a module is loaded, and is called + * when loading the interpreter */ +void LispAddBuiltinFunction(LispBuiltin*); + +/* + * Initialization + */ +extern LispObj *UNBOUND; +extern int gcpro; + +extern LispObj *Okey, *Orest, *Ooptional, *Oaux, *Olambda; +extern Atom_id Snil, St, Skey, Srest, Soptional, Saux; +extern Atom_id Sand, Sor, Snot; +extern Atom_id Satom, Ssymbol, Sinteger, Scharacter, Sstring, Slist, + Scons, Svector, Sarray, Sstruct, Skeyword, Sfunction, Spathname, + Srational, Sfloat, Scomplex, Sopaque, Sdefault; + +extern LispObj *Ocomplex, *Oformat, *Kunspecific; + +extern LispObj *Omake_array, *Kinitial_contents, *Osetf; +extern Atom_id Svariable, Sstructure, Stype, Ssetf; + +extern Atom_id Smake_struct, Sstruct_access, Sstruct_store, Sstruct_type; +extern LispObj *Omake_struct, *Ostruct_access, *Ostruct_store, *Ostruct_type; + +extern LispObj *Oparse_namestring, *Kerror, *Kabsolute, *Krelative, *Oopen, + *Oclose, *Kif_does_not_exist; + +extern LispObj *Oequal_; + +extern LispFile *Stdout, *Stdin, *Stderr; + +#endif /* Lisp_internal_h */ diff --git a/lisp/io.c b/lisp/io.c new file mode 100644 index 0000000..ea59575 --- /dev/null +++ b/lisp/io.c @@ -0,0 +1,709 @@ +/* + * Copyright (c) 2002 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/io.c,v 1.16 2002/12/16 03:59:27 paulo Exp $ */ + +#include "io.h" +#include <errno.h> +#include <fcntl.h> +#include <stdarg.h> +#include <sys/types.h> +#include <sys/stat.h> + +/* Match the FILE_XXX flags */ +#define READ_BIT 0x01 +#define WRITE_BIT 0x02 +#define APPEND_BIT 0x04 +#define BUFFERED_BIT 0x08 +#define UNBUFFERED_BIT 0x10 +#define BINARY_BIT 0x20 + +/* + * Prototypes + */ +static int calculate_line(void*, int); +static int calculate_column(void*, int, int); + +/* + * Initialization + */ +extern int pagesize; + +/* + * Implementation + */ +int +LispGet(void) +{ + int ch = EOF; + LispUngetInfo *unget = lisp__data.unget[lisp__data.iunget]; + + if (unget->offset) + ch = ((unsigned char*)unget->buffer)[--unget->offset]; + else if (SINPUT->data.stream.readable) { + LispFile *file = NULL; + + switch (SINPUT->data.stream.type) { + case LispStreamStandard: + case LispStreamFile: + file = FSTREAMP(SINPUT); + break; + case LispStreamPipe: + file = IPSTREAMP(SINPUT); + break; + case LispStreamString: + ch = LispSgetc(SSTREAMP(SINPUT)); + break; + default: + ch = EOF; + break; + } + if (file != NULL) { + if (file->nonblock) { + if (fcntl(file->descriptor, F_SETFL, 0) < 0) + LispDestroy("fcntl: %s", strerror(errno)); + file->nonblock = 0; + } + ch = LispFgetc(file); + } + } + else + LispDestroy("cannot read from *STANDARD-INPUT*"); + + if (ch == EOF) + lisp__data.eof = 1; + + return (ch); +} + +int +LispUnget(int ch) +{ + LispUngetInfo *unget = lisp__data.unget[lisp__data.iunget]; + + if (unget->offset == sizeof(unget->buffer)) { + LispWarning("character %c lost at LispUnget()", unget->buffer[0]); + memmove(unget->buffer, unget->buffer + 1, unget->offset - 1); + unget->buffer[unget->offset - 1] = ch; + } + else + unget->buffer[unget->offset++] = ch; + + return (ch); +} + +void +LispPushInput(LispObj *stream) +{ + if (!STREAMP(stream) || !stream->data.stream.readable) + LispDestroy("bad stream at PUSH-INPUT"); + lisp__data.input_list = CONS(stream, lisp__data.input_list); + SINPUT = stream; + if (lisp__data.iunget + 1 == lisp__data.nunget) { + LispUngetInfo **info = + realloc(lisp__data.unget, + sizeof(LispUngetInfo) * (lisp__data.nunget + 1)); + + if (!info || + (info[lisp__data.nunget] = + calloc(1, sizeof(LispUngetInfo))) == NULL) + LispDestroy("out of memory"); + lisp__data.unget = info; + ++lisp__data.nunget; + } + ++lisp__data.iunget; + memset(lisp__data.unget[lisp__data.iunget], '\0', sizeof(LispUngetInfo)); + lisp__data.eof = 0; +} + +void +LispPopInput(LispObj *stream) +{ + if (!CONSP(lisp__data.input_list) || stream != CAR(lisp__data.input_list)) + LispDestroy("bad stream at POP-INPUT"); + lisp__data.input_list = CDR(lisp__data.input_list); + SINPUT = CONSP(lisp__data.input_list) ? + CAR(lisp__data.input_list) : lisp__data.input_list; + --lisp__data.iunget; + lisp__data.eof = 0; +} + +/* + * Low level functions + */ +static int +calculate_line(void *data, int size) +{ + int line = 0; + char *str, *ptr; + + for (str = (char*)data, ptr = (char*)data + size; str < ptr; str++) + if (*ptr == '\n') + ++line; + + return (line); +} + +static int +calculate_column(void *data, int size, int column) +{ + char *str, *ptr; + + /* search for newline in data */ + for (str = (char*)data, ptr = (char*)data + size - 1; ptr >= str; ptr--) + if (*ptr == '\n') + break; + + /* newline found */ + if (ptr >= str) + return (size - (ptr - str) - 1); + + /* newline not found */ + return (column + size); +} + +LispFile * +LispFdopen(int descriptor, int mode) +{ + LispFile *file = calloc(1, sizeof(LispFile)); + + if (file) { + struct stat st; + + file->descriptor = descriptor; + file->readable = (mode & READ_BIT) != 0; + file->writable = (mode & WRITE_BIT) != 0; + + if (fstat(descriptor, &st) == 0) + file->regular = S_ISREG(st.st_mode); + else + file->regular = 0; + + file->buffered = (mode & BUFFERED_BIT) != 0; + if ((mode & UNBUFFERED_BIT) == 0) + file->buffered = file->regular; + + if (file->buffered) { + file->buffer = malloc(pagesize); + if (file->buffer == NULL) + file->buffered = 0; + } + file->line = 1; + file->binary = (mode & BINARY_BIT) != 0; + file->io_write = write; + } + + return (file); +} + +LispFile * +LispFopen(char *path, int mode) +{ + LispFile *file; + int descriptor; + int flags = O_NOCTTY; + + /* check read/write attributes */ + if ((mode & (READ_BIT | WRITE_BIT)) == (READ_BIT | WRITE_BIT)) + flags |= O_RDWR; + else if (mode & READ_BIT) + flags |= O_RDONLY; + else if (mode & WRITE_BIT) + flags |= O_WRONLY; + + /* create if does not exist */ + if (mode & WRITE_BIT) { + flags |= O_CREAT; + + /* append if exists? */ + if (mode & APPEND_BIT) + flags |= O_APPEND; + else + flags |= O_TRUNC; + } + + /* open file */ + descriptor = open(path, flags, 0666); + if (descriptor < 0) + return (NULL); + + /* initialize LispFile structure */ + file = LispFdopen(descriptor, mode); + if (file == NULL) + close(descriptor); + + return (file); +} + +void +LispFclose(LispFile *file) +{ + /* flush any pending output */ + LispFflush(file); + /* cleanup */ + close(file->descriptor); + if (file->buffer) + free(file->buffer); + free(file); +} + +io_write_fn +LispSetFileWrite(LispFile *file, io_write_fn new_write) +{ + io_write_fn old_write = file->io_write; + + file->io_write = new_write; + + return (old_write); +} + +int +LispFflush(LispFile *file) +{ + if (file->writable && file->length) { + int length = (*file->io_write)(file->descriptor, + file->buffer, file->length); + + if (length > 0) { + if (file->length > length) + memmove(file->buffer, file->buffer + length, + file->length - length); + file->length -= length; + } + return (length); + } + + return (0); +} + +int +LispFungetc(LispFile *file, int ch) +{ + if (file->readable) { + file->available = 1; + file->unget = ch; + /* this should never happen */ + if (ch == '\n' && !file->binary) + --file->line; + } + + return (ch); +} + +int +LispFgetc(LispFile *file) +{ + int ch; + + if (file->readable) { + unsigned char c; + + if (file->available) { + ch = file->unget; + file->available = 0; + } + else if (file->buffered) { + if (file->writable) { + LispFflush(file); + if (read(file->descriptor, &c, 1) == 1) + ch = c; + else + ch = EOF; + } + else { + if (file->offset < file->length) + ch = ((unsigned char*)file->buffer)[file->offset++]; + else { + int length = read(file->descriptor, + file->buffer, pagesize); + + if (length >= 0) + file->length = length; + else + file->length = 0; + file->offset = 0; + if (file->length) + ch = ((unsigned char*)file->buffer)[file->offset++]; + else + ch = EOF; + } + } + } + else if (read(file->descriptor, &c, 1) == 1) + ch = c; + else + ch = EOF; + } + else + ch = EOF; + + if (ch == '\n' && !file->binary) + ++file->line; + + return (ch); +} + +int +LispFputc(LispFile *file, int ch) +{ + if (file->writable) { + unsigned char c = ch; + + if (file->buffered) { + if (file->length + 1 >= pagesize) + LispFflush(file); + file->buffer[file->length++] = c; + } + else if ((*file->io_write)(file->descriptor, &c, 1) != 1) + ch = EOF; + + if (!file->binary) { + /* update column number */ + if (ch == '\n') + file->column = 0; + else + ++file->column; + } + } + + return (ch); +} + +int +LispSgetc(LispString *string) +{ + int ch; + + if (string->input >= string->length) + return (EOF); /* EOF reading from string */ + + ch = ((unsigned char*)string->string)[string->input++]; + if (ch == '\n' && !string->binary) + ++string->line; + + return (ch); +} + +int +LispSputc(LispString *string, int ch) +{ + if (string->output + 1 >= string->space) { + if (string->fixed) + return (EOF); + else { + char *tmp = realloc(string->string, string->space + pagesize); + + if (tmp == NULL) + return (EOF); + string->string = tmp; + string->space += pagesize; + } + } + + string->string[string->output++] = ch; + if (string->length < string->output) + string->length = string->output; + + /* update column number */ + if (!string->binary) { + if (ch == '\n') + string->column = 0; + else + ++string->column; + } + + return (ch); +} + +char * +LispFgets(LispFile *file, char *string, int size) +{ + int ch, offset = 0; + + if (size < 1) + return (string); + + for (;;) { + if (offset + 1 >= size) + break; + if ((ch = LispFgetc(file)) == EOF) + break; + string[offset++] = ch; + /* line number is calculated in LispFgetc */ + if (ch == '\n') + break; + } + string[offset] = '\0'; + + return (offset ? string : NULL); +} + +int +LispFputs(LispFile *file, char *buffer) +{ + return (LispFwrite(file, buffer, strlen(buffer))); +} + +int +LispSputs(LispString *string, char *buffer) +{ + return (LispSwrite(string, buffer, strlen(buffer))); +} + +int +LispFread(LispFile *file, void *data, int size) +{ + int bytes, length; + char *buffer; + + if (!file->readable) + return (EOF); + + if (size <= 0) + return (size); + + length = 0; + buffer = (char*)data; + + /* check if there is an unget character */ + if (file->available) { + *buffer++ = file->unget; + file->available = 0; + if (--size == 0) { + if (file->unget == '\n' && !file->binary) + ++file->line; + + return (1); + } + + length = 1; + } + + if (file->buffered) { + void *base_data = (char*)data - length; + + if (file->writable) { + LispFflush(file); + bytes = read(file->descriptor, buffer, size); + if (bytes < 0) + bytes = 0; + if (!file->binary) + file->line += calculate_line(base_data, length + bytes); + + return (length + bytes); + } + + /* read anything that is in the buffer */ + if (file->offset < file->length) { + bytes = file->length - file->offset; + if (bytes > size) + bytes = size; + memcpy(buffer, file->buffer + file->offset, bytes); + buffer += bytes; + file->offset += bytes; + size -= bytes; + } + + /* if there is still something to read */ + if (size) { + bytes = read(file->descriptor, buffer, size); + if (bytes < 0) + bytes = 0; + + length += bytes; + } + + if (!file->binary) + file->line += calculate_line(base_data, length); + + return (length); + } + + bytes = read(file->descriptor, buffer, size); + if (bytes < 0) + bytes = 0; + if (!file->binary) + file->line += calculate_line(buffer - length, length + bytes); + + return (length + bytes); +} + +int +LispFwrite(LispFile *file, void *data, int size) +{ + if (!file->writable || size < 0) + return (EOF); + + if (!file->binary) + file->column = calculate_column(data, size, file->column); + + if (file->buffered) { + int length, bytes; + char *buffer = (char*)data; + + length = 0; + if (size + file->length > pagesize) { + /* fill remaining space in buffer and flush */ + bytes = pagesize - file->length; + memcpy(file->buffer + file->length, buffer, bytes); + file->length += bytes; + LispFflush(file); + + /* check if all data was written */ + if (file->length) + return (pagesize - file->length); + + length = bytes; + buffer += bytes; + size -= bytes; + } + + while (size > pagesize) { + /* write multiple of pagesize */ + bytes = (*file->io_write)(file->descriptor, buffer, + size - (size % pagesize)); + if (bytes <= 0) + return (length); + + length += bytes; + buffer += bytes; + size -= bytes; + } + + if (size) { + /* keep remaining data in buffer */ + switch (size) { + case 8: + file->buffer[file->length++] = *buffer++; + case 7: + file->buffer[file->length++] = *buffer++; + case 6: + file->buffer[file->length++] = *buffer++; + case 5: + file->buffer[file->length++] = *buffer++; + case 4: + file->buffer[file->length++] = *buffer++; + case 3: + file->buffer[file->length++] = *buffer++; + case 2: + file->buffer[file->length++] = *buffer++; + case 1: + file->buffer[file->length++] = *buffer++; + break; + default: + memcpy(file->buffer + file->length, buffer, size); + file->length += size; + break; + } + length += size; + } + + return (length); + } + + return ((*file->io_write)(file->descriptor, data, size)); +} + +int +LispSwrite(LispString *string, void *data, int size) +{ + if (size < 0) + return (EOF); + + if (string->output + size >= string->space) { + if (string->fixed) { + /* leave space for a ending nul character */ + size = string->space - string->output - 1; + + if (size <= 0) + return (-1); + } + else { + char *tmp = realloc(string->string, string->space + + (size / pagesize) * pagesize + pagesize); + + if (tmp == NULL) + return (-1); + + string->string = tmp; + string->space += pagesize; + } + } + memcpy(string->string + string->output, data, size); + string->output += size; + if (string->length < string->output) + string->length = string->output; + + if (!string->binary) + string->column = calculate_column(data, size, string->column); + + return (size); +} + +char * +LispGetSstring(LispString *string, int *length) +{ + if (string->string == NULL || string->length <= 0) { + *length = 0; + + return (""); + } + *length = string->length; + if (string->string[string->length -1] != '\0') { + if (string->length < string->space) + string->string[string->length] = '\0'; + else if (string->fixed && string->space) + string->string[string->space - 1] = '\0'; + else { + char *tmp = realloc(string->string, string->space + pagesize); + + if (tmp == NULL) + string->string[string->space - 1] = '\0'; + else { + string->string = tmp; + string->space += pagesize; + string->string[string->length] = '\0'; + } + } + } + + return (string->string); +} + +int +LispRename(char *from, char *to) +{ + return (rename(from, to)); +} + +int +LispUnlink(char *name) +{ + return (unlink(name)); +} diff --git a/lisp/io.h b/lisp/io.h new file mode 100644 index 0000000..eb5edc6 --- /dev/null +++ b/lisp/io.h @@ -0,0 +1,115 @@ +/* + * Copyright (c) 2002 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/io.h,v 1.8 2002/12/06 03:25:27 paulo Exp $ */ + +#ifndef Lisp_io_h +#define Lisp_io_h + +#include "private.h" + +#define FILE_READ 0x01 +#define FILE_WRITE 0x02 +#define FILE_IO 0x03 +#define FILE_APPEND 0x06 /* append mode, write bit also set */ +#define FILE_BUFFERED 0x08 /* force buffered mode */ +#define FILE_UNBUFFERED 0x10 /* force unbuffered mode */ +#define FILE_BINARY 0x20 + +/* + * Types + */ +typedef ssize_t (*io_write_fn)(int, const void*, size_t); + +struct _LispFile { + char *buffer; + int line; /* input line number */ + int column; /* output column number */ + int descriptor; + int length; /* number of bytes used */ + int offset; /* read/write offset */ + int unget : 8; /* unread char */ + int readable : 1; + int writable : 1; + int regular : 1; /* regular file */ + int buffered : 1; + int available : 1; /* unget field holds a char */ + int nonblock : 1; /* in nonblock mode */ + int binary : 1; /* if set, don't calculate column/line-number */ + io_write_fn io_write; +}; + +struct _LispString { + char *string; + int line; /* input line number */ + int column; /* output column number */ + int space; /* number of bytes alocated */ + int length; /* number of bytes used */ + int input; /* input offset, for read operations */ + int output; /* output offset, for write operations */ + int fixed : 1; /* if set, don't try to reallocate string */ + int binary : 1; /* if set, don't calculate column/line-number */ +}; + +/* + * Prototypes + */ + /* higher level functions */ +int LispGet(void); +int LispUnget(int); +void LispPushInput(LispObj*); +void LispPopInput(LispObj*); + + /* functions that read/write using the LispFile structure */ +LispFile *LispFdopen(int, int); +LispFile *LispFopen(char*, int); +void LispFclose(LispFile*); +int LispFflush(LispFile*); +int LispFungetc(LispFile*, int); +int LispFgetc(LispFile*); +int LispFputc(LispFile*, int); +char *LispFgets(LispFile*, char*, int); +int LispFputs(LispFile*, char*); +int LispFread(LispFile*, void*, int); +int LispFwrite(LispFile*, void*, int); +int LispRename(char*, char*); +int LispUnlink(char*); + + /* io wrappers */ +io_write_fn LispSetFileWrite(LispFile*, io_write_fn); + + /* functions that read/write using the LispString structure */ +int LispSgetc(LispString*); +int LispSputc(LispString*, int); +int LispSputs(LispString*, char*); +int LispSwrite(LispString*, void*, int); + +char *LispGetSstring(LispString*, int*); + +#endif /* Lisp_io_h */ 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 +} diff --git a/lisp/lisp.h b/lisp/lisp.h new file mode 100644 index 0000000..f783c37 --- /dev/null +++ b/lisp/lisp.h @@ -0,0 +1,44 @@ +/* + * 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.h,v 1.5 2002/11/08 08:00:57 paulo Exp $ */ + +#ifndef Lisp_lisp_h +#define Lisp_lisp_h + +void LispBegin(void); +void LispEnd(void); +void *LispExecute(char*); +void LispMachine(void); +void LispSetPrompt(char*); +void LispSetInteractive(int); +void LispSetExitOnError(int); +void LispDebug(int); /* argument is boolean to enable/disable */ + +#endif /* Lisp_lisp_h */ diff --git a/lisp/lsp.c b/lisp/lsp.c new file mode 100644 index 0000000..920dba0 --- /dev/null +++ b/lisp/lsp.c @@ -0,0 +1,79 @@ +/* + * 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/lsp.c,v 1.7 2002/11/23 08:26:49 paulo Exp $ */ + +#include <stdio.h> +#include <string.h> +#include "lisp.h" + +#ifdef NEED_STRCASECMP +int strcasecmp(const char *s1, const char *s2); +int strncasecmp(const char *s1, const char *s2, size_t n); +#endif +#ifdef NEED_REALPATH +#include <sys/param.h> +#if defined(ISC) +#ifndef MAXPATHLEN +#define MAXPATHLEN 1024 +#endif +#endif +char *realpath(const char *pathname, char resolvedname[MAXPATHLEN]); +#endif + +int +main(int argc, char *argv[]) +{ + int i; + + LispBegin(); + + i = 1; + if (argc > 1 && strcmp(argv[1], "-d") == 0) { + LispDebug(1); + ++i; + } + + if (i < argc) { + char buffer[2048]; + + for (; i < argc; i++) { + snprintf(buffer, sizeof(buffer), + "(load \"%s\" :if-does-not-exist :error)", + argv[i]); + LispExecute(buffer); + } + } + else + LispMachine(); + + LispEnd(); + + return (0); +} diff --git a/lisp/math.c b/lisp/math.c new file mode 100644 index 0000000..fcadefa --- /dev/null +++ b/lisp/math.c @@ -0,0 +1,1473 @@ +/* + * 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/math.c,v 1.22 2002/11/23 21:41:52 paulo Exp $ */ + +#include "math.h" +#include "private.h" + +/* + * Prototypes + */ +static LispObj *LispDivide(LispBuiltin*, int, int); + +/* + * Initialization + */ +static LispObj *obj_zero, *obj_one; +LispObj *Ocomplex, *Oequal_; + +LispObj *Oshort_float, *Osingle_float, *Odouble_float, *Olong_float; + +Atom_id Sdefault_float_format; + +/* + * Implementation + */ +#include "mathimp.c" + +void +LispMathInit(void) +{ + LispObj *object, *result; + + mp_set_malloc(LispMalloc); + mp_set_calloc(LispCalloc); + mp_set_realloc(LispRealloc); + mp_set_free(LispFree); + + number_init(); + obj_zero = FIXNUM(0); + obj_one = FIXNUM(1); + + Oequal_ = STATIC_ATOM("="); + Ocomplex = STATIC_ATOM(Scomplex); + Oshort_float = STATIC_ATOM("SHORT-FLOAT"); + LispExportSymbol(Oshort_float); + Osingle_float = STATIC_ATOM("SINGLE-FLOAT"); + LispExportSymbol(Osingle_float); + Odouble_float = STATIC_ATOM("DOUBLE-FLOAT"); + LispExportSymbol(Odouble_float); + Olong_float = STATIC_ATOM("LONG-FLOAT"); + LispExportSymbol(Olong_float); + + object = STATIC_ATOM("*DEFAULT-FLOAT-FORMAT*"); + LispProclaimSpecial(object, Odouble_float, NIL); + LispExportSymbol(object); + Sdefault_float_format = ATOMID(object); + + object = STATIC_ATOM("PI"); + result = number_pi(); + LispProclaimSpecial(object, result, NIL); + LispExportSymbol(object); + + object = STATIC_ATOM("MOST-POSITIVE-FIXNUM"); + LispDefconstant(object, FIXNUM(MOST_POSITIVE_FIXNUM), NIL); + LispExportSymbol(object); + + object = STATIC_ATOM("MOST-NEGATIVE-FIXNUM"); + LispDefconstant(object, FIXNUM(MOST_NEGATIVE_FIXNUM), NIL); + LispExportSymbol(object); +} + +LispObj * +Lisp_Mul(LispBuiltin *builtin) +/* + * &rest numbers + */ +{ + n_number num; + LispObj *number, *numbers; + + numbers = ARGUMENT(0); + + if (CONSP(numbers)) { + number = CAR(numbers); + + numbers = CDR(numbers); + if (!CONSP(numbers)) { + CHECK_NUMBER(number); + return (number); + } + } + else + return (FIXNUM(1)); + + set_number_object(&num, number); + do { + mul_number_object(&num, CAR(numbers)); + numbers = CDR(numbers); + } while (CONSP(numbers)); + + return (make_number_object(&num)); +} + +LispObj * +Lisp_Plus(LispBuiltin *builtin) +/* + + &rest numbers + */ +{ + n_number num; + LispObj *number, *numbers; + + numbers = ARGUMENT(0); + + if (CONSP(numbers)) { + number = CAR(numbers); + + numbers = CDR(numbers); + if (!CONSP(numbers)) { + CHECK_NUMBER(number); + return (number); + } + } + else + return (FIXNUM(0)); + + set_number_object(&num, number); + do { + add_number_object(&num, CAR(numbers)); + numbers = CDR(numbers); + } while (CONSP(numbers)); + + return (make_number_object(&num)); +} + +LispObj * +Lisp_Minus(LispBuiltin *builtin) +/* + - number &rest more_numbers + */ +{ + n_number num; + LispObj *number, *more_numbers; + + more_numbers = ARGUMENT(1); + number = ARGUMENT(0); + + set_number_object(&num, number); + if (!CONSP(more_numbers)) { + neg_number(&num); + + return (make_number_object(&num)); + } + do { + sub_number_object(&num, CAR(more_numbers)); + more_numbers = CDR(more_numbers); + } while (CONSP(more_numbers)); + + return (make_number_object(&num)); +} + +LispObj * +Lisp_Div(LispBuiltin *builtin) +/* + / number &rest more_numbers + */ +{ + n_number num; + LispObj *number, *more_numbers; + + more_numbers = ARGUMENT(1); + number = ARGUMENT(0); + + if (CONSP(more_numbers)) + set_number_object(&num, number); + else { + num.complex = 0; + num.real.type = N_FIXNUM; + num.real.data.fixnum = 1; + goto div_one_argument; + } + + for (;;) { + number = CAR(more_numbers); + more_numbers = CDR(more_numbers); + +div_one_argument: + div_number_object(&num, number); + if (!CONSP(more_numbers)) + break; + } + + return (make_number_object(&num)); +} + +LispObj * +Lisp_OnePlus(LispBuiltin *builtin) +/* + 1+ number + */ +{ + n_number num; + LispObj *number; + + number = ARGUMENT(0); + num.complex = 0; + num.real.type = N_FIXNUM; + num.real.data.fixnum = 1; + add_number_object(&num, number); + + return (make_number_object(&num)); +} + +LispObj * +Lisp_OneMinus(LispBuiltin *builtin) +/* + 1- number + */ +{ + n_number num; + LispObj *number; + + number = ARGUMENT(0); + num.complex = 0; + num.real.type = N_FIXNUM; + num.real.data.fixnum = -1; + add_number_object(&num, number); + + return (make_number_object(&num)); +} + +LispObj * +Lisp_Less(LispBuiltin *builtin) +/* + < number &rest more-numbers + */ +{ + LispObj *compare, *number, *more_numbers; + + more_numbers = ARGUMENT(1); + compare = ARGUMENT(0); + + if (CONSP(more_numbers)) { + do { + number = CAR(more_numbers); + if (cmp_object_object(compare, number, 1) >= 0) + return (NIL); + compare = number; + more_numbers = CDR(more_numbers); + } while (CONSP(more_numbers)); + } + else { + CHECK_REAL(compare); + } + + return (T); +} + +LispObj * +Lisp_LessEqual(LispBuiltin *builtin) +/* + <= number &rest more-numbers + */ +{ + LispObj *compare, *number, *more_numbers; + + more_numbers = ARGUMENT(1); + compare = ARGUMENT(0); + + if (CONSP(more_numbers)) { + do { + number = CAR(more_numbers); + if (cmp_object_object(compare, number, 1) > 0) + return (NIL); + compare = number; + more_numbers = CDR(more_numbers); + } while (CONSP(more_numbers)); + } + else { + CHECK_REAL(compare); + } + + return (T); +} + +LispObj * +Lisp_Equal_(LispBuiltin *builtin) +/* + = number &rest more-numbers + */ +{ + LispObj *compare, *number, *more_numbers; + + more_numbers = ARGUMENT(1); + compare = ARGUMENT(0); + + if (CONSP(more_numbers)) { + do { + number = CAR(more_numbers); + if (cmp_object_object(compare, number, 0) != 0) + return (NIL); + compare = number; + more_numbers = CDR(more_numbers); + } while (CONSP(more_numbers)); + } + else { + CHECK_REAL(compare); + } + + return (T); +} + +LispObj * +Lisp_Greater(LispBuiltin *builtin) +/* + > number &rest more-numbers + */ +{ + LispObj *compare, *number, *more_numbers; + + more_numbers = ARGUMENT(1); + compare = ARGUMENT(0); + + if (CONSP(more_numbers)) { + do { + number = CAR(more_numbers); + if (cmp_object_object(compare, number, 1) <= 0) + return (NIL); + compare = number; + more_numbers = CDR(more_numbers); + } while (CONSP(more_numbers)); + } + else { + CHECK_REAL(compare); + } + + return (T); +} + +LispObj * +Lisp_GreaterEqual(LispBuiltin *builtin) +/* + >= number &rest more-numbers + */ +{ + LispObj *compare, *number, *more_numbers; + + more_numbers = ARGUMENT(1); + compare = ARGUMENT(0); + + if (CONSP(more_numbers)) { + do { + number = CAR(more_numbers); + if (cmp_object_object(compare, number, 1) < 0) + return (NIL); + compare = number; + more_numbers = CDR(more_numbers); + } while (CONSP(more_numbers)); + } + else { + CHECK_REAL(compare); + } + + return (T); +} + +LispObj * +Lisp_NotEqual(LispBuiltin *builtin) +/* + /= number &rest more-numbers + */ +{ + LispObj *object, *compare, *number, *more_numbers; + + more_numbers = ARGUMENT(1); + number = ARGUMENT(0); + + if (!CONSP(more_numbers)) { + CHECK_REAL(number); + + return (T); + } + + /* compare all numbers */ + while (1) { + compare = number; + for (object = more_numbers; CONSP(object); object = CDR(object)) { + number = CAR(object); + + if (cmp_object_object(compare, number, 0) == 0) + return (NIL); + } + if (CONSP(more_numbers)) { + number = CAR(more_numbers); + more_numbers = CDR(more_numbers); + } + else + break; + } + + return (T); +} + +LispObj * +Lisp_Min(LispBuiltin *builtin) +/* + min number &rest more-numbers + */ +{ + LispObj *result, *number, *more_numbers; + + more_numbers = ARGUMENT(1); + result = ARGUMENT(0); + + if (CONSP(more_numbers)) { + do { + number = CAR(more_numbers); + if (cmp_object_object(result, number, 1) > 0) + result = number; + more_numbers = CDR(more_numbers); + } while (CONSP(more_numbers)); + } + else { + CHECK_REAL(result); + } + + return (result); +} + +LispObj * +Lisp_Max(LispBuiltin *builtin) +/* + max number &rest more-numbers + */ +{ + LispObj *result, *number, *more_numbers; + + more_numbers = ARGUMENT(1); + result = ARGUMENT(0); + + if (CONSP(more_numbers)) { + do { + number = CAR(more_numbers); + if (cmp_object_object(result, number, 1) < 0) + result = number; + more_numbers = CDR(more_numbers); + } while (CONSP(more_numbers)); + } + else { + CHECK_REAL(result); + } + + return (result); +} + +LispObj * +Lisp_Abs(LispBuiltin *builtin) +/* + abs number + */ +{ + LispObj *result, *number; + + result = number = ARGUMENT(0); + + switch (OBJECT_TYPE(number)) { + case LispFixnum_t: + case LispInteger_t: + case LispBignum_t: + case LispDFloat_t: + case LispRatio_t: + case LispBigratio_t: + if (cmp_real_object(&zero, number) > 0) { + n_real real; + + set_real_object(&real, number); + neg_real(&real); + result = make_real_object(&real); + } + break; + case LispComplex_t: { + n_number num; + + set_number_object(&num, number); + abs_number(&num); + result = make_number_object(&num); + } break; + default: + fatal_builtin_object_error(builtin, number, NOT_A_NUMBER); + break; + } + + return (result); +} + +LispObj * +Lisp_Complex(LispBuiltin *builtin) +/* + complex realpart &optional imagpart + */ +{ + LispObj *realpart, *imagpart; + + imagpart = ARGUMENT(1); + realpart = ARGUMENT(0); + + CHECK_REAL(realpart); + + if (imagpart == UNSPEC) + return (realpart); + else { + CHECK_REAL(imagpart); + } + if (!FLOATP(imagpart) && cmp_real_object(&zero, imagpart) == 0) + return (realpart); + + return (COMPLEX(realpart, imagpart)); +} + +LispObj * +Lisp_Complexp(LispBuiltin *builtin) +/* + complexp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (COMPLEXP(object) ? T : NIL); +} + +LispObj * +Lisp_Conjugate(LispBuiltin *builtin) +/* + conjugate number + */ +{ + n_number num; + LispObj *number, *realpart, *imagpart; + + number = ARGUMENT(0); + + CHECK_NUMBER(number); + + if (REALP(number)) + return (number); + + realpart = OCXR(number); + num.complex = 0; + num.real.type = N_FIXNUM; + num.real.data.fixnum = -1; + mul_number_object(&num, OCXI(number)); + imagpart = make_number_object(&num); + + return (COMPLEX(realpart, imagpart)); +} + +LispObj * +Lisp_Decf(LispBuiltin *builtin) +/* + decf place &optional delta + */ +{ + n_number num; + LispObj *place, *delta, *number; + + delta = ARGUMENT(1); + place = ARGUMENT(0); + + if (SYMBOLP(place)) { + number = LispGetVar(place); + if (number == NULL) + LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); + } + else + number = EVAL(place); + + if (delta != UNSPEC) { + LispObj *operand; + + operand = EVAL(delta); + set_number_object(&num, number); + sub_number_object(&num, operand); + number = make_number_object(&num); + } + else { + num.complex = 0; + num.real.type = N_FIXNUM; + num.real.data.fixnum = -1; + add_number_object(&num, number); + number = make_number_object(&num); + } + + if (SYMBOLP(place)) { + CHECK_CONSTANT(place); + LispSetVar(place, number); + } + else { + GC_ENTER(); + + GC_PROTECT(number); + (void)APPLY2(Osetf, place, number); + GC_LEAVE(); + } + + return (number); +} + +LispObj * +Lisp_Denominator(LispBuiltin *builtin) +/* + denominator rational + */ +{ + LispObj *result, *rational; + + rational = ARGUMENT(0); + + switch (OBJECT_TYPE(rational)) { + case LispFixnum_t: + case LispInteger_t: + case LispBignum_t: + result = FIXNUM(1); + break; + case LispRatio_t: + result = INTEGER(OFRD(rational)); + break; + case LispBigratio_t: + if (mpi_fiti(OBRD(rational))) + result = INTEGER(mpi_geti(OBRD(rational))); + else { + mpi *den = XALLOC(mpi); + + mpi_init(den); + mpi_set(den, OBRD(rational)); + result = BIGNUM(den); + } + break; + default: + LispDestroy("%s: %s is not a rational number", + STRFUN(builtin), STROBJ(rational)); + /*NOTREACHED*/ + result = NIL; + } + + return (result); +} + +LispObj * +Lisp_Evenp(LispBuiltin *builtin) +/* + evenp integer + */ +{ + LispObj *result, *integer; + + integer = ARGUMENT(0); + + switch (OBJECT_TYPE(integer)) { + case LispFixnum_t: + result = FIXNUM_VALUE(integer) % 2 ? NIL : T; + break; + case LispInteger_t: + result = INT_VALUE(integer) % 2 ? NIL : T; + break; + case LispBignum_t: + result = mpi_remi(OBI(integer), 2) ? NIL : T; + break; + default: + fatal_builtin_object_error(builtin, integer, NOT_AN_INTEGER); + /*NOTREACHED*/ + result = NIL; + } + + return (result); +} + +/* only one float format */ +LispObj * +Lisp_Float(LispBuiltin *builtin) +/* + float number &optional other + */ +{ + LispObj *number, *other; + + other = ARGUMENT(1); + number = ARGUMENT(0); + + if (other != UNSPEC) { + CHECK_DFLOAT(other); + } + + return (LispFloatCoerce(builtin, number)); +} + +LispObj * +LispFloatCoerce(LispBuiltin *builtin, LispObj *number) +{ + double value; + + switch (OBJECT_TYPE(number)) { + case LispFixnum_t: + value = FIXNUM_VALUE(number); + break; + case LispInteger_t: + value = INT_VALUE(number); + break; + case LispBignum_t: + value = mpi_getd(OBI(number)); + break; + case LispDFloat_t: + return (number); + case LispRatio_t: + value = (double)OFRN(number) / (double)OFRD(number); + break; + case LispBigratio_t: + value = mpr_getd(OBR(number)); + break; + default: + value = 0.0; + fatal_builtin_object_error(builtin, number, NOT_A_REAL_NUMBER); + break; + } + + if (!finite(value)) + fatal_error(FLOATING_POINT_OVERFLOW); + + return (DFLOAT(value)); +} + +LispObj * +Lisp_Floatp(LispBuiltin *builtin) +/* + floatp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (FLOATP(object) ? T : NIL); +} + +LispObj * +Lisp_Gcd(LispBuiltin *builtin) +/* + gcd &rest integers + */ +{ + n_real real; + LispObj *integers, *integer, *operand; + + integers = ARGUMENT(0); + + if (!CONSP(integers)) + return (FIXNUM(0)); + + integer = CAR(integers); + + CHECK_INTEGER(integer); + set_real_object(&real, integer); + integers = CDR(integers); + + for (; CONSP(integers); integers = CDR(integers)) { + operand = CAR(integers); + gcd_real_object(&real, operand); + } + abs_real(&real); + + return (make_real_object(&real)); +} + +LispObj * +Lisp_Imagpart(LispBuiltin *builtin) +/* + imagpart number + */ +{ + LispObj *number; + + number = ARGUMENT(0); + + if (COMPLEXP(number)) + return (OCXI(number)); + else { + CHECK_REAL(number); + } + + return (FIXNUM(0)); +} + +LispObj * +Lisp_Incf(LispBuiltin *builtin) +/* + incf place &optional delta + */ +{ + n_number num; + LispObj *place, *delta, *number; + + delta = ARGUMENT(1); + place = ARGUMENT(0); + + if (SYMBOLP(place)) { + number = LispGetVar(place); + if (number == NULL) + LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); + } + else + number = EVAL(place); + + if (delta != UNSPEC) { + LispObj *operand; + + operand = EVAL(delta); + set_number_object(&num, number); + add_number_object(&num, operand); + number = make_number_object(&num); + } + else { + num.complex = 0; + num.real.type = N_FIXNUM; + num.real.data.fixnum = 1; + add_number_object(&num, number); + number = make_number_object(&num); + } + + if (SYMBOLP(place)) { + CHECK_CONSTANT(place); + LispSetVar(place, number); + } + else { + GC_ENTER(); + + GC_PROTECT(number); + (void)APPLY2(Osetf, place, number); + GC_LEAVE(); + } + + return (number); +} + +LispObj * +Lisp_Integerp(LispBuiltin *builtin) +/* + integerp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (INTEGERP(object) ? T : NIL); +} + +LispObj * +Lisp_Isqrt(LispBuiltin *builtin) +/* + isqrt natural + */ +{ + LispObj *natural, *result; + + natural = ARGUMENT(0); + + if (cmp_object_object(natural, obj_zero, 1) < 0) + goto not_a_natural_number; + + switch (OBJECT_TYPE(natural)) { + case LispFixnum_t: + result = FIXNUM((long)floor(sqrt(FIXNUM_VALUE(natural)))); + break; + case LispInteger_t: + result = INTEGER((long)floor(sqrt(INT_VALUE(natural)))); + break; + case LispBignum_t: { + mpi *bigi; + + bigi = XALLOC(mpi); + mpi_init(bigi); + mpi_sqrt(bigi, OBI(natural)); + if (mpi_fiti(bigi)) { + result = INTEGER(mpi_geti(bigi)); + mpi_clear(bigi); + XFREE(bigi); + } + else + result = BIGNUM(bigi); + } break; + default: + goto not_a_natural_number; + } + + return (result); + +not_a_natural_number: + LispDestroy("%s: %s is not a natural number", + STRFUN(builtin), STROBJ(natural)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +Lisp_Lcm(LispBuiltin *builtin) +/* + lcm &rest integers + */ +{ + n_real real, gcd; + LispObj *integers, *operand; + + integers = ARGUMENT(0); + + if (!CONSP(integers)) + return (FIXNUM(1)); + + operand = CAR(integers); + + CHECK_INTEGER(operand); + set_real_object(&real, operand); + integers = CDR(integers); + + gcd.type = N_FIXNUM; + gcd.data.fixnum = 0; + + for (; CONSP(integers); integers = CDR(integers)) { + operand = CAR(integers); + + if (real.type == N_FIXNUM && real.data.fixnum == 0) + break; + + /* calculate gcd before changing integer */ + clear_real(&gcd); + set_real_real(&gcd, &real); + gcd_real_object(&gcd, operand); + + /* calculate lcm */ + mul_real_object(&real, operand); + div_real_real(&real, &gcd); + } + clear_real(&gcd); + abs_real(&real); + + return (make_real_object(&real)); +} + +LispObj * +Lisp_Logand(LispBuiltin *builtin) +/* + logand &rest integers + */ +{ + n_real real; + + LispObj *integers; + + integers = ARGUMENT(0); + + real.type = N_FIXNUM; + real.data.fixnum = -1; + + for (; CONSP(integers); integers = CDR(integers)) + and_real_object(&real, CAR(integers)); + + return (make_real_object(&real)); +} + +LispObj * +Lisp_Logeqv(LispBuiltin *builtin) +/* + logeqv &rest integers + */ +{ + n_real real; + + LispObj *integers; + + integers = ARGUMENT(0); + + real.type = N_FIXNUM; + real.data.fixnum = -1; + + for (; CONSP(integers); integers = CDR(integers)) + eqv_real_object(&real, CAR(integers)); + + return (make_real_object(&real)); +} + +LispObj * +Lisp_Logior(LispBuiltin *builtin) +/* + logior &rest integers + */ +{ + n_real real; + + LispObj *integers; + + integers = ARGUMENT(0); + + real.type = N_FIXNUM; + real.data.fixnum = 0; + + for (; CONSP(integers); integers = CDR(integers)) + ior_real_object(&real, CAR(integers)); + + return (make_real_object(&real)); +} + +LispObj * +Lisp_Lognot(LispBuiltin *builtin) +/* + lognot integer + */ +{ + n_real real; + + LispObj *integer; + + integer = ARGUMENT(0); + + CHECK_INTEGER(integer); + + set_real_object(&real, integer); + not_real(&real); + + return (make_real_object(&real)); +} + +LispObj * +Lisp_Logxor(LispBuiltin *builtin) +/* + logxor &rest integers + */ +{ + n_real real; + + LispObj *integers; + + integers = ARGUMENT(0); + + real.type = N_FIXNUM; + real.data.fixnum = 0; + + for (; CONSP(integers); integers = CDR(integers)) + xor_real_object(&real, CAR(integers)); + + return (make_real_object(&real)); +} + +LispObj * +Lisp_Minusp(LispBuiltin *builtin) +/* + minusp number + */ +{ + LispObj *number; + + number = ARGUMENT(0); + + CHECK_REAL(number); + + return (cmp_real_object(&zero, number) > 0 ? T : NIL); +} + +LispObj * +Lisp_Mod(LispBuiltin *builtin) +/* + mod number divisor + */ +{ + LispObj *result; + + LispObj *number, *divisor; + + divisor = ARGUMENT(1); + number = ARGUMENT(0); + + if (INTEGERP(number) && INTEGERP(divisor)) { + n_real real; + + set_real_object(&real, number); + mod_real_object(&real, divisor); + result = make_real_object(&real); + } + else { + n_number num; + + set_number_object(&num, number); + divide_number_object(&num, divisor, NDIVIDE_FLOOR, 0); + result = make_real_object(&(num.imag)); + clear_real(&(num.real)); + } + + return (result); +} + +LispObj * +Lisp_Numberp(LispBuiltin *builtin) +/* + numberp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (NUMBERP(object) ? T : NIL); +} + +LispObj * +Lisp_Numerator(LispBuiltin *builtin) +/* + numerator rational + */ +{ + LispObj *result, *rational; + + rational = ARGUMENT(0); + + switch (OBJECT_TYPE(rational)) { + case LispFixnum_t: + case LispInteger_t: + case LispBignum_t: + result = rational; + break; + case LispRatio_t: + result = INTEGER(OFRN(rational)); + break; + case LispBigratio_t: + if (mpi_fiti(OBRN(rational))) + result = INTEGER(mpi_geti(OBRN(rational))); + else { + mpi *num = XALLOC(mpi); + + mpi_init(num); + mpi_set(num, OBRN(rational)); + result = BIGNUM(num); + } + break; + default: + LispDestroy("%s: %s is not a rational number", + STRFUN(builtin), STROBJ(rational)); + /*NOTREACHED*/ + result = NIL; + } + + return (result); +} + +LispObj * +Lisp_Oddp(LispBuiltin *builtin) +/* + oddp integer + */ +{ + LispObj *result, *integer; + + integer = ARGUMENT(0); + + switch (OBJECT_TYPE(integer)) { + case LispFixnum_t: + result = FIXNUM_VALUE(integer) % 2 ? T : NIL; + break; + case LispInteger_t: + result = INT_VALUE(integer) % 2 ? T : NIL; + break; + case LispBignum_t: + result = mpi_remi(OBI(integer), 2) ? T : NIL; + break; + default: + fatal_builtin_object_error(builtin, integer, NOT_AN_INTEGER); + /*NOTREACHED*/ + result = NIL; + } + + return (result); +} + +LispObj * +Lisp_Plusp(LispBuiltin *builtin) +/* + plusp number + */ +{ + LispObj *number; + + number = ARGUMENT(0); + + CHECK_REAL(number); + + return (cmp_real_object(&zero, number) < 0 ? T : NIL); +} + +LispObj * +Lisp_Rational(LispBuiltin *builtin) +/* + rational number + */ +{ + LispObj *number; + + number = ARGUMENT(0); + + if (DFLOATP(number)) { + double numerator = ODF(number); + + if ((long)numerator == numerator) + number = INTEGER(numerator); + else { + n_real real; + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + mpr_setd(bigr, numerator); + real.type = N_BIGRATIO; + real.data.bigratio = bigr; + rbr_canonicalize(&real); + number = make_real_object(&real); + } + } + else { + CHECK_REAL(number); + } + + return (number); +} + +LispObj * +Lisp_Rationalp(LispBuiltin *builtin) +/* + rationalp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (RATIONALP(object) ? T : NIL); +} + +LispObj * +Lisp_Realpart(LispBuiltin *builtin) +/* + realpart number + */ +{ + LispObj *number; + + number = ARGUMENT(0); + + if (COMPLEXP(number)) + return (OCXR(number)); + else { + CHECK_REAL(number); + } + + return (number); +} + +LispObj * +Lisp_Rem(LispBuiltin *builtin) +/* + rem number divisor + */ +{ + LispObj *result; + + LispObj *number, *divisor; + + divisor = ARGUMENT(1); + number = ARGUMENT(0); + + if (INTEGERP(number) && INTEGERP(divisor)) { + n_real real; + + set_real_object(&real, number); + rem_real_object(&real, divisor); + result = make_real_object(&real); + } + else { + n_number num; + + set_number_object(&num, number); + divide_number_object(&num, divisor, NDIVIDE_TRUNC, 0); + result = make_real_object(&(num.imag)); + clear_real(&(num.real)); + } + + return (result); +} + +LispObj * +Lisp_Sqrt(LispBuiltin *builtin) +/* + sqrt number + */ +{ + n_number num; + LispObj *number; + + number = ARGUMENT(0); + + set_number_object(&num, number); + sqrt_number(&num); + + return (make_number_object(&num)); +} + +LispObj * +Lisp_Zerop(LispBuiltin *builtin) +/* + zerop number + */ +{ + LispObj *result, *number; + + number = ARGUMENT(0); + + switch (OBJECT_TYPE(number)) { + case LispFixnum_t: + case LispInteger_t: + case LispBignum_t: + case LispDFloat_t: + case LispRatio_t: + case LispBigratio_t: + result = cmp_real_object(&zero, number) == 0 ? T : NIL; + break; + case LispComplex_t: + result = cmp_real_object(&zero, OCXR(number)) == 0 && + cmp_real_object(&zero, OCXI(number)) == 0 ? T : NIL; + break; + default: + fatal_builtin_object_error(builtin, number, NOT_A_NUMBER); + /*NOTREACHED*/ + result = NIL; + } + + return (result); +} + +static LispObj * +LispDivide(LispBuiltin *builtin, int fun, int flo) +{ + n_number num; + LispObj *number, *divisor; + + divisor = ARGUMENT(1); + number = ARGUMENT(0); + + RETURN_COUNT = 1; + + if (cmp_real_object(&zero, number) == 0) { + if (divisor != NIL) { + CHECK_REAL(divisor); + } + + return (RETURN(0) = obj_zero); + } + + if (divisor == UNSPEC) + divisor = obj_one; + + set_number_object(&num, number); + if (num.complex) + fatal_builtin_object_error(builtin, divisor, NOT_A_REAL_NUMBER); + + divide_number_object(&num, divisor, fun, flo); + RETURN(0) = make_real_object(&(num.imag)); + + return (make_real_object(&(num.real))); +} + +LispObj * +Lisp_Ceiling(LispBuiltin *builtin) +/* + ceiling number &optional divisor + */ +{ + return (LispDivide(builtin, NDIVIDE_CEIL, 0)); +} + +LispObj * +Lisp_Fceiling(LispBuiltin *builtin) +/* + fceiling number &optional divisor + */ +{ + return (LispDivide(builtin, NDIVIDE_CEIL, 1)); +} + +LispObj * +Lisp_Floor(LispBuiltin *builtin) +/* + floor number &optional divisor + */ +{ + return (LispDivide(builtin, NDIVIDE_FLOOR, 0)); +} + +LispObj * +Lisp_Ffloor(LispBuiltin *builtin) +/* + ffloor number &optional divisor + */ +{ + return (LispDivide(builtin, NDIVIDE_FLOOR, 1)); +} + +LispObj * +Lisp_Round(LispBuiltin *builtin) +/* + round number &optional divisor + */ +{ + return (LispDivide(builtin, NDIVIDE_ROUND, 0)); +} + +LispObj * +Lisp_Fround(LispBuiltin *builtin) +/* + fround number &optional divisor + */ +{ + return (LispDivide(builtin, NDIVIDE_ROUND, 1)); +} + +LispObj * +Lisp_Truncate(LispBuiltin *builtin) +/* + truncate number &optional divisor + */ +{ + return (LispDivide(builtin, NDIVIDE_TRUNC, 0)); +} + +LispObj * +Lisp_Ftruncate(LispBuiltin *builtin) +/* + ftruncate number &optional divisor + */ +{ + return (LispDivide(builtin, NDIVIDE_TRUNC, 1)); +} diff --git a/lisp/math.h b/lisp/math.h new file mode 100644 index 0000000..8297d43 --- /dev/null +++ b/lisp/math.h @@ -0,0 +1,100 @@ +/* + * 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/math.h,v 1.6 2002/11/08 08:00:57 paulo Exp $ */ + +#ifndef Lisp_math_h +#define Lisp_math_h + +#include "internal.h" +#include "mp.h" + +void LispMathInit(void); +LispObj *LispFloatCoerce(LispBuiltin*, LispObj*); + +LispObj *Lisp_Mul(LispBuiltin*); +LispObj *Lisp_Plus(LispBuiltin*); +LispObj *Lisp_Minus(LispBuiltin*); +LispObj *Lisp_Div(LispBuiltin*); +LispObj *Lisp_OnePlus(LispBuiltin*); +LispObj *Lisp_OneMinus(LispBuiltin*); +LispObj *Lisp_Less(LispBuiltin*); +LispObj *Lisp_LessEqual(LispBuiltin*); +LispObj *Lisp_Equal_(LispBuiltin*); +LispObj *Lisp_Greater(LispBuiltin*); +LispObj *Lisp_GreaterEqual(LispBuiltin*); +LispObj *Lisp_NotEqual(LispBuiltin*); +LispObj *Lisp_Max(LispBuiltin*); +LispObj *Lisp_Min(LispBuiltin*); +LispObj *Lisp_Mod(LispBuiltin*); +LispObj *Lisp_Abs(LispBuiltin*); +LispObj *Lisp_Complex(LispBuiltin*); +LispObj *Lisp_Complexp(LispBuiltin*); +LispObj *Lisp_Conjugate(LispBuiltin*); +LispObj *Lisp_Decf(LispBuiltin*); +LispObj *Lisp_Denominator(LispBuiltin*); +LispObj *Lisp_Evenp(LispBuiltin*); +LispObj *Lisp_Float(LispBuiltin*); +LispObj *Lisp_Floatp(LispBuiltin*); +LispObj *Lisp_Gcd(LispBuiltin*); +LispObj *Lisp_Imagpart(LispBuiltin*); +LispObj *Lisp_Incf(LispBuiltin*); +LispObj *Lisp_Integerp(LispBuiltin*); +LispObj *Lisp_Isqrt(LispBuiltin*); +LispObj *Lisp_Lcm(LispBuiltin*); +LispObj *Lisp_Logand(LispBuiltin*); +LispObj *Lisp_Logeqv(LispBuiltin*); +LispObj *Lisp_Logior(LispBuiltin*); +LispObj *Lisp_Lognot(LispBuiltin*); +LispObj *Lisp_Logxor(LispBuiltin*); +LispObj *Lisp_Minusp(LispBuiltin*); +LispObj *Lisp_Numberp(LispBuiltin*); +LispObj *Lisp_Numerator(LispBuiltin*); +LispObj *Lisp_Oddp(LispBuiltin*); +LispObj *Lisp_Plusp(LispBuiltin*); +LispObj *Lisp_Rational(LispBuiltin*); +#if 0 +LispObj *Lisp_Rationalize(LispBuiltin*); +#endif +LispObj *Lisp_Rationalp(LispBuiltin*); +LispObj *Lisp_Realpart(LispBuiltin*); +LispObj *Lisp_Rem(LispBuiltin*); +LispObj *Lisp_Sqrt(LispBuiltin*); +LispObj *Lisp_Zerop(LispBuiltin*); +LispObj *Lisp_Ceiling(LispBuiltin*); +LispObj *Lisp_Fceiling(LispBuiltin*); +LispObj *Lisp_Floor(LispBuiltin*); +LispObj *Lisp_Ffloor(LispBuiltin*); +LispObj *Lisp_Round(LispBuiltin*); +LispObj *Lisp_Fround(LispBuiltin*); +LispObj *Lisp_Truncate(LispBuiltin*); +LispObj *Lisp_Ftruncate(LispBuiltin*); + + +#endif /* Lisp_math_h */ diff --git a/lisp/mathimp.c b/lisp/mathimp.c new file mode 100644 index 0000000..ccda576 --- /dev/null +++ b/lisp/mathimp.c @@ -0,0 +1,5225 @@ +/* + * Copyright (c) 2002 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/mathimp.c,v 1.14 2003/01/30 02:46:25 paulo Exp $ */ + + +/* + * Defines + */ +#ifdef __GNUC__ +#define CONST __attribute__ ((__const__)) +#else +#define CONST /**/ +#endif + +/* mask for checking overflow on long operations */ +#ifdef LONG64 +#define FI_MASK 0x4000000000000000L +#define LONGSBITS 63 +#else +#define FI_MASK 0x40000000L +#define LONGSBITS 31 +#endif + +#define N_FIXNUM 1 +#define N_BIGNUM 2 +#define N_FLONUM 3 +#define N_FIXRATIO 4 +#define N_BIGRATIO 5 + +#define NOP_ADD 1 +#define NOP_SUB 2 +#define NOP_MUL 3 +#define NOP_DIV 4 + +#define NDIVIDE_CEIL 1 +#define NDIVIDE_FLOOR 2 +#define NDIVIDE_ROUND 3 +#define NDIVIDE_TRUNC 4 + +/* real part from number */ +#define NREAL(num) &((num)->real) +#define NRTYPE(num) (num)->real.type +#define NRFI(num) (num)->real.data.fixnum +#define NRBI(num) (num)->real.data.bignum +#define NRFF(num) (num)->real.data.flonum +#define NRFRN(Num) (Num)->real.data.fixratio.num +#define NRFRD(num) (num)->real.data.fixratio.den +#define NRBR(num) (num)->real.data.bigratio +#define NRBRN(num) mpr_num(NRBR(num)) +#define NRBRD(num) mpr_den(NRBR(num)) + +#define NRCLEAR_BI(num) mpi_clear(NRBI(num)); XFREE(NRBI(num)) +#define NRCLEAR_BR(num) mpr_clear(NRBR(num)); XFREE(NRBR(num)) + +/* imag part from number */ +#define NIMAG(num) &((num)->imag) +#define NITYPE(num) (num)->imag.type +#define NIFI(num) (num)->imag.data.fixnum +#define NIBI(num) (num)->imag.data.bignum +#define NIFF(num) (num)->imag.data.flonum +#define NIFRN(Num) (Num)->imag.data.fixratio.num +#define NIFRD(num) (num)->imag.data.fixratio.den +#define NIBR(num) (num)->imag.data.bigratio +#define NIBRN(obj) mpr_num(NIBR(obj)) +#define NIBRD(obj) mpr_den(NIBR(obj)) + +/* real number fields */ +#define RTYPE(real) (real)->type +#define RFI(real) (real)->data.fixnum +#define RBI(real) (real)->data.bignum +#define RFF(real) (real)->data.flonum +#define RFRN(real) (real)->data.fixratio.num +#define RFRD(real) (real)->data.fixratio.den +#define RBR(real) (real)->data.bigratio +#define RBRN(real) mpr_num(RBR(real)) +#define RBRD(real) mpr_den(RBR(real)) + +#define RINTEGERP(real) \ + (RTYPE(real) == N_FIXNUM || RTYPE(real) == N_BIGNUM) + +#define RCLEAR_BI(real) mpi_clear(RBI(real)); XFREE(RBI(real)) +#define RCLEAR_BR(real) mpr_clear(RBR(real)); XFREE(RBR(real)) + +/* numeric value from lisp object */ +#define OFI(object) FIXNUM_VALUE(object) +#define OII(object) INT_VALUE(object) +#define OBI(object) (object)->data.mp.integer +#define ODF(object) DFLOAT_VALUE(object) +#define OFRN(object) (object)->data.ratio.numerator +#define OFRD(object) (object)->data.ratio.denominator +#define OBR(object) (object)->data.mp.ratio +#define OBRN(object) mpr_num(OBR(object)) +#define OBRD(object) mpr_den(OBR(object)) +#define OCXR(object) (object)->data.complex.real +#define OCXI(object) (object)->data.complex.imag + +#define XALLOC(type) LispMalloc(sizeof(type)) +#define XFREE(ptr) LispFree(ptr) + + +/* + * Types + */ +typedef struct _n_real { + char type; + union { + long fixnum; + mpi *bignum; + double flonum; + struct { + long num; + long den; + } fixratio; + mpr *bigratio; + } data; +} n_real; + +typedef struct _n_number { + char complex; + n_real real; + n_real imag; +} n_number; + + +/* + * Prototypes + */ +static void number_init(void); +static LispObj *number_pi(void); + +static void set_real_real(n_real*, n_real*); +static void set_real_object(n_real*, LispObj*); +static void set_number_object(n_number*, LispObj*); +static void clear_real(n_real*); +static void clear_number(n_number*); + +static LispObj *make_real_object(n_real*); +static LispObj *make_number_object(n_number*); + +static void fatal_error(int); +static void fatal_object_error(LispObj*, int); +static void fatal_builtin_object_error(LispBuiltin*, LispObj*, int); + +static double bi_getd(mpi*); +static double br_getd(mpr*); + +/* add */ +static void add_real_object(n_real*, LispObj*); +static void add_number_object(n_number*, LispObj*); + +/* sub */ +static void sub_real_object(n_real*, LispObj*); +static void sub_number_object(n_number*, LispObj*); + +/* mul */ +static void mul_real_object(n_real*, LispObj*); +static void mul_number_object(n_number*, LispObj*); + +/* div */ +static void div_real_object(n_real*, LispObj*); +static void div_number_object(n_number*, LispObj*); + +/* compare */ +static int cmp_real_real(n_real*, n_real*); +static int cmp_real_object(n_real*, LispObj*); +#if 0 /* not used */ +static int cmp_number_object(n_number*, LispObj*); +#endif +static int cmp_object_object(LispObj*, LispObj*, int); + +/* fixnum */ +static INLINE int fi_fi_add_overflow(long, long) CONST; +static INLINE int fi_fi_sub_overflow(long, long) CONST; +static INLINE int fi_fi_mul_overflow(long, long) CONST; + +/* bignum */ +static void rbi_canonicalize(n_real*); + +/* ratio */ +static void rfr_canonicalize(n_real*); +static void rbr_canonicalize(n_real*); + +/* complex */ +static void ncx_canonicalize(n_number*); + +/* abs */ +static void abs_real(n_real*); +static void abs_number(n_number*); +static void nabs_cx(n_number*); +static INLINE void rabs_fi(n_real*); +static INLINE void rabs_bi(n_real*); +static INLINE void rabs_ff(n_real*); +static INLINE void rabs_fr(n_real*); +static INLINE void rabs_br(n_real*); + +/* neg */ +static void neg_real(n_real*); +static void neg_number(n_number*); +static void rneg_fi(n_real*); +static INLINE void rneg_bi(n_real*); +static INLINE void rneg_ff(n_real*); +static INLINE void rneg_fr(n_real*); +static INLINE void rneg_br(n_real*); + +/* sqrt */ +static void sqrt_real(n_real*); +static void sqrt_number(n_number*); +static void rsqrt_xi(n_real*); +static void rsqrt_xr(n_real*); +static void rsqrt_ff(n_real*); +static void nsqrt_cx(n_number*); +static void nsqrt_xi(n_number*); +static void nsqrt_ff(n_number*); +static void nsqrt_xr(n_number*); + +/* mod */ +static void mod_real_real(n_real*, n_real*); +static void mod_real_object(n_real*, LispObj*); +static void rmod_fi_fi(n_real*, long); +static void rmod_fi_bi(n_real*, mpi*); +static void rmod_bi_fi(n_real*, long); +static void rmod_bi_bi(n_real*, mpi*); + +/* rem */ +static void rem_real_object(n_real*, LispObj*); +static void rrem_fi_fi(n_real*, long); +static void rrem_fi_bi(n_real*, mpi*); +static void rrem_bi_fi(n_real*, long); +static void rrem_bi_bi(n_real*, mpi*); + +/* gcd */ +static void gcd_real_object(n_real*, LispObj*); + +/* and */ +static void and_real_object(n_real*, LispObj*); + +/* eqv */ +static void eqv_real_object(n_real*, LispObj*); + +/* ior */ +static void ior_real_object(n_real*, LispObj*); + +/* not */ +static void not_real(n_real*); + +/* xor */ +static void xor_real_object(n_real*, LispObj*); + +/* divide */ +static void divide_number_object(n_number*, LispObj*, int, int); +static void ndivide_xi_xi(n_number*, LispObj*, int, int); +static void ndivide_flonum(n_number*, double, double, int, int); +static void ndivide_xi_xr(n_number*, LispObj*, int, int); +static void ndivide_xr_xi(n_number*, LispObj*, int, int); +static void ndivide_xr_xr(n_number*, LispObj*, int, int); + +/* real complex */ +static void nadd_re_cx(n_number*, LispObj*); +static void nsub_re_cx(n_number*, LispObj*); +static void nmul_re_cx(n_number*, LispObj*); +static void ndiv_re_cx(n_number*, LispObj*); + +/* complex real */ +static void nadd_cx_re(n_number*, LispObj*); +static void nsub_cx_re(n_number*, LispObj*); +static void nmul_cx_re(n_number*, LispObj*); +static void ndiv_cx_re(n_number*, LispObj*); + +/* complex complex */ +static void nadd_cx_cx(n_number*, LispObj*); +static void nsub_cx_cx(n_number*, LispObj*); +static void nmul_cx_cx(n_number*, LispObj*); +static void ndiv_cx_cx(n_number*, LispObj*); +static int cmp_cx_cx(LispObj*, LispObj*); + +/* flonum flonum */ +static void radd_flonum(n_real*, double, double); +static void rsub_flonum(n_real*, double, double); +static void rmul_flonum(n_real*, double, double); +static void rdiv_flonum(n_real*, double, double); +static int cmp_flonum(double, double); + +/* fixnum fixnum */ +static void rop_fi_fi_bi(n_real*, long, int); +static INLINE void radd_fi_fi(n_real*, long); +static INLINE void rsub_fi_fi(n_real*, long); +static INLINE void rmul_fi_fi(n_real*, long); +static INLINE void rdiv_fi_fi(n_real*, long); +static INLINE int cmp_fi_fi(long, long); +static void ndivide_fi_fi(n_number*, long, int, int); + +/* fixnum bignum */ +static void rop_fi_bi_xi(n_real*, mpi*, int); +static INLINE void radd_fi_bi(n_real*, mpi*); +static INLINE void rsub_fi_bi(n_real*, mpi*); +static INLINE void rmul_fi_bi(n_real*, mpi*); +static void rdiv_fi_bi(n_real*, mpi*); +static INLINE int cmp_fi_bi(long, mpi*); + +/* fixnum fixratio */ +static void rop_fi_fr_as_xr(n_real*, long, long, int); +static void rop_fi_fr_md_xr(n_real*, long, long, int); +static INLINE void radd_fi_fr(n_real*, long, long); +static INLINE void rsub_fi_fr(n_real*, long, long); +static INLINE void rmul_fi_fr(n_real*, long, long); +static INLINE void rdiv_fi_fr(n_real*, long, long); +static INLINE int cmp_fi_fr(long, long, long); + +/* fixnum bigratio */ +static void rop_fi_br_as_xr(n_real*, mpr*, int); +static void rop_fi_br_md_xr(n_real*, mpr*, int); +static INLINE void radd_fi_br(n_real*, mpr*); +static INLINE void rsub_fi_br(n_real*, mpr*); +static INLINE void rmul_fi_br(n_real*, mpr*); +static INLINE void rdiv_fi_br(n_real*, mpr*); +static INLINE int cmp_fi_br(long, mpr*); + +/* bignum fixnum */ +static INLINE void radd_bi_fi(n_real*, long); +static INLINE void rsub_bi_fi(n_real*, long); +static INLINE void rmul_bi_fi(n_real*, long); +static void rdiv_bi_fi(n_real*, long); +static INLINE int cmp_bi_fi(mpi*, long); + +/* bignum bignum */ +static INLINE void radd_bi_bi(n_real*, mpi*); +static INLINE void rsub_bi_bi(n_real*, mpi*); +static INLINE void rmul_bi_bi(n_real*, mpi*); +static void rdiv_bi_bi(n_real*, mpi*); +static INLINE int cmp_bi_bi(mpi*, mpi*); + +/* bignum fixratio */ +static void rop_bi_fr_as_xr(n_real*, long, long, int); +static void rop_bi_fr_md_xr(n_real*, long, long, int); +static INLINE void radd_bi_fr(n_real*, long, long); +static INLINE void rsub_bi_fr(n_real*, long, long); +static INLINE void rmul_bi_fr(n_real*, long, long); +static INLINE void rdiv_bi_fr(n_real*, long, long); +static int cmp_bi_fr(mpi*, long, long); + +/* bignum bigratio */ +static void rop_bi_br_as_xr(n_real*, mpr*, int); +static void rop_bi_br_md_xr(n_real*, mpr*, int); +static INLINE void radd_bi_br(n_real*, mpr*); +static INLINE void rsub_bi_br(n_real*, mpr*); +static INLINE void rmul_bi_br(n_real*, mpr*); +static INLINE void rdiv_bi_br(n_real*, mpr*); +static int cmp_bi_br(mpi*, mpr*); + +/* fixratio fixnum */ +static void rop_fr_fi_as_xr(n_real*, long, int); +static void rop_fr_fi_md_xr(n_real*, long, int); +static INLINE void radd_fr_fi(n_real*, long); +static INLINE void rsub_fr_fi(n_real*, long); +static INLINE void rmul_fr_fi(n_real*, long); +static INLINE void rdiv_fr_fi(n_real*, long); +static INLINE int cmp_fr_fi(long, long, long); + +/* fixratio bignum */ +static void rop_fr_bi_as_xr(n_real*, mpi*, int); +static void rop_fr_bi_md_xr(n_real*, mpi*, int); +static INLINE void radd_fr_bi(n_real*, mpi*); +static INLINE void rsub_fr_bi(n_real*, mpi*); +static INLINE void rmul_fr_bi(n_real*, mpi*); +static INLINE void rdiv_fr_bi(n_real*, mpi*); +static int cmp_fr_bi(long, long, mpi*); + +/* fixratio fixratio */ +static void rop_fr_fr_as_xr(n_real*, long, long, int); +static void rop_fr_fr_md_xr(n_real*, long, long, int); +static INLINE void radd_fr_fr(n_real*, long, long); +static INLINE void rsub_fr_fr(n_real*, long, long); +static INLINE void rmul_fr_fr(n_real*, long, long); +static INLINE void rdiv_fr_fr(n_real*, long, long); +static INLINE int cmp_fr_fr(long, long, long, long); + +/* fixratio bigratio */ +static void rop_fr_br_asmd_xr(n_real*, mpr*, int); +static INLINE void radd_fr_br(n_real*, mpr*); +static INLINE void rsub_fr_br(n_real*, mpr*); +static INLINE void rmul_fr_br(n_real*, mpr*); +static INLINE void rdiv_fr_br(n_real*, mpr*); +static int cmp_fr_br(long, long, mpr*); + +/* bigratio fixnum */ +static void rop_br_fi_asmd_xr(n_real*, long, int); +static INLINE void radd_br_fi(n_real*, long); +static INLINE void rsub_br_fi(n_real*, long); +static INLINE void rmul_br_fi(n_real*, long); +static INLINE void rdiv_br_fi(n_real*, long); +static int cmp_br_fi(mpr*, long); + +/* bigratio bignum */ +static void rop_br_bi_as_xr(n_real*, mpi*, int); +static INLINE void radd_br_bi(n_real*, mpi*); +static INLINE void rsub_br_bi(n_real*, mpi*); +static INLINE void rmul_br_bi(n_real*, mpi*); +static INLINE void rdiv_br_bi(n_real*, mpi*); +static int cmp_br_bi(mpr*, mpi*); + +/* bigratio fixratio */ +static void rop_br_fr_asmd_xr(n_real*, long, long, int); +static INLINE void radd_br_fr(n_real*, long, long); +static INLINE void rsub_br_fr(n_real*, long, long); +static INLINE void rmul_br_fr(n_real*, long, long); +static INLINE void rdiv_br_fr(n_real*, long, long); +static int cmp_br_fr(mpr*, long, long); + +/* bigratio bigratio */ +static INLINE void radd_br_br(n_real*, mpr*); +static INLINE void rsub_br_br(n_real*, mpr*); +static INLINE void rmul_br_br(n_real*, mpr*); +static INLINE void rdiv_br_br(n_real*, mpr*); +static INLINE int cmp_br_br(mpr*, mpr*); + +/* + * Initialization + */ +static n_real zero, one, two; + +static char *fatal_error_strings[] = { +#define DIVIDE_BY_ZERO 0 + "divide by zero", +#define FLOATING_POINT_OVERFLOW 1 + "floating point overflow", +#define FLOATING_POINT_EXCEPTION 2 + "floating point exception" +}; + +static char *fatal_object_error_strings[] = { +#define NOT_A_NUMBER 0 + "is not a number", +#define NOT_A_REAL_NUMBER 1 + "is not a real number", +#define NOT_AN_INTEGER 2 + "is not an integer" +}; + +/* + * Implementation + */ +static void +fatal_error(int num) +{ + LispDestroy(fatal_error_strings[num]); +} + +static void +fatal_object_error(LispObj *obj, int num) +{ + LispDestroy("%s %s", STROBJ(obj), fatal_object_error_strings[num]); +} + +static void +fatal_builtin_object_error(LispBuiltin *builtin, LispObj *obj, int num) +{ + LispDestroy("%s: %s %s", STRFUN(builtin), STROBJ(obj), + fatal_object_error_strings[num]); +} + +static void +number_init(void) +{ + zero.type = one.type = two.type = N_FIXNUM; + zero.data.fixnum = 0; + one.data.fixnum = 1; + two.data.fixnum = 2; +} + +static double +bi_getd(mpi *bignum) +{ + double value = mpi_getd(bignum); + + if (!finite(value)) + fatal_error(FLOATING_POINT_EXCEPTION); + + return (value); +} + +static double +br_getd(mpr *bigratio) +{ + double value = mpr_getd(bigratio); + + if (!finite(value)) + fatal_error(FLOATING_POINT_EXCEPTION); + + return (value); +} + +static LispObj * +number_pi(void) +{ + LispObj *result; +#ifndef M_PI +#define M_PI 3.14159265358979323846 +#endif + result = DFLOAT(M_PI); + + return (result); +} + +static void +set_real_real(n_real *real, n_real *val) +{ + switch (RTYPE(real) = RTYPE(val)) { + case N_FIXNUM: + RFI(real) = RFI(val); + break; + case N_BIGNUM: + RBI(real) = XALLOC(mpi); + mpi_init(RBI(real)); + mpi_set(RBI(real), RBI(val)); + break; + case N_FLONUM: + RFF(real) = RFF(val); + break; + case N_FIXRATIO: + RFRN(real) = RFRN(val); + RFRD(real) = RFRD(val); + break; + case N_BIGRATIO: + RBR(real) = XALLOC(mpr); + mpr_init(RBR(real)); + mpr_set(RBR(real), RBR(val)); + break; + } +} + +static void +set_real_object(n_real *real, LispObj *obj) +{ + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + RTYPE(real) = N_FIXNUM; + RFI(real) = OFI(obj); + break; + case LispInteger_t: + RTYPE(real) = N_FIXNUM; + RFI(real) = OII(obj); + break; + case LispBignum_t: + RTYPE(real) = N_BIGNUM; + RBI(real) = XALLOC(mpi); + mpi_init(RBI(real)); + mpi_set(RBI(real), OBI(obj)); + break; + case LispDFloat_t: + RTYPE(real) = N_FLONUM; + RFF(real) = ODF(obj); + break; + case LispRatio_t: + RTYPE(real) = N_FIXRATIO; + RFRN(real) = OFRN(obj); + RFRD(real) = OFRD(obj); + break; + case LispBigratio_t: + RTYPE(real) = N_BIGRATIO; + RBR(real) = XALLOC(mpr); + mpr_init(RBR(real)); + mpr_set(RBR(real), OBR(obj)); + break; + default: + fatal_object_error(obj, NOT_A_REAL_NUMBER); + break; + } +} + +static void +set_number_object(n_number *num, LispObj *obj) +{ + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + num->complex = 0; + NRTYPE(num) = N_FIXNUM; + NRFI(num) = OFI(obj); + break; + case LispInteger_t: + num->complex = 0; + NRTYPE(num) = N_FIXNUM; + NRFI(num) = OII(obj); + break; + case LispBignum_t: + num->complex = 0; + NRTYPE(num) = N_BIGNUM; + NRBI(num) = XALLOC(mpi); + mpi_init(NRBI(num)); + mpi_set(NRBI(num), OBI(obj)); + break; + case LispDFloat_t: + num->complex = 0; + NRTYPE(num) = N_FLONUM; + NRFF(num) = ODF(obj); + break; + case LispRatio_t: + num->complex = 0; + NRTYPE(num) = N_FIXRATIO; + NRFRN(num) = OFRN(obj); + NRFRD(num) = OFRD(obj); + break; + case LispBigratio_t: + num->complex = 0; + NRTYPE(num) = N_BIGRATIO; + NRBR(num) = XALLOC(mpr); + mpr_init(NRBR(num)); + mpr_set(NRBR(num), OBR(obj)); + break; + case LispComplex_t: + num->complex = 1; + set_real_object(NREAL(num), OCXR(obj)); + set_real_object(NIMAG(num), OCXI(obj)); + break; + default: + fatal_object_error(obj, NOT_A_NUMBER); + break; + } +} + +static void +clear_real(n_real *real) +{ + if (RTYPE(real) == N_BIGNUM) { + mpi_clear(RBI(real)); + XFREE(RBI(real)); + } + else if (RTYPE(real) == N_BIGRATIO) { + mpr_clear(RBR(real)); + XFREE(RBR(real)); + } +} + +static void +clear_number(n_number *num) +{ + clear_real(NREAL(num)); + if (num->complex) + clear_real(NIMAG(num)); +} + +static LispObj * +make_real_object(n_real *real) +{ + LispObj *obj; + + switch (RTYPE(real)) { + case N_FIXNUM: + if (RFI(real) > MOST_POSITIVE_FIXNUM || + RFI(real) < MOST_NEGATIVE_FIXNUM) { + obj = LispNew(NIL, NIL); + obj->type = LispInteger_t; + OII(obj) = RFI(real); + } + else + obj = FIXNUM(RFI(real)); + break; + case N_BIGNUM: + obj = BIGNUM(RBI(real)); + break; + case N_FLONUM: + obj = DFLOAT(RFF(real)); + break; + case N_FIXRATIO: + obj = LispNew(NIL, NIL); + obj->type = LispRatio_t; + OFRN(obj) = RFRN(real); + OFRD(obj) = RFRD(real); + break; + case N_BIGRATIO: + obj = BIGRATIO(RBR(real)); + break; + default: + obj = NIL; + break; + } + + return (obj); +} + +static LispObj * +make_number_object(n_number *num) +{ + LispObj *obj; + + if (num->complex) { + GC_ENTER(); + + obj = LispNew(NIL, NIL); + GC_PROTECT(obj); + OCXI(obj) = NIL; + obj->type = LispComplex_t; + OCXR(obj) = make_real_object(NREAL(num)); + OCXI(obj) = make_real_object(NIMAG(num)); + GC_LEAVE(); + } + else { + switch (NRTYPE(num)) { + case N_FIXNUM: + if (NRFI(num) > MOST_POSITIVE_FIXNUM || + NRFI(num) < MOST_NEGATIVE_FIXNUM) { + obj = LispNew(NIL, NIL); + obj->type = LispInteger_t; + OII(obj) = NRFI(num); + } + else + obj = FIXNUM(NRFI(num)); + break; + case N_BIGNUM: + obj = BIGNUM(NRBI(num)); + break; + case N_FLONUM: + obj = DFLOAT(NRFF(num)); + break; + case N_FIXRATIO: + obj = LispNew(NIL, NIL); + obj->type = LispRatio_t; + OFRN(obj) = NRFRN(num); + OFRD(obj) = NRFRD(num); + break; + case N_BIGRATIO: + obj = BIGRATIO(NRBR(num)); + break; + default: + obj = NIL; + break; + } + } + + return (obj); +} + +#define DEFOP_REAL_REAL(OP) \ +OP##_real_real(n_real *real, n_real *val) \ +{ \ + switch (RTYPE(real)) { \ + case N_FIXNUM: \ + switch (RTYPE(val)) { \ + case N_FIXNUM: \ + r##OP##_fi_fi(real, RFI(val)); \ + break; \ + case N_BIGNUM: \ + r##OP##_fi_bi(real, RBI(val)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, (double)RFI(real), RFF(val)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fi_fr(real, RFRN(val), RFRD(val)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_fi_br(real, RBR(val)); \ + break; \ + } \ + break; \ + case N_BIGNUM: \ + switch (RTYPE(val)) { \ + case N_FIXNUM: \ + r##OP##_bi_fi(real, RFI(val)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_bi(real, RBI(val)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, bi_getd(RBI(real)), RFF(val)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_bi_fr(real, RFRN(val), RFRD(val)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_bi_br(real, RBR(val)); \ + break; \ + } \ + break; \ + case N_FLONUM: \ + switch (RTYPE(val)) { \ + case N_FIXNUM: \ + r##OP##_flonum(real, RFF(real), (double)RFI(val)); \ + break; \ + case N_BIGNUM: \ + r##OP##_flonum(real, RFF(real), bi_getd(RBI(val))); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, RFF(real), RFF(val)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_flonum(real, RFF(real), \ + (double)RFRN(val) / (double)RFRD(val));\ + break; \ + case N_BIGRATIO: \ + r##OP##_flonum(real, RFF(real), br_getd(RBR(val))); \ + break; \ + } \ + break; \ + case N_FIXRATIO: \ + switch (RTYPE(val)) { \ + case N_FIXNUM: \ + r##OP##_fr_fi(real, RFI(val)); \ + break; \ + case N_BIGNUM: \ + r##OP##_fr_bi(real, RBI(val)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, \ + (double)RFRN(real) / (double)RFRD(real),\ + RFF(val)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_fr(real, RFRN(val), RFRD(val)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_fr_br(real, RBR(val)); \ + break; \ + } \ + break; \ + case N_BIGRATIO: \ + switch (RTYPE(val)) { \ + case N_FIXNUM: \ + r##OP##_br_fi(real, RFI(val)); \ + break; \ + case N_BIGNUM: \ + r##OP##_br_bi(real, RBI(val)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, br_getd(RBR(real)), RFF(val)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_br_fr(real, RFRN(val), RFRD(val)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_br(real, RBR(val)); \ + break; \ + } \ + break; \ + } \ +} + +static void +DEFOP_REAL_REAL(add) + +static void +DEFOP_REAL_REAL(sub) + +static void +DEFOP_REAL_REAL(div) + +static void +DEFOP_REAL_REAL(mul) + + +#define DEFOP_REAL_OBJECT(OP) \ +OP##_real_object(n_real *real, LispObj *obj) \ +{ \ + switch (OBJECT_TYPE(obj)) { \ + case LispFixnum_t: \ + switch (RTYPE(real)) { \ + case N_FIXNUM: \ + r##OP##_fi_fi(real, OFI(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_fi(real, OFI(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, RFF(real), (double)OFI(obj)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_fi(real, OFI(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_fi(real, OFI(obj)); \ + break; \ + } \ + break; \ + case LispInteger_t: \ + switch (RTYPE(real)) { \ + case N_FIXNUM: \ + r##OP##_fi_fi(real, OII(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_fi(real, OII(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, RFF(real), (double)OII(obj)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_fi(real, OII(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_fi(real, OII(obj)); \ + break; \ + } \ + break; \ + case LispBignum_t: \ + switch (RTYPE(real)) { \ + case N_FIXNUM: \ + r##OP##_fi_bi(real, OBI(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_bi(real, OBI(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, RFF(real), bi_getd(OBI(obj))); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_bi(real, OBI(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_bi(real, OBI(obj)); \ + break; \ + } \ + break; \ + case LispDFloat_t: \ + switch (RTYPE(real)) { \ + case N_FIXNUM: \ + r##OP##_flonum(real, (double)RFI(real), ODF(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_flonum(real, bi_getd(RBI(real)), ODF(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, RFF(real), ODF(obj)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_flonum(real, \ + (double)RFRN(real) / (double)RFRD(real),\ + ODF(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_flonum(real, br_getd(RBR(real)), ODF(obj)); \ + break; \ + } \ + break; \ + case LispRatio_t: \ + switch (RTYPE(real)) { \ + case N_FIXNUM: \ + r##OP##_fi_fr(real, OFRN(obj), OFRD(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_fr(real, OFRN(obj), OFRD(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, RFF(real), \ + (double)OFRN(obj) / (double)OFRD(obj)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_fr(real, OFRN(obj), OFRD(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_fr(real, OFRN(obj), OFRD(obj)); \ + break; \ + } \ + break; \ + case LispBigratio_t: \ + switch (RTYPE(real)) { \ + case N_FIXNUM: \ + r##OP##_fi_br(real, OBR(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_br(real, OBR(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(real, RFF(real), br_getd(OBR(obj))); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_br(real, OBR(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_br(real, OBR(obj)); \ + break; \ + } \ + break; \ + default: \ + fatal_object_error(obj, NOT_A_REAL_NUMBER); \ + break; \ + } \ +} + +static void +DEFOP_REAL_OBJECT(add) + +static void +DEFOP_REAL_OBJECT(sub) + +static void +DEFOP_REAL_OBJECT(div) + +static void +DEFOP_REAL_OBJECT(mul) + + +#define DEFOP_NUMBER_OBJECT(OP) \ +OP##_number_object(n_number *num, LispObj *obj) \ +{ \ + if (num->complex) { \ + switch (OBJECT_TYPE(obj)) { \ + case LispFixnum_t: \ + case LispInteger_t: \ + case LispBignum_t: \ + case LispDFloat_t: \ + case LispRatio_t: \ + case LispBigratio_t: \ + n##OP##_cx_re(num, obj); \ + break; \ + case LispComplex_t: \ + n##OP##_cx_cx(num, obj); \ + break; \ + default: \ + fatal_object_error(obj, NOT_A_NUMBER); \ + break; \ + } \ + } \ + else { \ + switch (OBJECT_TYPE(obj)) { \ + case LispFixnum_t: \ + switch (NRTYPE(num)) { \ + case N_FIXNUM: \ + r##OP##_fi_fi(NREAL(num), OFI(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_fi(NREAL(num), OFI(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(NREAL(num), NRFF(num), \ + (double)OFI(obj)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_fi(NREAL(num), OFI(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_fi(NREAL(num), OFI(obj)); \ + break; \ + } \ + break; \ + case LispInteger_t: \ + switch (NRTYPE(num)) { \ + case N_FIXNUM: \ + r##OP##_fi_fi(NREAL(num), OII(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_fi(NREAL(num), OII(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(NREAL(num), NRFF(num), \ + (double)OII(obj)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_fi(NREAL(num), OII(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_fi(NREAL(num), OII(obj)); \ + break; \ + } \ + break; \ + case LispBignum_t: \ + switch (NRTYPE(num)) { \ + case N_FIXNUM: \ + r##OP##_fi_bi(NREAL(num), OBI(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_bi(NREAL(num), OBI(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(NREAL(num), NRFF(num), \ + bi_getd(OBI(obj))); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_bi(NREAL(num), OBI(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_bi(NREAL(num), OBI(obj)); \ + break; \ + } \ + break; \ + case LispDFloat_t: \ + switch (NRTYPE(num)) { \ + case N_FIXNUM: \ + r##OP##_flonum(NREAL(num), (double)NRFI(num), \ + ODF(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_flonum(NREAL(num), bi_getd(NRBI(num)), \ + ODF(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(NREAL(num), NRFF(num), ODF(obj));\ + break; \ + case N_FIXRATIO: \ + r##OP##_flonum(NREAL(num), \ + (double)NRFRN(num) / \ + (double)NRFRD(num), \ + ODF(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_flonum(NREAL(num), br_getd(NRBR(num)), \ + ODF(obj)); \ + break; \ + } \ + break; \ + case LispRatio_t: \ + switch (NRTYPE(num)) { \ + case N_FIXNUM: \ + r##OP##_fi_fr(NREAL(num), OFRN(obj), OFRD(obj));\ + break; \ + case N_BIGNUM: \ + r##OP##_bi_fr(NREAL(num), OFRN(obj), OFRD(obj));\ + break; \ + case N_FLONUM: \ + r##OP##_flonum(NREAL(num), NRFF(num), \ + (double)OFRN(obj) / \ + (double)OFRD(obj)); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_fr(NREAL(num), OFRN(obj), OFRD(obj));\ + break; \ + case N_BIGRATIO: \ + r##OP##_br_fr(NREAL(num), OFRN(obj), OFRD(obj));\ + break; \ + } \ + break; \ + case LispBigratio_t: \ + switch (NRTYPE(num)) { \ + case N_FIXNUM: \ + r##OP##_fi_br(NREAL(num), OBR(obj)); \ + break; \ + case N_BIGNUM: \ + r##OP##_bi_br(NREAL(num), OBR(obj)); \ + break; \ + case N_FLONUM: \ + r##OP##_flonum(NREAL(num), NRFF(num), \ + br_getd(OBR(obj))); \ + break; \ + case N_FIXRATIO: \ + r##OP##_fr_br(NREAL(num), OBR(obj)); \ + break; \ + case N_BIGRATIO: \ + r##OP##_br_br(NREAL(num), OBR(obj)); \ + break; \ + } \ + break; \ + case LispComplex_t: \ + n##OP##_re_cx(num, obj); \ + break; \ + default: \ + fatal_object_error(obj, NOT_A_NUMBER); \ + break; \ + } \ + } \ +} + +static void +DEFOP_NUMBER_OBJECT(add) + +static void +DEFOP_NUMBER_OBJECT(sub) + +static void +DEFOP_NUMBER_OBJECT(div) + +static void +DEFOP_NUMBER_OBJECT(mul) + + +/************************************************************************ + * ABS + ************************************************************************/ +static void +abs_real(n_real *real) +{ + switch (RTYPE(real)) { + case N_FIXNUM: rabs_fi(real); break; + case N_BIGNUM: rabs_bi(real); break; + case N_FLONUM: rabs_ff(real); break; + case N_FIXRATIO: rabs_fr(real); break; + case N_BIGRATIO: rabs_br(real); break; + } +} + +static void +abs_number(n_number *num) +{ + if (num->complex) + nabs_cx(num); + else { + switch (NRTYPE(num)) { + case N_FIXNUM: rabs_fi(NREAL(num)); break; + case N_BIGNUM: rabs_bi(NREAL(num)); break; + case N_FLONUM: rabs_ff(NREAL(num)); break; + case N_FIXRATIO: rabs_fr(NREAL(num)); break; + case N_BIGRATIO: rabs_br(NREAL(num)); break; + } + } +} + +static void +nabs_cx(n_number *num) +{ + n_real temp; + + abs_real(NREAL(num)); + abs_real(NIMAG(num)); + + if (cmp_real_real(NREAL(num), NIMAG(num)) < 0) { + memcpy(&temp, NIMAG(num), sizeof(n_real)); + memcpy(NIMAG(num), NREAL(num), sizeof(n_real)); + memcpy(NREAL(num), &temp, sizeof(n_real)); + } + + if (cmp_real_real(NIMAG(num), &zero) == 0) { + num->complex = 0; + if (NITYPE(num) == N_FLONUM) { + /* change number type */ + temp.type = N_FLONUM; + temp.data.flonum = 1.0; + mul_real_real(NREAL(num), &temp); + } + else + clear_real(NIMAG(num)); + } + else { + div_real_real(NIMAG(num), NREAL(num)); + set_real_real(&temp, NIMAG(num)); + mul_real_real(NIMAG(num), &temp); + clear_real(&temp); + + add_real_real(NIMAG(num), &one); + sqrt_real(NIMAG(num)); + + mul_real_real(NIMAG(num), NREAL(num)); + clear_real(NREAL(num)); + memcpy(NREAL(num), NIMAG(num), sizeof(n_real)); + num->complex = 0; + } +} + +static INLINE void +rabs_fi(n_real *real) +{ + if (RFI(real) < 0) + rneg_fi(real); +} + +static INLINE void +rabs_bi(n_real *real) +{ + if (mpi_cmpi(RBI(real), 0) < 0) + mpi_neg(RBI(real), RBI(real)); +} + +static INLINE void +rabs_ff(n_real *real) +{ + if (RFF(real) < 0.0) + RFF(real) = -RFF(real); +} + +static INLINE void +rabs_fr(n_real *real) +{ + if (RFRN(real) < 0) + rneg_fr(real); +} + +static INLINE void +rabs_br(n_real *real) +{ + if (mpi_cmpi(RBRN(real), 0) < 0) + mpi_neg(RBRN(real), RBRN(real)); +} + + +/************************************************************************ + * NEG + ************************************************************************/ +static void +neg_real(n_real *real) +{ + switch (RTYPE(real)) { + case N_FIXNUM: rneg_fi(real); break; + case N_BIGNUM: rneg_bi(real); break; + case N_FLONUM: rneg_ff(real); break; + case N_FIXRATIO: rneg_fr(real); break; + case N_BIGRATIO: rneg_br(real); break; + } +} + +static void +neg_number(n_number *num) +{ + if (num->complex) { + neg_real(NREAL(num)); + neg_real(NIMAG(num)); + } + else { + switch (NRTYPE(num)) { + case N_FIXNUM: rneg_fi(NREAL(num)); break; + case N_BIGNUM: rneg_bi(NREAL(num)); break; + case N_FLONUM: rneg_ff(NREAL(num)); break; + case N_FIXRATIO: rneg_fr(NREAL(num)); break; + case N_BIGRATIO: rneg_br(NREAL(num)); break; + } + } +} + +static void +rneg_fi(n_real *real) +{ + if (RFI(real) == MINSLONG) { + mpi *bigi = XALLOC(mpi); + + mpi_init(bigi); + mpi_seti(bigi, RFI(real)); + mpi_neg(bigi, bigi); + RTYPE(real) = N_BIGNUM; + RBI(real) = bigi; + } + else + RFI(real) = -RFI(real); +} + +static INLINE void +rneg_bi(n_real *real) +{ + mpi_neg(RBI(real), RBI(real)); +} + +static INLINE void +rneg_ff(n_real *real) +{ + RFF(real) = -RFF(real); +} + +static void +rneg_fr(n_real *real) +{ + if (RFRN(real) == MINSLONG) { + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + mpr_seti(bigr, RFRN(real), RFRD(real)); + mpi_neg(mpr_num(bigr), mpr_num(bigr)); + RTYPE(real) = N_BIGRATIO; + RBR(real) = bigr; + } + else + RFRN(real) = -RFRN(real); +} + +static INLINE void +rneg_br(n_real *real) +{ + mpi_neg(RBRN(real), RBRN(real)); +} + + +/************************************************************************ + * SQRT + ************************************************************************/ +static void +sqrt_real(n_real *real) +{ + switch (RTYPE(real)) { + case N_FIXNUM: + case N_BIGNUM: + rsqrt_xi(real); + break; + case N_FLONUM: + rsqrt_ff(real); + break; + case N_FIXRATIO: + case N_BIGRATIO: + rsqrt_xr(real); + break; + } +} + +static void +sqrt_number(n_number *num) +{ + if (num->complex) + nsqrt_cx(num); + else { + switch (NRTYPE(num)) { + case N_FIXNUM: + case N_BIGNUM: + nsqrt_xi(num); + break; + case N_FLONUM: + nsqrt_ff(num); + break; + case N_FIXRATIO: + case N_BIGRATIO: + nsqrt_xr(num); + break; + } + } +} + +static void +rsqrt_xi(n_real *real) +{ + int exact; + mpi bignum; + + if (cmp_real_real(real, &zero) < 0) + fatal_error(FLOATING_POINT_EXCEPTION); + + mpi_init(&bignum); + if (RTYPE(real) == N_BIGNUM) + exact = mpi_sqrt(&bignum, RBI(real)); + else { + mpi tmp; + + mpi_init(&tmp); + mpi_seti(&tmp, RFI(real)); + exact = mpi_sqrt(&bignum, &tmp); + mpi_clear(&tmp); + } + if (exact) { + if (RTYPE(real) == N_BIGNUM) { + mpi_set(RBI(real), &bignum); + rbi_canonicalize(real); + } + else + RFI(real) = mpi_geti(&bignum); + } + else { + double value; + + if (RTYPE(real) == N_BIGNUM) { + value = bi_getd(RBI(real)); + RCLEAR_BI(real); + } + else + value = (double)RFI(real); + + value = sqrt(value); + RTYPE(real) = N_FLONUM; + RFF(real) = value; + } + mpi_clear(&bignum); +} + +static void +rsqrt_xr(n_real *real) +{ + n_real num, den; + + if (cmp_real_real(real, &zero) < 0) + fatal_error(FLOATING_POINT_EXCEPTION); + + if (RTYPE(real) == N_FIXRATIO) { + num.type = den.type = N_FIXNUM; + num.data.fixnum = RFRN(real); + den.data.fixnum = RFRD(real); + } + else { + mpi *bignum; + + if (mpi_fiti(RBRN(real))) { + num.type = N_FIXNUM; + num.data.fixnum = mpi_geti(RBRN(real)); + } + else { + bignum = XALLOC(mpi); + mpi_init(bignum); + mpi_set(bignum, RBRN(real)); + num.type = N_BIGNUM; + num.data.bignum = bignum; + } + + if (mpi_fiti(RBRD(real))) { + den.type = N_FIXNUM; + den.data.fixnum = mpi_geti(RBRD(real)); + } + else { + bignum = XALLOC(mpi); + mpi_init(bignum); + mpi_set(bignum, RBRD(real)); + den.type = N_BIGNUM; + den.data.bignum = bignum; + } + } + + rsqrt_xi(&num); + rsqrt_xi(&den); + + clear_real(real); + memcpy(real, &num, sizeof(n_real)); + div_real_real(real, &den); + clear_real(&den); +} + +static void +rsqrt_ff(n_real *real) +{ + if (RFF(real) < 0.0) + fatal_error(FLOATING_POINT_EXCEPTION); + RFF(real) = sqrt(RFF(real)); +} + + +static void +nsqrt_cx(n_number *num) +{ + n_number mag; + n_real *real, *imag; + + real = &(mag.real); + imag = &(mag.imag); + set_real_real(real, NREAL(num)); + set_real_real(imag, NIMAG(num)); + mag.complex = 1; + + nabs_cx(&mag); /* this will free the imag part data */ + if (cmp_real_real(real, &zero) == 0) { + clear_number(num); + memcpy(NREAL(num), real, sizeof(n_real)); + clear_real(real); + num->complex = 0; + return; + } + else if (cmp_real_real(NREAL(num), &zero) > 0) { + /* R = sqrt((mag + Ra) / 2) */ + add_real_real(NREAL(num), real); + clear_real(real); + div_real_real(NREAL(num), &two); + sqrt_real(NREAL(num)); + + /* I = Ia / R / 2 */ + div_real_real(NIMAG(num), NREAL(num)); + div_real_real(NIMAG(num), &two); + } + else { + /* remember old imag part */ + memcpy(imag, NIMAG(num), sizeof(n_real)); + + /* I = sqrt((mag - Ra) / 2) */ + memcpy(NIMAG(num), real, sizeof(n_real)); + sub_real_real(NIMAG(num), NREAL(num)); + div_real_real(NIMAG(num), &two); + sqrt_real(NIMAG(num)); + if (cmp_real_real(imag, &zero) < 0) + neg_real(NIMAG(num)); + + /* R = Ia / I / 2 */ + clear_real(NREAL(num)); + /* start with old imag part */ + memcpy(NREAL(num), imag, sizeof(n_real)); + div_real_real(NREAL(num), NIMAG(num)); + div_real_real(NREAL(num), &two); + } + + ncx_canonicalize(num); +} + +static void +nsqrt_xi(n_number *num) +{ + if (cmp_real_real(NREAL(num), &zero) < 0) { + memcpy(NIMAG(num), NREAL(num), sizeof(n_real)); + neg_real(NIMAG(num)); + rsqrt_xi(NIMAG(num)); + NRTYPE(num) = N_FIXNUM; + NRFI(num) = 0; + num->complex = 1; + } + else + rsqrt_xi(NREAL(num)); +} + +static void +nsqrt_ff(n_number *num) +{ + double value; + + if (NRFF(num) < 0.0) { + value = sqrt(-NRFF(num)); + + NITYPE(num) = N_FLONUM; + NIFF(num) = value; + NRTYPE(num) = N_FIXNUM; + NRFI(num) = 0; + num->complex = 1; + } + else { + value = sqrt(NRFF(num)); + NRFF(num) = value; + } +} + +static void +nsqrt_xr(n_number *num) +{ + if (cmp_real_real(NREAL(num), &zero) < 0) { + memcpy(NIMAG(num), NREAL(num), sizeof(n_real)); + neg_real(NIMAG(num)); + rsqrt_xr(NIMAG(num)); + NRTYPE(num) = N_FIXNUM; + NRFI(num) = 0; + num->complex = 1; + } + else + rsqrt_xr(NREAL(num)); +} + + +/************************************************************************ + * MOD + ************************************************************************/ +static void +mod_real_real(n_real *real, n_real *val) +{ + /* Assume both operands are integers */ + switch (RTYPE(real)) { + case N_FIXNUM: + switch (RTYPE(val)) { + case N_FIXNUM: + rmod_fi_fi(real, RFI(val)); + break; + case N_BIGNUM: + rmod_fi_bi(real, RBI(val)); + break; + } + break; + case N_BIGNUM: + switch (RTYPE(val)) { + case N_FIXNUM: + rmod_bi_fi(real, RFI(val)); + break; + case N_BIGNUM: + rmod_bi_bi(real, RBI(val)); + break; + } + break; + } +} + +static void +mod_real_object(n_real *real, LispObj *obj) +{ + switch (RTYPE(real)) { + case N_FIXNUM: + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + rmod_fi_fi(real, OFI(obj)); + return; + case LispInteger_t: + rmod_fi_fi(real, OII(obj)); + return; + case LispBignum_t: + rmod_fi_bi(real, OBI(obj)); + return; + default: + break; + } + break; + case N_BIGNUM: + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + rmod_bi_fi(real, OFI(obj)); + return; + case LispInteger_t: + rmod_bi_fi(real, OII(obj)); + return; + case LispBignum_t: + rmod_bi_bi(real, OBI(obj)); + return; + default: + break; + } + break; + /* Assume the n_real object is an integer */ + } + fatal_object_error(obj, NOT_AN_INTEGER); +} + +static void +rmod_fi_fi(n_real *real, long fi) +{ + if (fi == 0) + fatal_error(DIVIDE_BY_ZERO); + + if ((RFI(real) < 0) ^ (fi < 0)) + RFI(real) = (RFI(real) % fi) + fi; + else if (RFI(real) == MINSLONG || fi == MINSLONG) { + mpi bignum; + + mpi_init(&bignum); + mpi_seti(&bignum, RFI(real)); + RFI(real) = mpi_modi(&bignum, fi); + mpi_clear(&bignum); + } + else + RFI(real) = RFI(real) % fi; +} + +static void +rmod_fi_bi(n_real *real, mpi *bignum) +{ + mpi *bigi; + + if (mpi_cmpi(bignum, 0) == 0) + fatal_error(DIVIDE_BY_ZERO); + + bigi = XALLOC(mpi); + mpi_init(bigi); + mpi_seti(bigi, RFI(real)); + mpi_mod(bigi, bigi, bignum); + RTYPE(real) = N_BIGNUM; + RBI(real) = bigi; + rbi_canonicalize(real); +} + +static void +rmod_bi_fi(n_real *real, long fi) +{ + mpi iop; + + if (fi == 0) + fatal_error(DIVIDE_BY_ZERO); + + mpi_init(&iop); + mpi_seti(&iop, fi); + mpi_mod(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); +} + +static void +rmod_bi_bi(n_real *real, mpi *bignum) +{ + if (mpi_cmpi(bignum, 0) == 0) + fatal_error(DIVIDE_BY_ZERO); + + mpi_mod(RBI(real), RBI(real), bignum); + rbi_canonicalize(real); +} + +/************************************************************************ + * REM + ************************************************************************/ +static void +rem_real_object(n_real *real, LispObj *obj) +{ + switch (RTYPE(real)) { + case N_FIXNUM: + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + rrem_fi_fi(real, OFI(obj)); + return; + case LispInteger_t: + rrem_fi_fi(real, OII(obj)); + return; + case LispBignum_t: + rrem_fi_bi(real, OBI(obj)); + return; + default: + break; + } + break; + case N_BIGNUM: + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + rrem_bi_fi(real, OFI(obj)); + return; + case LispInteger_t: + rrem_bi_fi(real, OII(obj)); + return; + case LispBignum_t: + rrem_bi_bi(real, OBI(obj)); + return; + default: + break; + } + break; + /* Assume the n_real object is an integer */ + } + fatal_object_error(obj, NOT_AN_INTEGER); +} + +static void +rrem_fi_fi(n_real *real, long fi) +{ + if (fi == 0) + fatal_error(DIVIDE_BY_ZERO); + + if (RFI(real) == MINSLONG || fi == MINSLONG) { + mpi bignum; + + mpi_init(&bignum); + mpi_seti(&bignum, RFI(real)); + RFI(real) = mpi_remi(&bignum, fi); + mpi_clear(&bignum); + } + else + RFI(real) = RFI(real) % fi; +} + +static void +rrem_fi_bi(n_real *real, mpi *bignum) +{ + mpi *bigi; + + if (mpi_cmpi(bignum, 0) == 0) + fatal_error(DIVIDE_BY_ZERO); + + bigi = XALLOC(mpi); + mpi_init(bigi); + mpi_seti(bigi, RFI(real)); + mpi_rem(bigi, bigi, bignum); + RTYPE(real) = N_BIGNUM; + RBI(real) = bigi; + rbi_canonicalize(real); +} + +static void +rrem_bi_fi(n_real *real, long fi) +{ + mpi iop; + + if (fi == 0) + fatal_error(DIVIDE_BY_ZERO); + + mpi_init(&iop); + mpi_seti(&iop, fi); + mpi_rem(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); +} + +static void +rrem_bi_bi(n_real *real, mpi *bignum) +{ + if (mpi_cmpi(bignum, 0) == 0) + fatal_error(DIVIDE_BY_ZERO); + + mpi_rem(RBI(real), RBI(real), bignum); + rbi_canonicalize(real); +} + + +/************************************************************************ + * GCD + ************************************************************************/ +static void +gcd_real_object(n_real *real, LispObj *obj) +{ + if (!INTEGERP(obj)) + fatal_object_error(obj, NOT_AN_INTEGER); + + /* check for zero operand */ + if (cmp_real_real(real, &zero) == 0) + set_real_object(real, obj); + else if (cmp_real_object(&zero, obj) != 0) { + n_real rest, temp; + + set_real_object(&rest, obj); + for (;;) { + mod_real_real(&rest, real); + if (cmp_real_real(&rest, &zero) == 0) + break; + memcpy(&temp, real, sizeof(n_real)); + memcpy(real, &rest, sizeof(n_real)); + memcpy(&rest, &temp, sizeof(n_real)); + } + clear_real(&rest); + } +} + +/************************************************************************ + * AND + ************************************************************************/ +static void +and_real_object(n_real *real, LispObj *obj) +{ + mpi *bigi, iop; + + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + switch (RTYPE(real)) { + case N_FIXNUM: + RFI(real) &= OFI(obj); + break; + case N_BIGNUM: + mpi_init(&iop); + mpi_seti(&iop, OFI(obj)); + mpi_and(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); + break; + } + break; + case LispInteger_t: + switch (RTYPE(real)) { + case N_FIXNUM: + RFI(real) &= OII(obj); + break; + case N_BIGNUM: + mpi_init(&iop); + mpi_seti(&iop, OII(obj)); + mpi_and(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); + break; + } + break; + case LispBignum_t: + switch (RTYPE(real)) { + case N_FIXNUM: + bigi = XALLOC(mpi); + mpi_init(bigi); + mpi_seti(bigi, RFI(real)); + mpi_and(bigi, bigi, OBI(obj)); + RTYPE(real) = N_BIGNUM; + RBI(real) = bigi; + rbi_canonicalize(real); + break; + case N_BIGNUM: + mpi_and(RBI(real), RBI(real), OBI(obj)); + rbi_canonicalize(real); + break; + } + break; + default: + fatal_object_error(obj, NOT_AN_INTEGER); + break; + } +} + + +/************************************************************************ + * EQV + ************************************************************************/ +static void +eqv_real_object(n_real *real, LispObj *obj) +{ + mpi *bigi, iop; + + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + switch (RTYPE(real)) { + case N_FIXNUM: + RFI(real) ^= ~OFI(obj); + break; + case N_BIGNUM: + mpi_init(&iop); + mpi_seti(&iop, OFI(obj)); + mpi_com(&iop, &iop); + mpi_xor(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); + break; + } + break; + case LispInteger_t: + switch (RTYPE(real)) { + case N_FIXNUM: + RFI(real) ^= ~OII(obj); + break; + case N_BIGNUM: + mpi_init(&iop); + mpi_seti(&iop, OII(obj)); + mpi_com(&iop, &iop); + mpi_xor(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); + break; + } + break; + case LispBignum_t: + switch (RTYPE(real)) { + case N_FIXNUM: + bigi = XALLOC(mpi); + mpi_init(bigi); + mpi_seti(bigi, RFI(real)); + mpi_com(bigi, bigi); + mpi_xor(bigi, bigi, OBI(obj)); + RTYPE(real) = N_BIGNUM; + RBI(real) = bigi; + rbi_canonicalize(real); + break; + case N_BIGNUM: + mpi_com(RBI(real), RBI(real)); + mpi_xor(RBI(real), RBI(real), OBI(obj)); + rbi_canonicalize(real); + break; + } + break; + default: + fatal_object_error(obj, NOT_AN_INTEGER); + break; + } +} + + +/************************************************************************ + * IOR + ************************************************************************/ +static void +ior_real_object(n_real *real, LispObj *obj) +{ + mpi *bigi, iop; + + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + switch (RTYPE(real)) { + case N_FIXNUM: + RFI(real) |= OFI(obj); + break; + case N_BIGNUM: + mpi_init(&iop); + mpi_seti(&iop, OFI(obj)); + mpi_ior(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); + break; + } + break; + case LispInteger_t: + switch (RTYPE(real)) { + case N_FIXNUM: + RFI(real) |= OII(obj); + break; + case N_BIGNUM: + mpi_init(&iop); + mpi_seti(&iop, OII(obj)); + mpi_ior(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); + break; + } + break; + case LispBignum_t: + switch (RTYPE(real)) { + case N_FIXNUM: + bigi = XALLOC(mpi); + mpi_init(bigi); + mpi_seti(bigi, RFI(real)); + mpi_ior(bigi, bigi, OBI(obj)); + RTYPE(real) = N_BIGNUM; + RBI(real) = bigi; + rbi_canonicalize(real); + break; + case N_BIGNUM: + mpi_ior(RBI(real), RBI(real), OBI(obj)); + rbi_canonicalize(real); + break; + } + break; + default: + fatal_object_error(obj, NOT_AN_INTEGER); + break; + } +} + + +/************************************************************************ + * NOT + ************************************************************************/ +static void +not_real(n_real *real) +{ + if (RTYPE(real) == N_FIXNUM) + RFI(real) = ~RFI(real); + else { + mpi_com(RBI(real), RBI(real)); + rbi_canonicalize(real); + } +} + +/************************************************************************ + * XOR + ************************************************************************/ +static void +xor_real_object(n_real *real, LispObj *obj) +{ + mpi *bigi, iop; + + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + switch (RTYPE(real)) { + case N_FIXNUM: + RFI(real) ^= OFI(obj); + break; + case N_BIGNUM: + mpi_init(&iop); + mpi_seti(&iop, OFI(obj)); + mpi_xor(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); + break; + } + break; + case LispInteger_t: + switch (RTYPE(real)) { + case N_FIXNUM: + RFI(real) ^= OII(obj); + break; + case N_BIGNUM: + mpi_init(&iop); + mpi_seti(&iop, OII(obj)); + mpi_xor(RBI(real), RBI(real), &iop); + mpi_clear(&iop); + rbi_canonicalize(real); + break; + } + break; + case LispBignum_t: + switch (RTYPE(real)) { + case N_FIXNUM: + bigi = XALLOC(mpi); + mpi_init(bigi); + mpi_seti(bigi, RFI(real)); + mpi_xor(bigi, bigi, OBI(obj)); + RTYPE(real) = N_BIGNUM; + RBI(real) = bigi; + rbi_canonicalize(real); + break; + case N_BIGNUM: + mpi_xor(RBI(real), RBI(real), OBI(obj)); + rbi_canonicalize(real); + break; + } + break; + default: + fatal_object_error(obj, NOT_AN_INTEGER); + break; + } +} + + +/************************************************************************ + * DIVIDE + ************************************************************************/ +static void +divide_number_object(n_number *num, LispObj *obj, int fun, int flo) +{ + switch (OBJECT_TYPE(obj)) { + case LispFixnum_t: + switch (NRTYPE(num)) { + case N_FIXNUM: + ndivide_fi_fi(num, OFI(obj), fun, flo); + break; + case N_BIGNUM: + ndivide_xi_xi(num, obj, fun, flo); + break; + case N_FLONUM: + ndivide_flonum(num, NRFF(num), (double)OFI(obj), fun, flo); + break; + case N_FIXRATIO: + case N_BIGRATIO: + ndivide_xr_xi(num, obj, fun, flo); + break; + } + break; + case LispInteger_t: + switch (NRTYPE(num)) { + case N_FIXNUM: + ndivide_fi_fi(num, OII(obj), fun, flo); + break; + case N_BIGNUM: + ndivide_xi_xi(num, obj, fun, flo); + break; + case N_FLONUM: + ndivide_flonum(num, NRFF(num), (double)OII(obj), fun, flo); + break; + case N_FIXRATIO: + case N_BIGRATIO: + ndivide_xr_xi(num, obj, fun, flo); + break; + } + break; + case LispBignum_t: + switch (NRTYPE(num)) { + case N_FIXNUM: + case N_BIGNUM: + ndivide_xi_xi(num, obj, fun, flo); + break; + case N_FLONUM: + ndivide_flonum(num, NRFF(num), bi_getd(OBI(obj)), + fun, flo); + break; + case N_FIXRATIO: + case N_BIGRATIO: + ndivide_xr_xi(num, obj, fun, flo); + break; + } + break; + case LispDFloat_t: + switch (NRTYPE(num)) { + case N_FIXNUM: + ndivide_flonum(num, (double)NRFI(num), ODF(obj), + fun, flo); + break; + case N_BIGNUM: + ndivide_flonum(num, bi_getd(NRBI(num)), ODF(obj), + fun, flo); + break; + case N_FLONUM: + ndivide_flonum(num, NRFF(num), ODF(obj), fun, flo); + break; + case N_FIXRATIO: + ndivide_flonum(num, + (double)NRFRN(num) / (double)NRFRD(num), + ODF(obj), fun, flo); + break; + case N_BIGRATIO: + ndivide_flonum(num, br_getd(NRBR(num)), ODF(obj), + fun, flo); + break; + } + break; + case LispRatio_t: + switch (NRTYPE(num)) { + case N_FIXNUM: + case N_BIGNUM: + ndivide_xi_xr(num, obj, fun, flo); + break; + case N_FLONUM: + ndivide_flonum(num, NRFF(num), + (double)OFRN(obj) / (double)OFRD(obj), + fun, flo); + break; + case N_FIXRATIO: + case N_BIGRATIO: + ndivide_xr_xr(num, obj, fun, flo); + break; + } + break; + case LispBigratio_t: + switch (NRTYPE(num)) { + case N_FIXNUM: + case N_BIGNUM: + ndivide_xi_xr(num, obj, fun, flo); + break; + case N_FLONUM: + ndivide_flonum(num, NRFF(num), br_getd(OBR(obj)), + fun, flo); + break; + case N_FIXRATIO: + case N_BIGRATIO: + ndivide_xr_xr(num, obj, fun, flo); + break; + } + break; + default: + fatal_object_error(obj, NOT_A_REAL_NUMBER); + break; + } +} + + +/************************************************************************ + * COMPARE + ************************************************************************/ +static int +cmp_real_real(n_real *op1, n_real *op2) +{ + switch (RTYPE(op1)) { + case N_FIXNUM: + switch (RTYPE(op2)) { + case N_FIXNUM: + return (cmp_fi_fi(RFI(op1), RFI(op2))); + case N_BIGNUM: + return (cmp_fi_bi(RFI(op1), RBI(op2))); + case N_FLONUM: + return (cmp_flonum((double)RFI(op1), RFF(op2))); + case N_FIXRATIO: + return (cmp_fi_fr(RFI(op1), RFRN(op2), RFRD(op2))); + case N_BIGRATIO: + return (cmp_fi_br(RFI(op1), RBR(op2))); + } + break; + case N_BIGNUM: + switch (RTYPE(op2)) { + case N_FIXNUM: + return (cmp_bi_fi(RBI(op1), RFI(op2))); + case N_BIGNUM: + return (cmp_bi_bi(RBI(op1), RBI(op2))); + case N_FLONUM: + return (cmp_flonum(bi_getd(RBI(op1)), RFF(op2))); + case N_FIXRATIO: + return (cmp_bi_fr(RBI(op1), RFRN(op2), RFRD(op2))); + case N_BIGRATIO: + return (cmp_bi_br(RBI(op1), RBR(op2))); + } + break; + case N_FLONUM: + switch (RTYPE(op2)) { + case N_FIXNUM: + return (cmp_flonum(RFF(op1), (double)RFI(op2))); + case N_BIGNUM: + return (cmp_flonum(RFF(op1), bi_getd(RBI(op2)))); + case N_FLONUM: + return (cmp_flonum(RFF(op1), RFF(op2))); + case N_FIXRATIO: + return (cmp_flonum(RFF(op1), + (double)RFRN(op2) / (double)RFRD(op2))); + case N_BIGRATIO: + return (cmp_flonum(RFF(op1), br_getd(RBR(op2)))); + } + break; + case N_FIXRATIO: + switch (RTYPE(op2)) { + case N_FIXNUM: + return (cmp_fr_fi(RFRN(op1), RFRD(op1), RFI(op2))); + case N_BIGNUM: + return (cmp_fr_bi(RFRN(op1), RFRD(op1), RBI(op2))); + case N_FLONUM: + return (cmp_flonum((double)RFRN(op1) / (double)RFRD(op1), + RFF(op2))); + case N_FIXRATIO: + return (cmp_fr_fr(RFRN(op1), RFRD(op1), + RFRN(op2), RFRD(op2))); + case N_BIGRATIO: + return (cmp_fr_br(RFRN(op1), RFRD(op1), RBR(op2))); + } + break; + case N_BIGRATIO: + switch (RTYPE(op2)) { + case N_FIXNUM: + return (cmp_br_fi(RBR(op1), RFI(op2))); + case N_BIGNUM: + return (cmp_br_bi(RBR(op1), RBI(op2))); + case N_FLONUM: + return (cmp_flonum(br_getd(RBR(op1)), RFF(op2))); + case N_FIXRATIO: + return (cmp_br_fr(RBR(op1), RFRN(op2), RFRD(op2))); + case N_BIGRATIO: + return (cmp_br_br(RBR(op1), RBR(op2))); + } + } + + return (0); +} + +static int +cmp_real_object(n_real *op1, LispObj *op2) +{ + switch (OBJECT_TYPE(op2)) { + case LispFixnum_t: + switch (RTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_fi(RFI(op1), OFI(op2))); + case N_BIGNUM: + return (cmp_bi_fi(RBI(op1), OFI(op2))); + case N_FLONUM: + return (cmp_flonum(RFF(op1), (double)OFI(op2))); + case N_FIXRATIO: + return (cmp_fr_fi(RFRD(op1), RFRN(op1), OFI(op2))); + case N_BIGRATIO: + return (cmp_br_fi(RBR(op1), OFI(op2))); + } + break; + case LispInteger_t: + switch (RTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_fi(RFI(op1), OII(op2))); + case N_BIGNUM: + return (cmp_bi_fi(RBI(op1), OII(op2))); + case N_FLONUM: + return (cmp_flonum(RFF(op1), (double)OII(op2))); + case N_FIXRATIO: + return (cmp_fr_fi(RFRD(op1), RFRN(op1), OII(op2))); + case N_BIGRATIO: + return (cmp_br_fi(RBR(op1), OII(op2))); + } + break; + case LispBignum_t: + switch (RTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_bi(RFI(op1), OBI(op2))); + case N_BIGNUM: + return (cmp_bi_bi(RBI(op1), OBI(op2))); + case N_FLONUM: + return (cmp_flonum(RFF(op1), bi_getd(OBI(op2)))); + case N_FIXRATIO: + return (cmp_fr_bi(RFRD(op1), RFRN(op1), OBI(op2))); + case N_BIGRATIO: + return (cmp_br_bi(RBR(op1), OBI(op2))); + } + break; + case LispDFloat_t: + switch (RTYPE(op1)) { + case N_FIXNUM: + return (cmp_flonum((double)RFI(op1), ODF(op2))); + case N_BIGNUM: + return (cmp_flonum(bi_getd(RBI(op1)), ODF(op2))); + case N_FLONUM: + return (cmp_flonum(RFF(op1), ODF(op2))); + case N_FIXRATIO: + return (cmp_flonum((double)RFRN(op1) / (double)RFRD(op1), + ODF(op2))); + case N_BIGRATIO: + return (cmp_flonum(br_getd(RBR(op1)), ODF(op2))); + } + break; + case LispRatio_t: + switch (RTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_fr(RFI(op1), OFRN(op2), OFRD(op2))); + case N_BIGNUM: + return (cmp_bi_fr(RBI(op1), OFRN(op2), OFRD(op2))); + case N_FLONUM: + return (cmp_flonum(RFF(op1), + (double)OFRN(op2) / (double)OFRD(op2))); + case N_FIXRATIO: + return (cmp_fr_fr(RFRN(op1), RFRD(op1), + OFRN(op2), OFRD(op2))); + case N_BIGRATIO: + return (cmp_br_fr(RBR(op1), OFRN(op2), OFRD(op2))); + } + break; + case LispBigratio_t: + switch (RTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_br(RFI(op1), OBR(op2))); + case N_BIGNUM: + return (cmp_bi_br(RBI(op1), OBR(op2))); + case N_FLONUM: + return (cmp_flonum(RFF(op1), br_getd(OBR(op2)))); + case N_FIXRATIO: + return (cmp_fr_br(RFRN(op1), RFRD(op1), OBR(op2))); + case N_BIGRATIO: + return (cmp_br_br(RBR(op1), OBR(op2))); + } + break; + default: + fatal_object_error(op2, NOT_A_REAL_NUMBER); + break; + } + + return (0); +} + +#if 0 /* not used */ +static int +cmp_number_object(n_number *op1, LispObj *op2) +{ + if (op1->complex) { + if (OBJECT_TYPE(op2) == LispComplex_t) { + if (cmp_real_object(NREAL(op1), OCXR(op2)) == 0) + return (cmp_real_object(NIMAG(op1), OCXI(op2))); + return (1); + } + else if (cmp_real_real(NIMAG(op1), &zero) == 0) + return (cmp_real_object(NREAL(op1), op2)); + else + return (1); + } + else { + switch (OBJECT_TYPE(op2)) { + case LispFixnum_t: + switch (NRTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_fi(NRFI(op1), OFI(op2))); + case N_BIGNUM: + return (cmp_bi_fi(NRBI(op1), OFI(op2))); + case N_FLONUM: + return (cmp_flonum(NRFF(op1), (double)OFI(op2))); + case N_FIXRATIO: + return (cmp_fr_fi(NRFRD(op1), NRFRN(op1), OFI(op2))); + case N_BIGRATIO: + return (cmp_br_fi(NRBR(op1), OFI(op2))); + } + break; + case LispInteger_t: + switch (NRTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_fi(NRFI(op1), OII(op2))); + case N_BIGNUM: + return (cmp_bi_fi(NRBI(op1), OII(op2))); + case N_FLONUM: + return (cmp_flonum(NRFF(op1), (double)OII(op2))); + case N_FIXRATIO: + return (cmp_fr_fi(NRFRD(op1), NRFRN(op1), OII(op2))); + case N_BIGRATIO: + return (cmp_br_fi(NRBR(op1), OII(op2))); + } + break; + case LispBignum_t: + switch (NRTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_bi(NRFI(op1), OBI(op2))); + case N_BIGNUM: + return (cmp_bi_bi(NRBI(op1), OBI(op2))); + case N_FLONUM: + return (cmp_flonum(NRFF(op1), bi_getd(OBI(op2)))); + case N_FIXRATIO: + return (cmp_fr_bi(NRFRD(op1), NRFRN(op1), OBI(op2))); + case N_BIGRATIO: + return (cmp_br_bi(NRBR(op1), OBI(op2))); + } + break; + case LispDFloat_t: + switch (NRTYPE(op1)) { + case N_FIXNUM: + return (cmp_flonum((double)NRFI(op1), ODF(op2))); + case N_BIGNUM: + return (cmp_flonum(bi_getd(NRBI(op1)), ODF(op2))); + case N_FLONUM: + return (cmp_flonum(NRFF(op1), ODF(op2))); + case N_FIXRATIO: + return (cmp_flonum((double)NRFRN(op1) / + (double)NRFRD(op1), + ODF(op2))); + case N_BIGRATIO: + return (cmp_flonum(br_getd(NRBR(op1)), ODF(op2))); + } + break; + case LispRatio_t: + switch (NRTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_fr(NRFI(op1), OFRN(op2), OFRD(op2))); + case N_BIGNUM: + return (cmp_bi_fr(NRBI(op1), OFRN(op2), OFRD(op2))); + case N_FLONUM: + return (cmp_flonum(NRFF(op1), + (double)OFRN(op2) / (double)OFRD(op2))); + case N_FIXRATIO: + return (cmp_fr_fr(NRFRN(op1), NRFRD(op1), + OFRN(op2), OFRD(op2))); + case N_BIGRATIO: + return (cmp_br_fr(NRBR(op1), OFRN(op2), OFRD(op2))); + } + break; + case LispBigratio_t: + switch (NRTYPE(op1)) { + case N_FIXNUM: + return (cmp_fi_br(NRFI(op1), OBR(op2))); + case N_BIGNUM: + return (cmp_bi_br(NRBI(op1), OBR(op2))); + case N_FLONUM: + return (cmp_flonum(NRFF(op1), br_getd(OBR(op2)))); + case N_FIXRATIO: + return (cmp_fr_br(NRFRN(op1), NRFRD(op1), OBR(op2))); + case N_BIGRATIO: + return (cmp_br_br(NRBR(op1), OBR(op2))); + } + break; + case LispComplex_t: + if (cmp_real_object(&zero, OCXI(op2)) == 0) + return (cmp_real_object(NREAL(op1), OCXR(op2))); + return (1); + default: + fatal_object_error(op2, NOT_A_NUMBER); + break; + } + } + + return (0); +} +#endif + +static int +cmp_object_object(LispObj *op1, LispObj *op2, int real) +{ + if (OBJECT_TYPE(op1) == LispComplex_t) { + if (real) + fatal_object_error(op1, NOT_A_REAL_NUMBER); + if (OBJECT_TYPE(op2) == LispComplex_t) + return (cmp_cx_cx(op1, op2)); + else if (cmp_real_object(&zero, OCXI(op1)) == 0) + return (cmp_object_object(OCXR(op1), op2, real)); + return (1); + } + else if (OBJECT_TYPE(op2) == LispComplex_t) { + if (real) + fatal_object_error(op1, NOT_A_REAL_NUMBER); + if (cmp_real_object(&zero, OCXI(op2)) == 0) + return (cmp_object_object(op1, OCXR(op2), real)); + return (1); + } + else { + switch (OBJECT_TYPE(op1)) { + case LispFixnum_t: + switch (OBJECT_TYPE(op2)) { + case LispFixnum_t: + return (cmp_fi_fi(OFI(op1), OFI(op2))); + case LispInteger_t: + return (cmp_fi_fi(OFI(op1), OII(op2))); + case LispBignum_t: + return (cmp_fi_bi(OFI(op1), OBI(op2))); + case LispDFloat_t: + return (cmp_flonum((double)OFI(op1), ODF(op2))); + case LispRatio_t: + return (cmp_fi_fr(OFI(op1), + OFRN(op2), OFRD(op2))); + case LispBigratio_t: + return (cmp_fi_br(OFI(op1), OBR(op2))); + default: + break; + } + break; + case LispInteger_t: + switch (OBJECT_TYPE(op2)) { + case LispFixnum_t: + return (cmp_fi_fi(OII(op1), OFI(op2))); + case LispInteger_t: + return (cmp_fi_fi(OII(op1), OII(op2))); + case LispBignum_t: + return (cmp_fi_bi(OII(op1), OBI(op2))); + case LispDFloat_t: + return (cmp_flonum((double)OII(op1), ODF(op2))); + case LispRatio_t: + return (cmp_fi_fr(OII(op1), + OFRN(op2), OFRD(op2))); + case LispBigratio_t: + return (cmp_fi_br(OII(op1), OBR(op2))); + default: + break; + } + break; + case LispBignum_t: + switch (OBJECT_TYPE(op2)) { + case LispFixnum_t: + return (cmp_bi_fi(OBI(op1), OFI(op2))); + case LispInteger_t: + return (cmp_bi_fi(OBI(op1), OII(op2))); + case LispBignum_t: + return (cmp_bi_bi(OBI(op1), OBI(op2))); + case LispDFloat_t: + return (cmp_flonum(bi_getd(OBI(op1)), ODF(op2))); + case LispRatio_t: + return (cmp_bi_fr(OBI(op1), + OFRN(op2), OFRD(op2))); + case LispBigratio_t: + return (cmp_bi_br(OBI(op1), OBR(op2))); + default: + break; + } + break; + case LispDFloat_t: + switch (OBJECT_TYPE(op2)) { + case LispFixnum_t: + return (cmp_flonum(ODF(op1), (double)OFI(op2))); + case LispInteger_t: + return (cmp_flonum(ODF(op1), (double)OII(op2))); + case LispBignum_t: + return (cmp_flonum(ODF(op1), bi_getd(OBI(op2)))); + case LispDFloat_t: + return (cmp_flonum(ODF(op1), ODF(op2))); + break; + case LispRatio_t: + return (cmp_flonum(ODF(op1), + (double)OFRN(op2) / + (double)OFRD(op2))); + case LispBigratio_t: + return (cmp_flonum(ODF(op1), br_getd(OBR(op2)))); + default: + break; + } + break; + case LispRatio_t: + switch (OBJECT_TYPE(op2)) { + case LispFixnum_t: + return (cmp_fr_fi(OFRN(op1), OFRD(op1), OFI(op2))); + case LispInteger_t: + return (cmp_fr_fi(OFRN(op1), OFRD(op1), OII(op2))); + case LispBignum_t: + return (cmp_fr_bi(OFRN(op1), OFRD(op1), OBI(op2))); + case LispDFloat_t: + return (cmp_flonum((double)OFRN(op1) / + (double)OFRD(op1), + ODF(op2))); + case LispRatio_t: + return (cmp_fr_fr(OFRN(op1), OFRD(op1), + OFRN(op2), OFRD(op2))); + case LispBigratio_t: + return (cmp_fr_br(OFRN(op1), OFRD(op1), OBR(op2))); + default: + break; + } + break; + case LispBigratio_t: + switch (OBJECT_TYPE(op2)) { + case LispFixnum_t: + return (cmp_br_fi(OBR(op1), OFI(op2))); + case LispInteger_t: + return (cmp_br_fi(OBR(op1), OII(op2))); + case LispBignum_t: + return (cmp_br_bi(OBR(op1), OBI(op2))); + case LispDFloat_t: + return (cmp_flonum(br_getd(OBR(op1)), ODF(op2))); + case LispRatio_t: + return (cmp_br_fr(OBR(op1), OFRN(op2), OFRD(op2))); + case LispBigratio_t: + return (cmp_br_br(OBR(op1), OBR(op2))); + default: + break; + } + break; + default: + fatal_object_error(op1, NOT_A_NUMBER); + break; + } + } + + fatal_object_error(op2, NOT_A_NUMBER); + return (0); +} + + +/************************************************************************ + * FIXNUM + ************************************************************************/ +/* + * check if op1 + op2 will overflow + */ +static INLINE int +fi_fi_add_overflow(long op1, long op2) +{ + long op = op1 + op2; + + return (op1 > 0 ? op2 > op : op2 < op); +} + +/* + * check if op1 - op2 will overflow + */ +static INLINE int +fi_fi_sub_overflow(long op1, long op2) +{ + long op = op1 - op2; + + return (((op1 < 0) ^ (op2 < 0)) && ((op < 0) ^ (op1 < 0))); +} + +/* + * check if op1 * op2 will overflow + */ +static INLINE int +fi_fi_mul_overflow(long op1, long op2) +{ +#ifndef LONG64 + double op = (double)op1 * (double)op2; + + return (op > 2147483647.0 || op < -2147483648.0); +#else + int shift, sign; + long mask; + + if (op1 == 0 || op1 == 1 || op2 == 0 || op2 == 1) + return (0); + + if (op1 == MINSLONG || op2 == MINSLONG) + return (1); + + sign = (op1 < 0) ^ (op2 < 0); + + if (op1 < 0) + op1 = -op1; + if (op2 < 0) + op2 = -op2; + + for (shift = 0, mask = FI_MASK; shift < LONGSBITS; shift++, mask >>= 1) + if (op1 & mask) + break; + ++shift; + for (mask = FI_MASK; shift < LONGSBITS; shift++, mask >>= 1) + if (op2 & mask) + break; + + return (shift < LONGSBITS); +#endif +} + + +/************************************************************************ + * BIGNUM + ************************************************************************/ +static void +rbi_canonicalize(n_real *real) +{ + if (mpi_fiti(RBI(real))) { + long fi = mpi_geti(RBI(real)); + + RTYPE(real) = N_FIXNUM; + mpi_clear(RBI(real)); + XFREE(RBI(real)); + RFI(real) = fi; + } +} + + +/************************************************************************ + * RATIO + ************************************************************************/ +static void +rfr_canonicalize(n_real *real) +{ + long num, numerator, den, denominator, rest; + + num = numerator = RFRN(real); + den = denominator = RFRD(real); + if (denominator == 0) + fatal_error(DIVIDE_BY_ZERO); + + if (num == MINSLONG || den == MINSLONG) { + mpr *bigratio = XALLOC(mpr); + + mpr_init(bigratio); + mpr_seti(bigratio, num, den); + RTYPE(real) = N_BIGRATIO; + RBR(real) = bigratio; + rbr_canonicalize(real); + return; + } + + if (num < 0) + num = -num; + else if (num == 0) { + RFI(real) = 0; + RTYPE(real) = N_FIXNUM; + return; + } + for (;;) { + if ((rest = den % num) == 0) + break; + den = num; + num = rest; + } + if (den != 1) { + denominator /= num; + numerator /= num; + } + if (denominator < 0) { + numerator = -numerator; + denominator = -denominator; + } + if (denominator == 1) { + RTYPE(real) = N_FIXNUM; + RFI(real) = numerator; + } + else { + RFRN(real) = numerator; + RFRD(real) = denominator; + } +} + +static void +rbr_canonicalize(n_real *real) +{ + int fitnum, fitden; + long numerator, denominator; + + mpr_canonicalize(RBR(real)); + fitnum = mpi_fiti(RBRN(real)); + fitden = mpi_fiti(RBRD(real)); + if (fitnum && fitden) { + numerator = mpi_geti(RBRN(real)); + denominator = mpi_geti(RBRD(real)); + mpr_clear(RBR(real)); + XFREE(RBR(real)); + if (numerator == 0) { + RFI(real) = 0; + RTYPE(real) = N_FIXNUM; + } + else if (denominator == 1) { + RTYPE(real) = N_FIXNUM; + RFI(real) = numerator; + } + else { + RTYPE(real) = N_FIXRATIO; + RFRN(real) = numerator; + RFRD(real) = denominator; + } + } + else if (fitden) { + denominator = mpi_geti(RBRD(real)); + if (denominator == 1) { + mpi *bigi = XALLOC(mpi); + + mpi_init(bigi); + mpi_set(bigi, RBRN(real)); + mpr_clear(RBR(real)); + XFREE(RBR(real)); + RTYPE(real) = N_BIGNUM; + RBI(real) = bigi; + } + else if (denominator == 0) + fatal_error(DIVIDE_BY_ZERO); + } +} + + +/************************************************************************ + * COMPLEX + ************************************************************************/ +static void +ncx_canonicalize(n_number *num) +{ + if (NITYPE(num) == N_FIXNUM && NIFI(num) == 0) + num->complex = 0; +} + + +/************************************************************************ + * DIVIDE + ************************************************************************/ +#define NDIVIDE_NOP 0 +#define NDIVIDE_ADD 1 +#define NDIVIDE_SUB 2 +static void +ndivide_fi_fi(n_number *num, long div, int fun, int flo) +{ + long quo, rem; + + if (NRFI(num) == MINSLONG || div == MINSLONG) { + LispObj integer; + mpi *bignum = XALLOC(mpi); + + mpi_init(bignum); + mpi_seti(bignum, NRFI(num)); + NRBI(num) = bignum; + NRTYPE(num) = N_BIGNUM; + integer.type = LispInteger_t; + integer.data.integer = div; + ndivide_xi_xi(num, &integer, fun, flo); + return; + } + else { + quo = NRFI(num) / div; + rem = NRFI(num) % div; + } + + switch (fun) { + case NDIVIDE_CEIL: + if ((rem < 0 && div < 0) || (rem > 0 && div > 0)) { + ++quo; + rem -= div; + } + break; + case NDIVIDE_FLOOR: + if ((rem < 0 && div > 0) || (rem > 0 && div < 0)) { + --quo; + rem += div; + } + break; + case NDIVIDE_ROUND: + if (div > 0) { + if (rem > 0) { + if (rem >= (div + 1) / 2) { + ++quo; + rem -= div; + } + } + else { + if (rem <= (-div - 1) / 2) { + --quo; + rem += div; + } + } + } + else { + if (rem > 0) { + if (rem >= (-div + 1) / 2) { + --quo; + rem += div; + } + } + else { + if (rem <= (div - 1) / 2) { + ++quo; + rem -= div; + } + } + } + break; + } + + NITYPE(num) = N_FIXNUM; + NIFI(num) = rem; + if (flo) { + NRTYPE(num) = N_FLONUM; + NRFF(num) = (double)quo; + } + else + NRFI(num) = quo; +} + +static void +ndivide_xi_xi(n_number *num, LispObj *div, int fun, int flo) +{ + LispType type = OBJECT_TYPE(div); + int state = NDIVIDE_NOP, dsign, rsign; + mpi *quo, *rem; + + quo = XALLOC(mpi); + mpi_init(quo); + if (NRTYPE(num) == N_FIXNUM) + mpi_seti(quo, NRFI(num)); + else + mpi_set(quo, NRBI(num)); + + rem = XALLOC(mpi); + mpi_init(rem); + + switch (type) { + case LispFixnum_t: + mpi_seti(rem, OFI(div)); + break; + case LispInteger_t: + mpi_seti(rem, OII(div)); + break; + default: + mpi_set(rem, OBI(div)); + } + + dsign = mpi_sgn(rem); + + mpi_divqr(quo, rem, quo, rem); + rsign = mpi_sgn(rem); + + switch (fun) { + case NDIVIDE_CEIL: + if ((rsign < 0 && dsign < 0) || (rsign > 0 && dsign > 0)) + state = NDIVIDE_ADD; + break; + case NDIVIDE_FLOOR: + if ((rsign < 0 && dsign > 0) || (rsign > 0 && dsign < 0)) + state = NDIVIDE_SUB; + break; + case NDIVIDE_ROUND: { + mpi test; + + mpi_init(&test); + switch (type) { + case LispFixnum_t: + mpi_seti(&test, OFI(div)); + break; + case LispInteger_t: + mpi_seti(&test, OII(div)); + break; + default: + mpi_set(&test, OBI(div)); + } + if (dsign > 0) { + if (rsign > 0) { + mpi_addi(&test, &test, 1); + mpi_divi(&test, &test, 2); + if (mpi_cmp(rem, &test) >= 0) + state = NDIVIDE_ADD; + } + else { + mpi_neg(&test, &test); + mpi_subi(&test, &test, 1); + mpi_divi(&test, &test, 2); + if (mpi_cmp(rem, &test) <= 0) + state = NDIVIDE_SUB; + } + } + else { + if (rsign > 0) { + mpi_neg(&test, &test); + mpi_addi(&test, &test, 1); + mpi_divi(&test, &test, 2); + if (mpi_cmp(rem, &test) >= 0) + state = NDIVIDE_SUB; + } + else { + mpi_subi(&test, &test, 1); + mpi_divi(&test, &test, 2); + if (mpi_cmp(rem, &test) <= 0) + state = NDIVIDE_ADD; + } + } + mpi_clear(&test); + } break; + } + + if (state == NDIVIDE_ADD) { + mpi_addi(quo, quo, 1); + switch (type) { + case LispFixnum_t: + mpi_subi(rem, rem, OFI(div)); + break; + case LispInteger_t: + mpi_subi(rem, rem, OII(div)); + break; + default: + mpi_sub(rem, rem, OBI(div)); + } + } + else if (state == NDIVIDE_SUB) { + mpi_subi(quo, quo, 1); + switch (type) { + case LispFixnum_t: + mpi_addi(rem, rem, OFI(div)); + break; + case LispInteger_t: + mpi_addi(rem, rem, OII(div)); + break; + default: + mpi_add(rem, rem, OBI(div)); + } + } + + if (mpi_fiti(rem)) { + NITYPE(num) = N_FIXNUM; + NIFI(num) = mpi_geti(rem); + mpi_clear(rem); + XFREE(rem); + } + else { + NITYPE(num) = N_BIGNUM; + NIBI(num) = rem; + } + + clear_real(NREAL(num)); + + if (flo) { + double dval = bi_getd(quo); + + mpi_clear(quo); + XFREE(quo); + NRTYPE(num) = N_FLONUM; + NRFF(num) = dval; + } + else { + NRTYPE(num) = N_BIGNUM; + NRBI(num) = quo; + rbi_canonicalize(NREAL(num)); + } +} + +static void +ndivide_flonum(n_number *number, double num, double div, int fun, int flo) +{ + double quo, rem, modp, tmp; + + modp = modf(num / div, &quo); + rem = num - quo * div; + + switch (fun) { + case NDIVIDE_CEIL: + if ((rem < 0.0 && div < 0.0) || (rem > 0.0 && div > 0.0)) { + quo += 1.0; + rem -= div; + } + break; + case NDIVIDE_FLOOR: + if ((rem < 0.0 && div > 0.0) || (rem > 0.0 && div < 0.0)) { + quo -= 1.0; + rem += div; + } + break; + case NDIVIDE_ROUND: + if (fabs(modp) != 0.5 || modf(quo * 0.5, &tmp) != 0.0) { + if (div > 0.0) { + if (rem > 0.0) { + if (rem >= div * 0.5) { + quo += 1.0; + rem -= div; + } + } + else { + if (rem <= div * -0.5) { + quo -= 1.0; + rem += div; + } + } + } + else { + if (rem > 0.0) { + if (rem >= div * -0.5) { + quo -= 1.0; + rem += div; + } + } + else { + if (rem <= div * 0.5) { + quo += 1.0; + rem -= div; + } + } + } + } + break; + } + if (!finite(quo) || !finite(rem)) + fatal_error(FLOATING_POINT_OVERFLOW); + + NITYPE(number) = N_FLONUM; + NIFF(number) = rem; + + clear_real(NREAL(number)); + + if (flo) { + NRTYPE(number) = N_FLONUM; + NRFF(number) = quo; + } + else { + if ((long)quo == quo) { + NRTYPE(number) = N_FIXNUM; + NRFI(number) = (long)quo; + } + else { + mpi *bigi = XALLOC(mpi); + + mpi_init(bigi); + mpi_setd(bigi, quo); + NRBI(number) = bigi; + NRTYPE(number) = N_BIGNUM; + } + } +} + +static void +ndivide_xi_xr(n_number *num, LispObj *div, int fun, int flo) +{ + int state = NDIVIDE_NOP, dsign, rsign; + mpi *quo; + mpr *rem; + + quo = XALLOC(mpi); + mpi_init(quo); + if (NRTYPE(num) == N_FIXNUM) + mpi_seti(quo, NRFI(num)); + else + mpi_set(quo, NRBI(num)); + + rem = XALLOC(mpr); + mpr_init(rem); + + if (XOBJECT_TYPE(div) == LispRatio_t) + mpr_seti(rem, OFRN(div), OFRD(div)); + else + mpr_set(rem, OBR(div)); + dsign = mpi_sgn(mpr_num(rem)); + mpi_mul(quo, quo, mpr_den(rem)); + + mpi_divqr(quo, mpr_num(rem), quo, mpr_num(rem)); + mpr_canonicalize(rem); + + rsign = mpi_sgn(mpr_num(rem)); + if (mpr_fiti(rem)) { + if (mpi_geti(mpr_den(rem)) == 1) { + NITYPE(num) = N_FIXNUM; + NIFI(num) = mpi_geti(mpr_num(rem)); + } + else { + NITYPE(num) = N_FIXRATIO; + NIFRN(num) = mpi_geti(mpr_num(rem)); + NIFRD(num) = mpi_geti(mpr_den(rem)); + } + mpr_clear(rem); + XFREE(rem); + } + else { + if (mpi_fiti(mpr_den(rem)) && mpi_geti(mpr_den(rem)) == 1) { + NITYPE(num) = N_BIGNUM; + NIBI(num) = mpr_num(rem); + mpi_clear(mpr_den(rem)); + XFREE(rem); + } + else { + NITYPE(num) = N_BIGRATIO; + NIBR(num) = rem; + } + } + + switch (fun) { + case NDIVIDE_CEIL: + if ((rsign < 0 && dsign < 0) || (rsign > 0 && dsign > 0)) + state = NDIVIDE_ADD; + break; + case NDIVIDE_FLOOR: + if ((rsign < 0 && dsign > 0) || (rsign > 0 && dsign < 0)) + state = NDIVIDE_SUB; + break; + case NDIVIDE_ROUND: { + n_real cmp; + + set_real_object(&cmp, div); + div_real_real(&cmp, &two); + if (dsign > 0) { + if (rsign > 0) { + if (cmp_real_real(NIMAG(num), &cmp) >= 0) + state = NDIVIDE_ADD; + } + else { + neg_real(&cmp); + if (cmp_real_real(NIMAG(num), &cmp) <= 0) + state = NDIVIDE_SUB; + } + } + else { + if (rsign > 0) { + neg_real(&cmp); + if (cmp_real_real(NIMAG(num), &cmp) >= 0) + state = NDIVIDE_SUB; + } + else { + if (cmp_real_real(NIMAG(num), &cmp) <= 0) + state = NDIVIDE_ADD; + } + } + clear_real(&cmp); + } break; + } + + if (state == NDIVIDE_ADD) { + mpi_addi(quo, quo, 1); + sub_real_object(NIMAG(num), div); + } + else if (state == NDIVIDE_SUB) { + mpi_subi(quo, quo, 1); + add_real_object(NIMAG(num), div); + } + + clear_real(NREAL(num)); + + if (flo) { + double dval = bi_getd(quo); + + mpi_clear(quo); + XFREE(quo); + NRTYPE(num) = N_FLONUM; + NRFF(num) = dval; + } + else { + NRBI(num) = quo; + NRTYPE(num) = N_BIGNUM; + rbi_canonicalize(NREAL(num)); + } +} + +static void +ndivide_xr_xi(n_number *num, LispObj *div, int fun, int flo) +{ + LispType type = OBJECT_TYPE(div); + int state = NDIVIDE_NOP, dsign, rsign; + mpi *quo; + mpr *rem; + + quo = XALLOC(mpi); + mpi_init(quo); + switch (type) { + case LispFixnum_t: + dsign = OFI(div) < 0 ? -1 : OFI(div) > 0 ? 1 : 0; + mpi_seti(quo, OFI(div)); + break; + case LispInteger_t: + dsign = OII(div) < 0 ? -1 : OII(div) > 0 ? 1 : 0; + mpi_seti(quo, OII(div)); + break; + default: + dsign = mpi_sgn(OBI(div)); + mpi_set(quo, OBI(div)); + break; + } + + rem = XALLOC(mpr); + mpr_init(rem); + if (NRTYPE(num) == N_FIXRATIO) { + mpr_seti(rem, NRFRN(num), NRFRD(num)); + mpi_muli(quo, quo, NRFRD(num)); + } + else { + mpr_set(rem, NRBR(num)); + mpi_mul(quo, quo, NRBRD(num)); + } + mpi_divqr(quo, mpr_num(rem), mpr_num(rem), quo); + mpr_canonicalize(rem); + + rsign = mpi_sgn(mpr_num(rem)); + if (mpr_fiti(rem)) { + NITYPE(num) = N_FIXRATIO; + NIFRN(num) = mpi_geti(mpr_num(rem)); + NIFRD(num) = mpi_geti(mpr_den(rem)); + mpr_clear(rem); + XFREE(rem); + } + else { + NITYPE(num) = N_BIGRATIO; + NIBR(num) = rem; + } + + switch (fun) { + case NDIVIDE_CEIL: + if ((rsign < 0 && dsign < 0) || (rsign > 0 && dsign > 0)) + state = NDIVIDE_ADD; + break; + case NDIVIDE_FLOOR: + if ((rsign < 0 && dsign > 0) || (rsign > 0 && dsign < 0)) + state = NDIVIDE_SUB; + break; + case NDIVIDE_ROUND: { + n_real cmp; + + set_real_object(&cmp, div); + div_real_real(&cmp, &two); + if (dsign > 0) { + if (rsign > 0) { + if (cmp_real_real(NIMAG(num), &cmp) >= 0) + state = NDIVIDE_ADD; + } + else { + neg_real(&cmp); + if (cmp_real_real(NIMAG(num), &cmp) <= 0) + state = NDIVIDE_SUB; + } + } + else { + if (rsign > 0) { + neg_real(&cmp); + if (cmp_real_real(NIMAG(num), &cmp) >= 0) + state = NDIVIDE_SUB; + } + else { + if (cmp_real_real(NIMAG(num), &cmp) <= 0) + state = NDIVIDE_ADD; + } + } + clear_real(&cmp); + } break; + } + + if (state == NDIVIDE_ADD) { + mpi_addi(quo, quo, 1); + sub_real_object(NIMAG(num), div); + } + else if (state == NDIVIDE_SUB) { + mpi_subi(quo, quo, 1); + add_real_object(NIMAG(num), div); + } + + clear_real(NREAL(num)); + + if (flo) { + double dval = bi_getd(quo); + + mpi_clear(quo); + XFREE(quo); + NRTYPE(num) = N_FLONUM; + NRFF(num) = dval; + } + else { + NRBI(num) = quo; + NRTYPE(num) = N_BIGNUM; + rbi_canonicalize(NREAL(num)); + } +} + +static void +ndivide_xr_xr(n_number *num, LispObj *div, int fun, int flo) +{ + int state = NDIVIDE_NOP, dsign, rsign, modp; + mpr *bigr; + mpi *bigi; + + bigr = XALLOC(mpr); + mpr_init(bigr); + if (NRTYPE(num) == N_FIXRATIO) + mpr_seti(bigr, NRFRN(num), NRFRD(num)); + else + mpr_set(bigr, NRBR(num)); + + NITYPE(num) = N_BIGRATIO; + NIBR(num) = bigr; + + if (OBJECT_TYPE(div) == LispRatio_t) { + dsign = OFRN(div) < 0 ? -1 : OFRN(div) > 0 ? 1 : 0; + mpi_muli(mpr_num(bigr), mpr_num(bigr), OFRD(div)); + mpi_muli(mpr_den(bigr), mpr_den(bigr), OFRN(div)); + } + else { + dsign = mpi_sgn(OBRN(div)); + mpr_div(bigr, bigr, OBR(div)); + } + modp = mpi_fiti(mpr_den(bigr)) && mpi_geti(mpr_den(bigr)) == 2; + + bigi = XALLOC(mpi); + mpi_init(bigi); + mpi_divqr(bigi, mpr_num(bigr), mpr_num(bigr), mpr_den(bigr)); + + if (OBJECT_TYPE(div) == LispRatio_t) + mpi_seti(mpr_den(bigr), OFRD(div)); + else + mpi_set(mpr_den(bigr), OBRD(div)); + if (NRTYPE(num) == N_FIXRATIO) + mpi_muli(mpr_den(bigr), mpr_den(bigr), NRFRD(num)); + else + mpi_mul(mpr_den(bigr), mpr_den(bigr), NRBRD(num)); + + clear_real(NREAL(num)); + NRTYPE(num) = N_BIGNUM; + NRBI(num) = bigi; + + rbr_canonicalize(NIMAG(num)); + rsign = cmp_real_real(NIMAG(num), &zero); + + switch (fun) { + case NDIVIDE_CEIL: + if ((rsign < 0 && dsign < 0) || (rsign > 0 && dsign > 0)) + state = NDIVIDE_ADD; + break; + case NDIVIDE_FLOOR: + if ((rsign < 0 && dsign > 0) || (rsign > 0 && dsign < 0)) + state = NDIVIDE_SUB; + break; + case NDIVIDE_ROUND: + if (!modp || (bigi->digs[0] & 1) == 1) { + n_real cmp; + + set_real_object(&cmp, div); + div_real_real(&cmp, &two); + if (dsign > 0) { + if (rsign > 0) { + if (cmp_real_real(NIMAG(num), &cmp) >= 0) + state = NDIVIDE_ADD; + } + else { + neg_real(&cmp); + if (cmp_real_real(NIMAG(num), &cmp) <= 0) + state = NDIVIDE_SUB; + } + } + else { + if (rsign > 0) { + neg_real(&cmp); + if (cmp_real_real(NIMAG(num), &cmp) >= 0) + state = NDIVIDE_SUB; + } + else { + if (cmp_real_real(NIMAG(num), &cmp) <= 0) + state = NDIVIDE_ADD; + } + } + clear_real(&cmp); + } + break; + } + + if (state == NDIVIDE_ADD) { + add_real_real(NREAL(num), &one); + sub_real_object(NIMAG(num), div); + } + else if (state == NDIVIDE_SUB) { + sub_real_real(NREAL(num), &one); + add_real_object(NIMAG(num), div); + } + + if (NRTYPE(num) == N_BIGNUM) { + if (flo) { + double dval = bi_getd(bigi); + + mpi_clear(bigi); + XFREE(bigi); + NRTYPE(num) = N_FLONUM; + NRFF(num) = dval; + } + else + rbi_canonicalize(NREAL(num)); + } + else if (flo) { + NRTYPE(num) = N_FLONUM; + NRFF(num) = (double)NRFI(num); + } +} + + +/************************************************************************ + * REAL COMPLEX + ************************************************************************/ +static void +nadd_re_cx(n_number *num, LispObj *comp) +{ +/* + Ra+Rb Ib + */ + /* Ra+Rb */ + add_real_object(NREAL(num), OCXR(comp)); + + /* Ib */ + set_real_object(NIMAG(num), OCXI(comp)); + + num->complex = 1; + + ncx_canonicalize(num); +} + +static void +nsub_re_cx(n_number *num, LispObj *comp) +{ +/* + Ra-Rb -Ib + */ + /* Ra-Rb */ + sub_real_object(NREAL(num), OCXR(comp)); + + /* -Ib */ + NITYPE(num) = N_FIXNUM; + NIFI(num) = -1; + mul_real_object(NIMAG(num), OCXI(comp)); + + num->complex = 1; + + ncx_canonicalize(num); +} + +static void +nmul_re_cx(n_number *num, LispObj *comp) +{ +/* + Ra*Rb Ra*Ib + */ + /* copy before change */ + set_real_real(NIMAG(num), NREAL(num)); + + /* Ra*Rb */ + mul_real_object(NREAL(num), OCXR(comp)); + + /* Ra*Ib */ + mul_real_object(NIMAG(num), OCXI(comp)); + + num->complex = 1; + + ncx_canonicalize(num); +} + +static void +ndiv_re_cx(n_number *num, LispObj *comp) +{ +/* + Ra*Rb -Ib*Ra + ----------- ----------- + Rb*Rb+Ib*Ib Rb*Rb+Ib*Ib + */ + n_real div, temp; + + /* Rb*Rb */ + set_real_object(&div, OCXR(comp)); + mul_real_object(&div, OCXR(comp)); + + /* Ib*Ib */ + set_real_object(&temp, OCXI(comp)); + mul_real_object(&temp, OCXI(comp)); + + /* Rb*Rb+Ib*Ib */ + add_real_real(&div, &temp); + clear_real(&temp); + + /* -Ib*Ra */ + NITYPE(num) = N_FIXNUM; + NIFI(num) = -1; + mul_real_object(NIMAG(num), OCXI(comp)); + mul_real_real(NIMAG(num), NREAL(num)); + + /* Ra*Rb */ + mul_real_object(NREAL(num), OCXR(comp)); + + div_real_real(NREAL(num), &div); + div_real_real(NIMAG(num), &div); + clear_real(&div); + + num->complex = 1; + + ncx_canonicalize(num); +} + + +/************************************************************************ + * COMPLEX REAL + ************************************************************************/ +static void +nadd_cx_re(n_number *num, LispObj *re) +{ +/* + Ra+Rb Ia + */ + add_real_object(NREAL(num), re); + + ncx_canonicalize(num); +} + +static void +nsub_cx_re(n_number *num, LispObj *re) +{ +/* + Ra-Rb Ia + */ + sub_real_object(NREAL(num), re); + + ncx_canonicalize(num); +} + +static void +nmul_cx_re(n_number *num, LispObj *re) +{ +/* + Ra*Rb Ia*Rb + */ + mul_real_object(NREAL(num), re); + mul_real_object(NIMAG(num), re); + + ncx_canonicalize(num); +} + +static void +ndiv_cx_re(n_number *num, LispObj *re) +{ +/* + Ra/Rb Ia/Rb + */ + div_real_object(NREAL(num), re); + div_real_object(NIMAG(num), re); + + ncx_canonicalize(num); +} + + +/************************************************************************ + * COMPLEX COMPLEX + ************************************************************************/ +static void +nadd_cx_cx(n_number *num, LispObj *comp) +{ +/* + Ra+Rb Ia+Ib + */ + add_real_object(NREAL(num), OCXR(comp)); + add_real_object(NIMAG(num), OCXI(comp)); + + ncx_canonicalize(num); +} + +static void +nsub_cx_cx(n_number *num, LispObj *comp) +{ +/* + Ra-Rb Ia-Ib + */ + sub_real_object(NREAL(num), OCXR(comp)); + sub_real_object(NIMAG(num), OCXI(comp)); + + ncx_canonicalize(num); +} + +static void +nmul_cx_cx(n_number *num, LispObj *comp) +{ +/* + Ra*Rb-Ia*Ib Ra*Ib+Ia*Rb + */ + n_real IaIb, RaIb; + + set_real_real(&IaIb, NIMAG(num)); + mul_real_object(&IaIb, OCXI(comp)); + + set_real_real(&RaIb, NREAL(num)); + mul_real_object(&RaIb, OCXI(comp)); + + /* Ra*Rb-Ia*Ib */ + mul_real_object(NREAL(num), OCXR(comp)); + sub_real_real(NREAL(num), &IaIb); + clear_real(&IaIb); + + /* Ra*Ib+Ia*Rb */ + mul_real_object(NIMAG(num), OCXR(comp)); + add_real_real(NIMAG(num), &RaIb); + clear_real(&RaIb); + + ncx_canonicalize(num); +} + +static void +ndiv_cx_cx(n_number *num, LispObj *comp) +{ +/* + Ra*Rb+Ia*Ib Ia*Rb-Ib*Ra + ----------- ----------- + Rb*Rb+Ib*Ib Rb*Rb+Ib*Ib + */ + n_real temp1, temp2; + + /* IaIb */ + set_real_real(&temp1, NIMAG(num)); + mul_real_object(&temp1, OCXI(comp)); + + /* IbRa */ + set_real_real(&temp2, NREAL(num)); + mul_real_object(&temp2, OCXI(comp)); + + /* Ra*Rb+Ia*Ib */ + mul_real_object(NREAL(num), OCXR(comp)); + add_real_real(NREAL(num), &temp1); + clear_real(&temp1); + + /* Ia*Rb-Ib*Ra */ + mul_real_object(NIMAG(num), OCXR(comp)); + sub_real_real(NIMAG(num), &temp2); + clear_real(&temp2); + + + /* Rb*Rb */ + set_real_object(&temp1, OCXR(comp)); + mul_real_object(&temp1, OCXR(comp)); + + /* Ib*Ib */ + set_real_object(&temp2, OCXI(comp)); + mul_real_object(&temp2, OCXI(comp)); + + /* Rb*Rb+Ib*Ib */ + add_real_real(&temp1, &temp2); + clear_real(&temp2); + + div_real_real(NREAL(num), &temp1); + div_real_real(NIMAG(num), &temp1); + clear_real(&temp1); + + ncx_canonicalize(num); +} + +static int +cmp_cx_cx(LispObj *op1, LispObj *op2) +{ + int cmp; + + cmp = cmp_object_object(OCXR(op1), OCXR(op2), 1); + if (cmp == 0) + cmp = cmp_object_object(OCXI(op1), OCXI(op2), 1); + + return (cmp); +} + + +/************************************************************************ + * FLONUM FLONUM + ************************************************************************/ +static void +radd_flonum(n_real *real, double op1, double op2) +{ + double value = op1 + op2; + + if (!finite(value)) + fatal_error(FLOATING_POINT_OVERFLOW); + switch (RTYPE(real)) { + case N_FIXNUM: + case N_FIXRATIO: + RTYPE(real) = N_FLONUM; + break; + case N_BIGNUM: + RCLEAR_BI(real); + RTYPE(real) = N_FLONUM; + break; + case N_BIGRATIO: + RCLEAR_BR(real); + RTYPE(real) = N_FLONUM; + break; + } + RFF(real) = value; +} + +static void +rsub_flonum(n_real *real, double op1, double op2) +{ + double value = op1 - op2; + + if (!finite(value)) + fatal_error(FLOATING_POINT_OVERFLOW); + switch (RTYPE(real)) { + case N_FIXNUM: + case N_FIXRATIO: + RTYPE(real) = N_FLONUM; + break; + case N_BIGNUM: + RCLEAR_BI(real); + RTYPE(real) = N_FLONUM; + break; + case N_BIGRATIO: + RCLEAR_BR(real); + RTYPE(real) = N_FLONUM; + break; + } + RFF(real) = value; +} + +static void +rmul_flonum(n_real *real, double op1, double op2) +{ + double value = op1 * op2; + + if (!finite(value)) + fatal_error(FLOATING_POINT_OVERFLOW); + switch (RTYPE(real)) { + case N_FIXNUM: + case N_FIXRATIO: + RTYPE(real) = N_FLONUM; + break; + case N_BIGNUM: + RCLEAR_BI(real); + RTYPE(real) = N_FLONUM; + break; + case N_BIGRATIO: + RCLEAR_BR(real); + RTYPE(real) = N_FLONUM; + break; + } + RFF(real) = value; +} + +static void +rdiv_flonum(n_real *real, double op1, double op2) +{ + double value; + + if (op2 == 0.0) + fatal_error(DIVIDE_BY_ZERO); + value = op1 / op2; + if (!finite(value)) + fatal_error(FLOATING_POINT_OVERFLOW); + switch (RTYPE(real)) { + case N_FIXNUM: + case N_FIXRATIO: + RTYPE(real) = N_FLONUM; + break; + case N_BIGNUM: + RCLEAR_BI(real); + RTYPE(real) = N_FLONUM; + break; + case N_BIGRATIO: + RCLEAR_BR(real); + RTYPE(real) = N_FLONUM; + break; + } + RFF(real) = value; +} + +static int +cmp_flonum(double op1, double op2) +{ + double value = op1 - op2; + + if (!finite(value)) + fatal_error(FLOATING_POINT_OVERFLOW); + + return (value > 0.0 ? 1 : value < 0.0 ? -1 : 0); +} + + +/************************************************************************ + * FIXNUM FIXNUM + ************************************************************************/ +static void +rop_fi_fi_bi(n_real *real, long fi, int op) +{ + mpi *bigi = XALLOC(mpi); + + mpi_init(bigi); + mpi_seti(bigi, RFI(real)); + if (op == NOP_ADD) + mpi_addi(bigi, bigi, fi); + else if (op == NOP_SUB) + mpi_subi(bigi, bigi, fi); + else + mpi_muli(bigi, bigi, fi); + RBI(real) = bigi; + RTYPE(real) = N_BIGNUM; +} + +static INLINE void +radd_fi_fi(n_real *real, long fi) +{ + if (!fi_fi_add_overflow(RFI(real), fi)) + RFI(real) += fi; + else + rop_fi_fi_bi(real, fi, NOP_ADD); +} + +static INLINE void +rsub_fi_fi(n_real *real, long fi) +{ + if (!fi_fi_sub_overflow(RFI(real), fi)) + RFI(real) -= fi; + else + rop_fi_fi_bi(real, fi, NOP_SUB); +} + +static INLINE void +rmul_fi_fi(n_real *real, long fi) +{ + if (!fi_fi_mul_overflow(RFI(real), fi)) + RFI(real) *= fi; + else + rop_fi_fi_bi(real, fi, NOP_MUL); +} + +static INLINE void +rdiv_fi_fi(n_real *real, long fi) +{ + RTYPE(real) = N_FIXRATIO; + RFRN(real) = RFI(real); + RFRD(real) = fi; + rfr_canonicalize(real); +} + +static INLINE int +cmp_fi_fi(long op1, long op2) +{ + if (op1 > op2) + return (1); + else if (op1 < op2) + return (-1); + + return (0); +} + + +/************************************************************************ + * FIXNUM BIGNUM + ************************************************************************/ +static void +rop_fi_bi_xi(n_real *real, mpi *bi, int nop) +{ + mpi *bigi = XALLOC(mpi); + + mpi_init(bigi); + mpi_seti(bigi, RFI(real)); + if (nop == NOP_ADD) + mpi_add(bigi, bigi, bi); + else if (nop == NOP_SUB) + mpi_sub(bigi, bigi, bi); + else + mpi_mul(bigi, bigi, bi); + + if (mpi_fiti(bigi)) { + RFI(real) = mpi_geti(bigi); + mpi_clear(bigi); + XFREE(bigi); + } + else { + RBI(real) = bigi; + RTYPE(real) = N_BIGNUM; + } +} + +static INLINE void +radd_fi_bi(n_real *real, mpi *bi) +{ + rop_fi_bi_xi(real, bi, NOP_ADD); +} + +static INLINE void +rsub_fi_bi(n_real *real, mpi *bi) +{ + rop_fi_bi_xi(real, bi, NOP_SUB); +} + +static INLINE void +rmul_fi_bi(n_real *real, mpi *bi) +{ + rop_fi_bi_xi(real, bi, NOP_MUL); +} + +static void +rdiv_fi_bi(n_real *real, mpi *bi) +{ + mpr *bigr; + + if (mpi_cmpi(bi, 0) == 0) + fatal_error(DIVIDE_BY_ZERO); + + bigr = XALLOC(mpr); + mpr_init(bigr); + mpi_seti(mpr_num(bigr), RFI(real)); + mpi_set(mpr_den(bigr), bi); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static INLINE int +cmp_fi_bi(long fixnum, mpi *bignum) +{ + return (-mpi_cmpi(bignum, fixnum)); +} + + +/************************************************************************ + * FIXNUM FIXRATIO + ************************************************************************/ +static void +rop_fi_fr_as_xr(n_real *real, long num, long den, int nop) +{ + int fit; + long value = 0, op = RFI(real); + + fit = !fi_fi_mul_overflow(op, den); + if (fit) { + value = op * den; + if (nop == NOP_ADD) + fit = !fi_fi_add_overflow(value, num); + else + fit = !fi_fi_sub_overflow(value, num); + } + if (fit) { + if (nop == NOP_ADD) + RFRN(real) = value + num; + else + RFRN(real) = value - num; + RFRD(real) = den; + RTYPE(real) = N_FIXRATIO; + rfr_canonicalize(real); + } + else { + mpi iop; + mpr *bigr = XALLOC(mpr); + + mpi_init(&iop); + mpi_seti(&iop, op); + mpi_muli(&iop, &iop, den); + + mpr_init(bigr); + mpr_seti(bigr, num, den); + if (nop == NOP_ADD) + mpi_add(mpr_num(bigr), &iop, mpr_num(bigr)); + else + mpi_sub(mpr_num(bigr), &iop, mpr_num(bigr)); + mpi_clear(&iop); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); + } +} + +static void +rop_fi_fr_md_xr(n_real *real, long num, long den, int nop) +{ + int fit; + long op = RFI(real); + + if (nop == NOP_MUL) + fit = !fi_fi_mul_overflow(op, num); + else + fit = !fi_fi_mul_overflow(op, den); + if (fit) { + if (nop == NOP_MUL) { + RFRN(real) = op * num; + RFRD(real) = den; + } + else { + RFRN(real) = op * den; + RFRD(real) = num; + } + RTYPE(real) = N_FIXRATIO; + rfr_canonicalize(real); + } + else { + mpi iop; + mpr *bigr = XALLOC(mpr); + + mpi_init(&iop); + mpi_seti(&iop, op); + + mpr_init(bigr); + if (nop == NOP_MUL) + mpr_seti(bigr, num, den); + else + mpr_seti(bigr, den, num); + mpi_mul(mpr_num(bigr), mpr_num(bigr), &iop); + mpi_clear(&iop); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); + } +} + +static INLINE void +radd_fi_fr(n_real *real, long num, long den) +{ + rop_fi_fr_as_xr(real, num, den, NOP_ADD); +} + +static INLINE void +rsub_fi_fr(n_real *real, long num, long den) +{ + rop_fi_fr_as_xr(real, num, den, NOP_SUB); +} + +static INLINE void +rmul_fi_fr(n_real *real, long num, long den) +{ + rop_fi_fr_md_xr(real, num, den, NOP_MUL); +} + +static INLINE void +rdiv_fi_fr(n_real *real, long num, long den) +{ + rop_fi_fr_md_xr(real, num, den, NOP_DIV); +} + +static INLINE int +cmp_fi_fr(long fi, long num, long den) +{ + return (cmp_flonum((double)fi, (double)num / (double)den)); +} + + +/************************************************************************ + * FIXNUM BIGRATIO + ************************************************************************/ +static void +rop_fi_br_as_xr(n_real *real, mpr *ratio, int nop) +{ + mpi iop; + mpr *bigr = XALLOC(mpr); + + mpi_init(&iop); + mpi_seti(&iop, RFI(real)); + + mpr_init(bigr); + mpr_set(bigr, ratio); + + mpi_mul(&iop, &iop, mpr_den(ratio)); + if (nop == NOP_ADD) + mpi_add(mpr_num(bigr), &iop, mpr_num(bigr)); + else + mpi_sub(mpr_num(bigr), &iop, mpr_num(bigr)); + + mpi_clear(&iop); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static void +rop_fi_br_md_xr(n_real *real, mpr *ratio, int nop) +{ + mpi iop; + mpr *bigr = XALLOC(mpr); + + mpi_init(&iop); + mpi_seti(&iop, RFI(real)); + + mpr_init(bigr); + if (nop == NOP_MUL) + mpr_set(bigr, ratio); + else + mpr_inv(bigr, ratio); + + mpi_mul(mpr_num(bigr), &iop, mpr_num(bigr)); + + mpi_clear(&iop); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static INLINE void +radd_fi_br(n_real *real, mpr *ratio) +{ + rop_fi_br_as_xr(real, ratio, NOP_ADD); +} + +static INLINE void +rsub_fi_br(n_real *real, mpr *ratio) +{ + rop_fi_br_as_xr(real, ratio, NOP_SUB); +} + +static INLINE void +rmul_fi_br(n_real *real, mpr *ratio) +{ + rop_fi_br_md_xr(real, ratio, NOP_MUL); +} + +static INLINE void +rdiv_fi_br(n_real *real, mpr *ratio) +{ + rop_fi_br_md_xr(real, ratio, NOP_DIV); +} + +static INLINE int +cmp_fi_br(long op1, mpr *op2) +{ + return (-mpr_cmpi(op2, op1)); +} + + +/************************************************************************ + * BIGNUM FIXNUM + ************************************************************************/ +static INLINE void +radd_bi_fi(n_real *real, long fi) +{ + mpi_addi(RBI(real), RBI(real), fi); + rbi_canonicalize(real); +} + +static INLINE void +rsub_bi_fi(n_real *real, long fi) +{ + mpi_subi(RBI(real), RBI(real), fi); + rbi_canonicalize(real); +} + +static INLINE void +rmul_bi_fi(n_real *real, long fi) +{ + mpi_muli(RBI(real), RBI(real), fi); + rbi_canonicalize(real); +} + +static void +rdiv_bi_fi(n_real *real, long fi) +{ + mpr *bigr; + + if (RFI(real) == 0) + fatal_error(DIVIDE_BY_ZERO); + + bigr = XALLOC(mpr); + mpr_init(bigr); + mpi_set(mpr_num(bigr), RBI(real)); + mpi_seti(mpr_den(bigr), fi); + RCLEAR_BI(real); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static INLINE int +cmp_bi_fi(mpi *bignum, long fi) +{ + return (mpi_cmpi(bignum, fi)); +} + + +/************************************************************************ + * BIGNUM BIGNUM + ************************************************************************/ +static INLINE void +radd_bi_bi(n_real *real, mpi *bignum) +{ + mpi_add(RBI(real), RBI(real), bignum); + rbi_canonicalize(real); +} + +static INLINE void +rsub_bi_bi(n_real *real, mpi *bignum) +{ + mpi_sub(RBI(real), RBI(real), bignum); + rbi_canonicalize(real); +} + +static INLINE void +rmul_bi_bi(n_real *real, mpi *bignum) +{ + mpi_mul(RBI(real), RBI(real), bignum); + rbi_canonicalize(real); +} + +static void +rdiv_bi_bi(n_real *real, mpi *bignum) +{ + mpr *bigr; + + if (mpi_cmpi(bignum, 0) == 0) + fatal_error(DIVIDE_BY_ZERO); + + bigr = XALLOC(mpr); + mpr_init(bigr); + mpi_set(mpr_num(bigr), RBI(real)); + mpi_set(mpr_den(bigr), bignum); + RCLEAR_BI(real); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static INLINE int +cmp_bi_bi(mpi *op1, mpi *op2) +{ + return (mpi_cmp(op1, op2)); +} + + +/************************************************************************ + * BIGNUM FIXRATIO + ************************************************************************/ +static void +rop_bi_fr_as_xr(n_real *real, long num, long den, int nop) +{ + mpi iop; + mpr *bigr = XALLOC(mpr); + + mpi_init(&iop); + mpi_set(&iop, RBI(real)); + mpi_muli(&iop, &iop, den); + + mpr_init(bigr); + mpr_seti(bigr, num, den); + + if (nop == NOP_ADD) + mpi_add(mpr_num(bigr), &iop, mpr_num(bigr)); + else + mpi_sub(mpr_num(bigr), &iop, mpr_num(bigr)); + mpi_clear(&iop); + + RCLEAR_BI(real); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static INLINE void +rop_bi_fr_md_xr(n_real *real, long num, long den, int nop) +{ + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + + mpr_seti(bigr, num, den); + + if (nop == NOP_MUL) + mpi_mul(mpr_num(bigr), RBI(real), mpr_num(bigr)); + else { + mpi_mul(mpr_den(bigr), RBI(real), mpr_den(bigr)); + mpr_inv(bigr, bigr); + } + + RCLEAR_BI(real); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static INLINE void +radd_bi_fr(n_real *real, long num, long den) +{ + rop_bi_fr_as_xr(real, num, den, NOP_ADD); +} + +static INLINE void +rsub_bi_fr(n_real *real, long num, long den) +{ + rop_bi_fr_as_xr(real, num, den, NOP_SUB); +} + +static INLINE void +rmul_bi_fr(n_real *real, long num, long den) +{ + rop_bi_fr_md_xr(real, num, den, NOP_MUL); +} + +static INLINE void +rdiv_bi_fr(n_real *real, long num, long den) +{ + rop_bi_fr_md_xr(real, num, den, NOP_DIV); +} + +static int +cmp_bi_fr(mpi *bignum, long num, long den) +{ + int cmp; + mpr cmp1, cmp2; + + mpr_init(&cmp1); + mpi_set(mpr_num(&cmp1), bignum); + mpi_seti(mpr_den(&cmp1), 1); + + mpr_init(&cmp2); + mpr_seti(&cmp2, num, den); + + cmp = mpr_cmp(&cmp1, &cmp2); + mpr_clear(&cmp1); + mpr_clear(&cmp2); + + return (cmp); +} + + +/************************************************************************ + * BIGNUM BIGRATIO + ************************************************************************/ +static void +rop_bi_br_as_xr(n_real *real, mpr *bigratio, int nop) +{ + mpi iop; + mpr *bigr = XALLOC(mpr); + + mpi_init(&iop); + mpi_set(&iop, RBI(real)); + mpr_init(bigr); + mpr_set(bigr, bigratio); + + mpi_mul(&iop, &iop, mpr_den(bigratio)); + + if (nop == NOP_ADD) + mpi_add(mpr_num(bigr), &iop, mpr_num(bigr)); + else + mpi_sub(mpr_num(bigr), &iop, mpr_num(bigr)); + mpi_clear(&iop); + + RCLEAR_BI(real); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static void +rop_bi_br_md_xr(n_real *real, mpr *bigratio, int nop) +{ + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + if (nop == NOP_MUL) + mpr_set(bigr, bigratio); + else + mpr_inv(bigr, bigratio); + + mpi_mul(mpr_num(bigr), RBI(real), mpr_num(bigr)); + + RCLEAR_BI(real); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static INLINE void +radd_bi_br(n_real *real, mpr *bigratio) +{ + rop_bi_br_as_xr(real, bigratio, NOP_ADD); +} + +static INLINE void +rsub_bi_br(n_real *real, mpr *bigratio) +{ + rop_bi_br_as_xr(real, bigratio, NOP_SUB); +} + +static INLINE void +rmul_bi_br(n_real *real, mpr *bigratio) +{ + rop_bi_br_md_xr(real, bigratio, NOP_MUL); +} + +static INLINE void +rdiv_bi_br(n_real *real, mpr *bigratio) +{ + rop_bi_br_md_xr(real, bigratio, NOP_DIV); +} + +static int +cmp_bi_br(mpi *bignum, mpr *bigratio) +{ + int cmp; + mpr cmp1; + + mpr_init(&cmp1); + mpi_set(mpr_num(&cmp1), bignum); + mpi_seti(mpr_den(&cmp1), 1); + + cmp = mpr_cmp(&cmp1, bigratio); + mpr_clear(&cmp1); + + return (cmp); +} + + +/************************************************************************ + * FIXRATIO FIXNUM + ************************************************************************/ +static void +rop_fr_fi_as_xr(n_real *real, long op, int nop) +{ + int fit; + long value = 0, num = RFRN(real), den = RFRD(real); + + fit = !fi_fi_mul_overflow(op, den); + + if (fit) { + value = op * den; + if (nop == NOP_ADD) + fit = !fi_fi_add_overflow(value, num); + else + fit = !fi_fi_sub_overflow(value, num); + } + if (fit) { + if (nop == NOP_ADD) + RFRN(real) = num + value; + else + RFRN(real) = num - value; + rfr_canonicalize(real); + } + else { + mpi iop; + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + mpr_seti(bigr, num, den); + mpi_init(&iop); + mpi_seti(&iop, op); + mpi_muli(&iop, &iop, den); + if (nop == NOP_ADD) + mpi_add(mpr_num(bigr), mpr_num(bigr), &iop); + else + mpi_sub(mpr_num(bigr), mpr_num(bigr), &iop); + mpi_clear(&iop); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); + } +} + +static void +rop_fr_fi_md_xr(n_real *real, long op, int nop) +{ + long num = RFRN(real), den = RFRD(real); + + if (nop == NOP_MUL) { + if (!fi_fi_mul_overflow(op, num)) { + RFRN(real) = op * num; + rfr_canonicalize(real); + return; + } + } + else if (!fi_fi_mul_overflow(op, den)) { + RFRD(real) = op * den; + rfr_canonicalize(real); + return; + } + + { + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + mpr_seti(bigr, num, den); + if (nop == NOP_MUL) + mpr_muli(bigr, bigr, op); + else + mpr_divi(bigr, bigr, op); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); + } +} + +static INLINE void +radd_fr_fi(n_real *real, long op) +{ + rop_fr_fi_as_xr(real, op, NOP_ADD); +} + +static INLINE void +rsub_fr_fi(n_real *real, long op) +{ + rop_fr_fi_as_xr(real, op, NOP_SUB); +} + +static INLINE void +rmul_fr_fi(n_real *real, long op) +{ + rop_fr_fi_md_xr(real, op, NOP_MUL); +} + +static INLINE void +rdiv_fr_fi(n_real *real, long op) +{ + rop_fr_fi_md_xr(real, op, NOP_DIV); +} + +static INLINE int +cmp_fr_fi(long num, long den, long fixnum) +{ + return (cmp_flonum((double)num / (double)den, (double)fixnum)); +} + + +/************************************************************************ + * FIXRATIO BIGNUM + ************************************************************************/ +static void +rop_fr_bi_as_xr(n_real *real, mpi *bignum, int nop) +{ + mpi iop; + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + mpr_seti(bigr, RFRN(real), RFRD(real)); + + mpi_init(&iop); + mpi_set(&iop, bignum); + mpi_muli(&iop, &iop, RFRD(real)); + + if (nop == NOP_ADD) + mpi_add(mpr_num(bigr), mpr_num(bigr), &iop); + else + mpi_sub(mpr_num(bigr), mpr_num(bigr), &iop); + mpi_clear(&iop); + + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static void +rop_fr_bi_md_xr(n_real *real, mpi *bignum, int nop) +{ + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + mpr_seti(bigr, RFRN(real), RFRD(real)); + + if (nop == NOP_MUL) + mpi_mul(mpr_num(bigr), mpr_num(bigr), bignum); + else + mpi_mul(mpr_den(bigr), mpr_den(bigr), bignum); + + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static INLINE void +radd_fr_bi(n_real *real, mpi *bignum) +{ + rop_fr_bi_as_xr(real, bignum, NOP_ADD); +} + +static INLINE void +rsub_fr_bi(n_real *real, mpi *bignum) +{ + rop_fr_bi_as_xr(real, bignum, NOP_SUB); +} + +static INLINE void +rmul_fr_bi(n_real *real, mpi *bignum) +{ + rop_fr_bi_md_xr(real, bignum, NOP_MUL); +} + +static INLINE void +rdiv_fr_bi(n_real *real, mpi *bignum) +{ + rop_fr_bi_md_xr(real, bignum, NOP_DIV); +} + +static int +cmp_fr_bi(long num, long den, mpi *bignum) +{ + int cmp; + mpr cmp1, cmp2; + + mpr_init(&cmp1); + mpr_seti(&cmp1, num, den); + + mpr_init(&cmp2); + mpi_set(mpr_num(&cmp2), bignum); + mpi_seti(mpr_den(&cmp2), 1); + + cmp = mpr_cmp(&cmp1, &cmp2); + mpr_clear(&cmp1); + mpr_clear(&cmp2); + + return (cmp); +} + + +/************************************************************************ + * FIXRATIO FIXRATIO + ************************************************************************/ +static void +rop_fr_fr_as_xr(n_real *real, long num2, long den2, int nop) +{ + int fit; + long num1 = RFRN(real), den1 = RFRD(real), num = 0, den = 0; + + fit = !fi_fi_mul_overflow(num1, den2); + if (fit) { + num = num1 * den2; + fit = !fi_fi_mul_overflow(num2, den1); + if (fit) { + den = num2 * den1; + if (nop == NOP_ADD) { + if ((fit = !fi_fi_add_overflow(num, den)) != 0) + num += den; + } + else if ((fit = !fi_fi_sub_overflow(num, den)) != 0) + num -= den; + if (fit) { + fit = !fi_fi_mul_overflow(den1, den2); + if (fit) + den = den1 * den2; + } + } + } + if (fit) { + RFRN(real) = num; + RFRD(real) = den; + rfr_canonicalize(real); + } + else { + mpi iop; + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + mpr_seti(bigr, num1, den1); + mpi_muli(mpr_den(bigr), mpr_den(bigr), den2); + mpi_init(&iop); + mpi_seti(&iop, num2); + mpi_muli(&iop, &iop, den1); + mpi_muli(mpr_num(bigr), mpr_num(bigr), den2); + if (nop == NOP_ADD) + mpi_add(mpr_num(bigr), mpr_num(bigr), &iop); + else + mpi_sub(mpr_num(bigr), mpr_num(bigr), &iop); + mpi_clear(&iop); + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); + } +} + +static void +rop_fr_fr_md_xr(n_real *real, long num2, long den2, int nop) +{ + int fit; + long num1 = RFRN(real), den1 = RFRD(real), num = 0, den = 0; + + if (nop == NOP_MUL) { + fit = !fi_fi_mul_overflow(num1, num2) && !fi_fi_mul_overflow(den1, den2); + if (fit) { + num = num1 * num2; + den = den1 * den2; + } + } + else { + fit = !fi_fi_mul_overflow(num1, den2) && !fi_fi_mul_overflow(den1, num2); + if (fit) { + num = num1 * den2; + den = den1 * num2; + } + } + + if (fit) { + RFRN(real) = num; + RFRD(real) = den; + rfr_canonicalize(real); + } + else { + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + + if (nop == NOP_MUL) { + mpr_seti(bigr, num1, den1); + mpi_muli(mpr_num(bigr), mpr_num(bigr), num2); + mpi_muli(mpr_den(bigr), mpr_den(bigr), den2); + } + else { + mpr_seti(bigr, num1, num2); + mpi_muli(mpr_num(bigr), mpr_num(bigr), den2); + mpi_muli(mpr_den(bigr), mpr_den(bigr), den1); + } + + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); + } +} + +static INLINE void +radd_fr_fr(n_real *real, long num, long den) +{ + rop_fr_fr_as_xr(real, num, den, NOP_ADD); +} + +static INLINE void +rsub_fr_fr(n_real *real, long num, long den) +{ + rop_fr_fr_as_xr(real, num, den, NOP_SUB); +} + +static INLINE void +rmul_fr_fr(n_real *real, long num, long den) +{ + rop_fr_fr_md_xr(real, num, den, NOP_MUL); +} + +static INLINE void +rdiv_fr_fr(n_real *real, long num, long den) +{ + rop_fr_fr_md_xr(real, num, den, NOP_DIV); +} + +static INLINE int +cmp_fr_fr(long num1, long den1, long num2, long den2) +{ + return (cmp_flonum((double)num1 / (double)den1, + (double)num2 / (double)den2)); +} + + +/************************************************************************ + * FIXRATIO BIGRATIO + ************************************************************************/ +static void +rop_fr_br_asmd_xr(n_real *real, mpr *bigratio, int nop) +{ + mpr *bigr = XALLOC(mpr); + + mpr_init(bigr); + mpr_seti(bigr, RFRN(real), RFRD(real)); + + switch (nop) { + case NOP_ADD: + mpr_add(bigr, bigr, bigratio); + break; + case NOP_SUB: + mpr_sub(bigr, bigr, bigratio); + break; + case NOP_MUL: + mpr_mul(bigr, bigr, bigratio); + break; + default: + mpr_div(bigr, bigr, bigratio); + break; + } + + RBR(real) = bigr; + RTYPE(real) = N_BIGRATIO; + rbr_canonicalize(real); +} + +static INLINE void +radd_fr_br(n_real *real, mpr *bigratio) +{ + rop_fr_br_asmd_xr(real, bigratio, NOP_ADD); +} + +static INLINE void +rsub_fr_br(n_real *real, mpr *bigratio) +{ + rop_fr_br_asmd_xr(real, bigratio, NOP_SUB); +} + +static INLINE void +rmul_fr_br(n_real *real, mpr *bigratio) +{ + rop_fr_br_asmd_xr(real, bigratio, NOP_MUL); +} + +static INLINE void +rdiv_fr_br(n_real *real, mpr *bigratio) +{ + rop_fr_br_asmd_xr(real, bigratio, NOP_DIV); +} + +static int +cmp_fr_br(long num, long den, mpr *bigratio) +{ + int cmp; + mpr cmp1; + + mpr_init(&cmp1); + mpr_seti(&cmp1, num, den); + + cmp = mpr_cmp(&cmp1, bigratio); + mpr_clear(&cmp1); + + return (cmp); +} + + +/************************************************************************ + * BIGRATIO FIXNUM + ************************************************************************/ +static void +rop_br_fi_asmd_xr(n_real *real, long fixnum, int nop) +{ + mpr *bigratio = RBR(real); + + switch (nop) { + case NOP_ADD: + mpr_addi(bigratio, bigratio, fixnum); + break; + case NOP_SUB: + mpr_subi(bigratio, bigratio, fixnum); + break; + case NOP_MUL: + mpr_muli(bigratio, bigratio, fixnum); + break; + default: + if (fixnum == 0) + fatal_error(DIVIDE_BY_ZERO); + mpr_divi(bigratio, bigratio, fixnum); + break; + } + rbr_canonicalize(real); +} + +static INLINE void +radd_br_fi(n_real *real, long fixnum) +{ + rop_br_fi_asmd_xr(real, fixnum, NOP_ADD); +} + +static INLINE void +rsub_br_fi(n_real *real, long fixnum) +{ + rop_br_fi_asmd_xr(real, fixnum, NOP_SUB); +} + +static INLINE void +rmul_br_fi(n_real *real, long fixnum) +{ + rop_br_fi_asmd_xr(real, fixnum, NOP_MUL); +} + +static INLINE void +rdiv_br_fi(n_real *real, long fixnum) +{ + rop_br_fi_asmd_xr(real, fixnum, NOP_DIV); +} + +static int +cmp_br_fi(mpr *bigratio, long fixnum) +{ + int cmp; + mpr cmp2; + + mpr_init(&cmp2); + mpr_seti(&cmp2, fixnum, 1); + cmp = mpr_cmp(bigratio, &cmp2); + mpr_clear(&cmp2); + + return (cmp); +} + + +/************************************************************************ + * BIGRATIO BIGNUM + ************************************************************************/ +static void +rop_br_bi_as_xr(n_real *real, mpi *bignum, int nop) +{ + mpi iop; + + mpi_init(&iop); + mpi_set(&iop, bignum); + + mpi_mul(&iop, &iop, RBRD(real)); + if (nop == NOP_ADD) + mpi_add(RBRN(real), RBRN(real), &iop); + else + mpi_sub(RBRN(real), RBRN(real), &iop); + mpi_clear(&iop); + rbr_canonicalize(real); +} + +static INLINE void +radd_br_bi(n_real *real, mpi *bignum) +{ + rop_br_bi_as_xr(real, bignum, NOP_ADD); +} + +static INLINE void +rsub_br_bi(n_real *real, mpi *bignum) +{ + rop_br_bi_as_xr(real, bignum, NOP_SUB); +} + +static INLINE void +rmul_br_bi(n_real *real, mpi *bignum) +{ + mpi_mul(RBRN(real), RBRN(real), bignum); + rbr_canonicalize(real); +} + +static INLINE void +rdiv_br_bi(n_real *real, mpi *bignum) +{ + mpi_mul(RBRD(real), RBRD(real), bignum); + rbr_canonicalize(real); +} + +static int +cmp_br_bi(mpr *bigratio, mpi *bignum) +{ + int cmp; + mpr cmp1; + + mpr_init(&cmp1); + mpi_set(mpr_num(&cmp1), bignum); + mpi_seti(mpr_den(&cmp1), 1); + + cmp = mpr_cmp(bigratio, &cmp1); + mpr_clear(&cmp1); + + return (cmp); +} + + +/************************************************************************ + * BIGRATIO FIXRATIO + ************************************************************************/ +static void +rop_br_fr_asmd_xr(n_real *real, long num, long den, int nop) +{ + mpr *bigratio = RBR(real), rop; + + mpr_init(&rop); + mpr_seti(&rop, num, den); + switch (nop) { + case NOP_ADD: + mpr_add(bigratio, bigratio, &rop); + break; + case NOP_SUB: + mpr_sub(bigratio, bigratio, &rop); + break; + case NOP_MUL: + mpr_mul(bigratio, bigratio, &rop); + break; + default: + mpr_div(bigratio, bigratio, &rop); + break; + } + mpr_clear(&rop); + rbr_canonicalize(real); +} + +static INLINE void +radd_br_fr(n_real *real, long num, long den) +{ + rop_br_fr_asmd_xr(real, num, den, NOP_ADD); +} + +static INLINE void +rsub_br_fr(n_real *real, long num, long den) +{ + rop_br_fr_asmd_xr(real, num, den, NOP_SUB); +} + +static INLINE void +rmul_br_fr(n_real *real, long num, long den) +{ + rop_br_fr_asmd_xr(real, num, den, NOP_MUL); +} + +static INLINE void +rdiv_br_fr(n_real *real, long num, long den) +{ + rop_br_fr_asmd_xr(real, num, den, NOP_DIV); +} + +static int +cmp_br_fr(mpr *bigratio, long num, long den) +{ + int cmp; + mpr cmp2; + + mpr_init(&cmp2); + mpr_seti(&cmp2, num, den); + cmp = mpr_cmp(bigratio, &cmp2); + mpr_clear(&cmp2); + + return (cmp); +} + + +/************************************************************************ + * BIGRATIO BIGRATIO + ************************************************************************/ +static INLINE void +radd_br_br(n_real *real, mpr *bigratio) +{ + mpr_add(RBR(real), RBR(real), bigratio); + rbr_canonicalize(real); +} + +static INLINE void +rsub_br_br(n_real *real, mpr *bigratio) +{ + mpr_sub(RBR(real), RBR(real), bigratio); + rbr_canonicalize(real); +} + +static INLINE void +rmul_br_br(n_real *real, mpr *bigratio) +{ + mpr_mul(RBR(real), RBR(real), bigratio); + rbr_canonicalize(real); +} + +static INLINE void +rdiv_br_br(n_real *real, mpr *bigratio) +{ + mpr_div(RBR(real), RBR(real), bigratio); + rbr_canonicalize(real); +} + +static INLINE int +cmp_br_br(mpr *op1, mpr *op2) +{ + return (mpr_cmp(op1, op2)); +} diff --git a/lisp/modules/indent.lsp b/lisp/modules/indent.lsp new file mode 100644 index 0000000..4a7f7aa --- /dev/null +++ b/lisp/modules/indent.lsp @@ -0,0 +1,1420 @@ +; +;; Copyright (c) 2002 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/modules/indent.lsp,v 1.7 2003/01/29 03:05:53 paulo Exp $ +;; + +(provide "indent") +(require "xedit") +(in-package "XEDIT") + +(defconstant indent-spaces '(#\Tab #\Space)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The final indentation function. +;; Parameters: +;; indent +;; Number of spaces to insert +;; offset +;; Offset to where indentation should be added +;; no-tabs +;; If set, tabs aren't inserted +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indent-text (indent offset &optional no-tabs + &aux start line length index current tabs spaces string + barrier base result (point (point)) + ) + + ;; Initialize + (setq + start (scan offset :eol :left) + line (read-text start (- offset start)) + length (length line) + index (1- length) + current 0 + base 0 + ) + + (and (minusp indent) (setq indent 0)) + + ;; Skip any spaces after offset, "paranoia check" + (while (member (char-after offset) indent-spaces) + (incf offset) + ) + + ;; Check if there are only spaces before `offset' and the line `start' + (while (and (>= index 0) (member (char line index) indent-spaces)) + (decf index) + ) + + ;; `index' will be zero if there are only spaces in the `line' + (setq barrier (+ start (incf index))) + + ;; Calculate `base' unmodifiable indentation, if any + (dotimes (i index) + (if (char= (char line i) #\Tab) + (incf base (- 8 (rem base 8))) + (incf base) + ) + ) + + ;; If any non blank character would need to be deleted + (and (> base indent) (return-from indent-text nil)) + + ;; Calculate `current' indentation + (setq current base) + (while (< index length) + (if (char= (char line index) #\Tab) + (incf current (- 8 (rem current 8))) + (incf current) + ) + (incf index) + ) + + ;; Maybe could also "optimize" the indentation even if it is already + ;; correct, removing spaces "inside" tabs. + (when (/= indent current) + (if no-tabs + (setq + length (- indent base) + result (+ barrier length) + string (make-string length :initial-element #\Space) + ) + (progn + (multiple-value-setq (tabs spaces) (floor (- indent base) 8)) + (setq + length (+ tabs spaces) + result (+ barrier length) + string (make-string length :initial-element #\Tab) + ) + (fill string #\Space :start tabs) + ) + ) + + (replace-text barrier offset string) + (and (>= offset point) (>= point barrier) (goto-char result)) + ) +) +(compile 'indent-text) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helper function, returns indentation of a given offset +;; If `align' is set, stop once a non blank character is seen, that +;; is, use `offset' only as a line identifier +;; If `resolve' is set, it means that the offset is just a hint, it +;; maybe anywhere in the line +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun offset-indentation (offset &key resolve align + &aux + char + line + (start (scan offset :eol :left)) + (indent 0)) + (if resolve + (loop + (if (characterp (setq char (char-after start))) + (if (char= char #\Tab) + (incf indent (- 8 (rem indent 8))) + ;; Not a tab, check if is a space + (if (char= char #\Space) + (incf indent) + ;; Not a tab neither a space + (return indent) + ) + ) + ;; EOF found + (return indent) + ) + ;; Increment offset to check next character + (incf start) + ) + (progn + (setq line (read-text start (- offset start))) + (dotimes (i (length line) indent) + (if (char= (setq char (char line i)) #\Tab) + (incf indent (- 8 (rem indent 8))) + (progn + (or align (member char indent-spaces) + (return indent) + ) + (incf indent) + ) + ) + ) + ) + ) +) +(compile 'offset-indentation) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; A default/fallback indentation function, just copy indentation +;; of previous line. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun default-indent (syntax syntable) + (let + ( + (offset (scan (point) :eol :left)) + start + left + right + ) + + syntable ;; XXX hack to not generate warning about unused + ;; variable, should be temporary (until unused + ;; variables can be declared as such) + + (if + (or + ;; if indentation is disabled + (and + (hash-table-p (syntax-options syntax)) + (gethash :disable-indent (syntax-options syntax)) + ) + ;; or if not at the start of a new line + (> (scan offset :eol :right) offset) + ) + (return-from default-indent) + ) + + (setq left offset) + (loop + (setq + start left + left (scan start :eol :left :count 2) + right (scan left :eol :right) + ) + ;; if start of file reached + (and (>= left start) (return)) + (when + (setq + start + (position-if-not + #'(lambda (char) (member char indent-spaces)) + (read-text left (- right left)) + ) + ) + + ;; indent the current line + (indent-text (offset-indentation (+ left start) :align t) offset) + (return) + ) + ) + ) +) +(compile 'default-indent) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helper function +;; Clear line before cursor if it is empty +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indent-clear-empty-line (&aux left offset right line index) + (setq + offset (scan (point) :eol :left) + left (scan offset :eol :left :count 2) + right (scan left :eol :right) + ) + + ;; If not at the first line in the file and line is not already empty + (when (and (/= offset left) (/= left right)) + (setq + line (read-text left (- right left)) + index (1- (length line)) + ) + (while (and (>= index 0) (member (char line index) indent-spaces)) + (decf index) + ) + ;; If line was only spaces + (and (minusp index) (replace-text left right "")) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Macro to be called whenever an indentation rule decides that +;; the parser is done. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indent-macro-terminate (&optional result) + `(return-from ind-terminate-block ,result) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Like indent-terminate, but "rejects" the input for the current line +;; and terminates the loop. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indent-macro-reject (&optional result) + `(progn + (setq ind-state ind-prev-state) + (return-from ind-terminate-block ,result) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Like indent-reject, but "rejects" anything before the current token +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indent-macro-reject-left (&optional result) + `(progn + (setq ind-state ind-matches) + (return-from ind-terminate-block ,result) + ) +) + + +(defstruct indtoken + regex ;; a string, character or regex + token ;; the resulting token, nil or a keyword + begin ;; begin a new table + switch ;; switch to another table + ;; begin and switch fields are used like the ones for the syntax highlight + ;; syntoken structure. + label ;; filed at compile time + code ;; code to execute when it matches +) + +(defstruct indtable + label ;; a keyword, name of the table + tokens ;; list of indtoken structures + tables ;; list of indtable structures + augments ;; augment list +) + +(defstruct indaugment + labels ;; list of keywords labeling tables +) + +(defstruct indinit + variables ;; list of variables and optional initialization + ;; Format of variables must be suitable to LET*, example of call: + ;; (indinit + ;; var1 ;; initialized to NIL + ;; (var2 (afun)) ;; initialized to the value returned by AFUN + ;; ) +) + +(defstruct indreduce + token ;; reduced token + rules ;; list of rules + label ;; unique label associated with rule, this + ;; field is automatically filled in the + ;; compilation process. this field exists + ;; to allow several indreduce definitions + ;; that result in the same token + check ;; FORM evaluated, if T apply reduce rule + code ;; PROGN to be called when a rule matches +) + +;; NOTE, unlike "reduce" rules, "resolve" rules cannot be duplicated +(defstruct indresolve + match ;; the matched token (or a list of tokens) + code ;; PROGN to apply for this token +) + +(defstruct indent + reduces ;; list of indreduce structures + tables ;; list of indtable structures + inits ;; initialization list + resolves ;; list of indresolve structures + token-code ;; code to execute when a token matches + check-code ;; code to execute before applying a reduce rule + reduce-code ;; code to execute after reduce rule + resolve-code ;; code to execute when matching a token +) + +(defmacro defindent (variable label &rest lists) + `(if (boundp ',variable) + ,variable + (progn + (proclaim '(special ,variable)) + (setq ,variable (compile-indent-table ,label ,@lists)) + ) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create an indent token. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indtoken (pattern token + &key icase nospec begin switch code (nosub t)) + (setq pattern (re-comp (eval pattern) :icase icase :nospec nospec :nosub nosub)) + (when (consp (re-exec pattern "" :notbol t :noteol t)) + (error "INDTOKEN: regex ~A matches empty string" pattern) + ) + + ;; result of macro, return token structure + (make-indtoken + :regex pattern + :token token + :begin begin + :switch switch + :code code + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create an indentation table. Basically a list of indentation tokens. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indtable (label &rest definitions) + ;; check for simple errors + (unless (keywordp label) + (error "INDTABLE: ~A is not a keyword" label) + ) + (dolist (item definitions) + (unless + (or + (atom item) + (indtoken-p item) + (indtable-p item) + (indaugment-p item) + ) + (error "INDTABLE: invalid indent table argument ~A" item) + ) + ) + + ;; return indent table structure + (make-indtable + :label label + :tokens (remove-if-not #'indtoken-p definitions) + :tables (remove-if-not #'indtable-p definitions) + :augments (remove-if-not #'indaugment-p definitions) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Add identifier to list of augment tables. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indaugment (&rest keywords) + (dolist (keyword keywords) + (unless (keywordp keyword) + (error "INDAUGMENT: bad indent table label ~A" keyword) + ) + ) + + ;; return augment list structure + (make-indaugment :labels keywords) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Add variables to initialization list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indinit (&rest variables) + (make-indinit :variables variables) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create a "reduction rule" +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indreduce (token check rules &rest code &aux nullp consp) + ;; check for simple errors + (unless (or (keywordp token) (null token)) + (error "INDREDUCE: ~A is not a keyword" token) + ) + (dolist (rule rules) + (or (listp rule) (error "INDREDUCE: invalid indent rule ~A" rule)) + ;; XXX This test is not enough, maybe should add some sort of + ;; runtime check to avoid circularity. + (and (eq token (car rule)) (null (cdr rule)) + (error "INDREDUCE: ~A reduces to ~A" token) + ) + (dolist (item rule) + (and (or nullp consp) (not (keywordp item)) + (error "INDREDUCE: a keyword must special pattern") + ) + (if (consp item) + (progn + (unless + (or + (and + (eq (car item) 'not) + (keywordp (cadr item)) + (null (cddr item)) + ) + (and + (eq (car item) 'or) + (null (member-if-not #'keywordp (cdr item))) + ) + ) + (error "INDREDUCE: syntax error parsing ~A" item) + ) + (setq consp t) + ) + (progn + (setq nullp (null item) consp nil) + (unless (or (keywordp item) nullp (eq item t)) + (error "INDREDUCE: ~A is not a keyword" item) + ) + ) + ) + ) +; (and consp +; (error "INDREDUCE: pattern must be followed by keyword") +; ) + ) + + ;; result of macro, return indent reduce structure + (make-indreduce + :token token + :check check + :rules (remove-if #'null rules) + :code code + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create a "resolve rule" +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indresolve (match &rest code) + ;; check for simple errors + (if (consp match) + (dolist (token match) + (or (keywordp token) (error "INDRESOLVE: ~A is not a keyword" token)) + ) + (or (keywordp match) (error "INDRESOLVE: ~A is not a keyword" match)) + ) + + ;; result of macro, return indent resolve structure + (make-indresolve + :match match + :code code + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helper function for compile-indent-table. Returns a list of all +;; tables and tokens for a given table, including tokens and tables +;; of children. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun list-indtable-elements (table &aux result sub-result) + (setq result (cons (indtable-tokens table) (indtable-tables table))) + (dolist (child (indtable-tables table)) + (setq sub-result (list-indtable-elements child)) + (rplaca result (append (car result) (car sub-result))) + (rplacd result (append (cdr result) (cdr sub-result))) + ) + ;; Return pair of all nested tokens and tables + result +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; First pass adding augumented tokens to a table, done in two passes +;; to respect inheritance order. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-indent-augment-list (table table-list &aux labels augment tokens) + + ;; Create a list of all augment tables. + (dolist (augment (indtable-augments table)) + (setq labels (append labels (indaugment-labels augment))) + ) + + ;; Remove duplicates and references to "itself", without warnings? + (setq + labels + (remove (indtable-label table) (remove-duplicates labels :from-end t)) + ) + + ;; Check if the specified indent tables exists! + (dolist (label labels) + (unless + (setq augment (car (member label table-list :key #'indtable-label))) + (error "COMPILE-INDENT-AUGMENT-LIST: Cannot augment ~A in ~A" + label + (indtable-label table) + ) + ) + + ;; Increase list of tokens. + (setq tokens (append tokens (indtable-tokens augment))) + ) + + ;; Store the tokens in the augment list. They will be added + ;; to the indent table in the second pass. + (setf (indtable-augments table) tokens) + + ;; Recurse on every child table. + (dolist (child (indtable-tables table)) + (compile-indent-augment-list child table-list) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Last pass adding augmented tokens to a table. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun link-indent-augment-list (table) + (setf + (indtable-tokens table) + (remove-duplicates + (nconc (indtable-tokens table) (indtable-augments table)) + :key #'indtoken-regex + :test #'equal + :from-end t + ) + + ;; Don't need to keep this list anymore. + (indtable-augments table) + () + ) + + (dolist (child (indtable-tables table)) + (link-indent-augment-list child) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Compile the indent reduction rules +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-indent-reduces (reduces + &aux need label check rules reduce + check-code reduce-code) + (dolist (item reduces) + (setq + label (indreduce-label item) + check (indreduce-check item) + rules (indreduce-rules item) + reduce (indreduce-code item) + need (and + rules + (not label) + (or + reduce + (null check) + (not (constantp check)) + ) + ) + ) + (when need + (and (null label) (setq label (intern (string (gensym)) 'keyword))) + + (setf (indreduce-label item) label) + + (and + (or (null check) + (not (constantp check)) + ) + (setq + check (list (list 'eq '*ind-label* label) check) + check-code (nconc check-code (list check)) + ) + ) + + (and reduce + (setq + reduce (cons (list 'eq '*ind-label* label) reduce) + reduce-code (nconc reduce-code (list reduce)) + ) + ) + ) + ) + + ;; XXX Instead of using COND, could/should use CASE + ;; TODO Implement a smart CASE in the bytecode compiler, if + ;; possible, should generate a hashtable, or a table + ;; of indexes (for example when all elements in the cases + ;; are characters) and then jump directly to the code. + (if check-code + (setq check-code (cons 'cond (nconc check-code '((t t))))) + (setq check-code t) + ) + (and reduce-code (setq reduce-code (cons 'cond reduce-code))) + + (values check-code reduce-code) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Compile the indent resolve code +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-indent-resolves (resolves &aux match resolve resolve-code) + (and + (/= + (length resolves) + (length (remove-duplicates resolves :key #'indresolve-match)) + ) + ;; XXX Could do a more complete job and tell what is wrong... + (error "COMPILE-INDENT-RESOLVES: duplicated labels") + ) + + (dolist (item resolves) + (when (setq resolve (indresolve-code item)) + (setq + match + (indresolve-match item) + + resolve + (cons + (if (listp match) + (list 'member '*ind-token* `',match :test `#'eq) + (list 'eq '*ind-token* match) + ) + resolve + ) + + resolve-code + (nconc resolve-code (list resolve)) + ) + ) + ) + + (and resolve-code (cons 'cond resolve-code)) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create an indentation table +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-indent-table (name &rest lists + &aux main elements switches begins tables symbols + label code token-code check-code reduce-code + (inits (remove-if-not #'indinit-p lists)) + (reduces (remove-if-not #'indreduce-p lists)) + (resolves (remove-if-not #'indresolve-p lists)) + ) + (setq + lists (delete-if + #'(lambda (object) + (or + (indinit-p object) + (indreduce-p object) + (indresolve-p object) + ) + ) + lists) + main (apply #'indtable name lists) + elements (list-indtable-elements main) + switches (remove-if #'null (car elements) :key #'indtoken-switch) + begins (remove-if #'null (car elements) :key #'indtoken-begin) + tables (cons main (cdr elements)) + ) + + ;; Check for typos in the keywords, or for not defined indent tables. + (dolist (item (mapcar #'indtoken-switch switches)) + (unless + (or (and (integerp item) (minusp item)) + (member item tables :key #'indtable-label) + ) + (error "COMPILE-INDENT-TABLE: SWITCH ~A cannot be matched" item) + ) + ) + (dolist (item (mapcar #'indtoken-begin begins)) + (unless (member item tables :key #'indtable-label) + (error "COMPILE-INDENT-TABLE: BEGIN ~A cannot be matched" item) + ) + ) + + ;; Build augment list. + (compile-indent-augment-list main tables) + (link-indent-augment-list main) + + ;; Change switch and begin fields to point to the indent table + (dolist (item switches) + (if (keywordp (indtoken-switch item)) + (setf + (indtoken-switch item) + (car (member (indtoken-switch item) tables :key #'indtable-label)) + ) + ) + ) + (dolist (item begins) + (setf + (indtoken-begin item) + (car (member (indtoken-begin item) tables :key #'indtable-label)) + ) + ) + + ;; Build initialization list + (dolist (init inits) + (setq symbols (nconc symbols (indinit-variables init))) + ) + + ;; Build token code + (dolist (item (car elements)) + (when (setq code (indtoken-code item)) + (setf + label + (intern (string (gensym)) 'keyword) + + (indtoken-label item) + label + + code + (list (list 'eq '*ind-label* label) code) + + token-code + (nconc token-code (list code)) + ) + ) + ) + + (multiple-value-setq + (check-code reduce-code) + (compile-indent-reduces reduces) + ) + + (make-indent + :tables tables + :inits symbols + :reduces reduces + :resolves resolves + :token-code (and token-code (cons 'cond token-code)) + :check-code check-code + :reduce-code reduce-code + :resolve-code (compile-indent-resolves resolves) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Search rule-pattern in match-pattern +;; Returns offset of match, and it's length, if any +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indent-search-rule (rule-pattern match-pattern + &aux start rule rulep matchp test offset length) + (if (member-if-not #'keywordp rule-pattern) + ;; rule has wildcards + (progn + (setq + rulep rule-pattern + matchp match-pattern + start match-pattern + ) + (loop + (setq rule (car rulep)) + (cond + ;; Special pattern + ((consp rule) + (if (eq (car rule) 'not) + (progn + (setq + test (cadr rule) + rulep (cdr rulep) + rule (car rulep) + ) + (while + (and + ;; something to match + matchp + ;; NOT match is true + (not (eq (car matchp) test)) + ;; next match is not true + (not (eq (car matchp) rule)) + ) + (setq matchp (cdr matchp)) + ) + (if (eq (car matchp) rule) + ;; rule matched + (setq + matchp (cdr matchp) + rulep (cdr rulep) + ) + ;; failed + (setq + rulep rule-pattern + matchp (cdr start) + start matchp + ) + ) + ) + ;; (eq (car rule) 'or) + (progn + (if (member (car matchp) (cdr rule) :test #'eq) + (setq rulep (cdr rulep) matchp (cdr matchp)) + ;; failed + (progn + ;; end of match found! + (and (null matchp) (return)) + ;; reset search + (setq + rulep rule-pattern + matchp (cdr start) + start matchp + ) + ) + ) + ) + ) + ) + + ;; Skip until end of match-pattern or rule is found + ((null rule) + (setq rulep (cdr rulep)) + ;; If matches everything + (if (null rulep) + (progn (setq matchp nil) (return)) + ;; If next token cannot be matched + (unless + (setq + matchp + (member (car rulep) matchp :test #'eq) + ) + (setq rulep rule-pattern) + (return) + ) + ) + (setq rulep (cdr rulep) matchp (cdr matchp)) + ) + + ;; Matched + ((eq rule t) + ;; If there isn't a rule to skip + (and (null matchp) (return)) + (setq rulep (cdr rulep) matchp (cdr matchp)) + ) + + ;; Matched + ((eq rule (car matchp)) + (setq rulep (cdr rulep) matchp (cdr matchp)) + ) + + ;; No match + (t + ;; end of match found! + (and (null matchp) (return)) + ;; reset search + (setq + rulep rule-pattern + matchp (cdr start) + start matchp + ) + ) + ) + + ;; if everything matched + (or rulep (return)) + ) + + ;; All rules matched + (unless rulep + ;; Calculate offset and length of match + (setq offset 0 length 0) + (until (eq match-pattern start) + (setq + offset (1+ offset) + match-pattern (cdr match-pattern) + ) + ) + (until (eq match-pattern matchp) + (setq + length (1+ length) + match-pattern (cdr match-pattern) + ) + ) + ) + ) + ;; no wildcards + (and (setq offset (search rule-pattern match-pattern :test #'eq)) + (setq length (length rule-pattern)) + ) + ) + + (values offset length) +) +(compile 'indent-search-rule) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Indentation parser +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indent-macro (ind-definition ind-offset &optional ind-no-tabs) + `(prog* + ( + ;; Current indentation table + (ind-table (car (indent-tables ,ind-definition))) + + ;; The parser rules + (ind-reduces (indent-reduces ,ind-definition)) + + ;; Token list for the table + (ind-tokens (indtable-tokens ind-table)) + + ;; Stack of nested tables/states + ind-stack + + ;; indentation to be used + (*indent* 0) + + ;; offset to apply indentation + *offset* + + ;; Number of lines read + (*ind-lines* 1) + + ;; Matched token + *ind-token* + + ;; list of tokens after current match, should not be changed + *ind-token-list* + + ;; label associated with rule + *ind-label* + + ;; offset of match + *ind-offset* + + ;; length of match + *ind-length* + + ;; insert position + (*ind-point* (point)) + + (ind-from (scan ,ind-offset :eol :left)) + (ind-to ,ind-offset) + (ind-line (read-text ind-from (- ind-to ind-from))) + + ;; start of current line + (*ind-start* ind-from) + + ;; State information + ind-state + + ;; For use with (indent-macro-reject) + ind-prev-state + + ;; Matches for the current line + ind-matches + + ;; Matched tokens not yet used + ind-cache + + ;; Pattern being tested + ind-token + + ;; Used when searching for a regex + ind-match + + ;; Table to change + ind-change + + ;; Length of ind-line + (ind-length (length ind-line)) + + ;; Don't parse after this offset + (ind-end ind-length) + + ;; Temporary variables used during loops + ind-left + ind-right + ind-tleft + ind-tright + + ;; Set when start of file is found + ind-startp + + ;; Flag for regex search + (ind-noteol (< ind-to (scan ind-from :eol :right))) + + ;; Initialization variables expanded here + ,@(indent-inits (eval ind-definition)) + ) + + ;; Initial input already read + (go :ind-loop) + +;------------------------------------------------------------------------ +; Read a text line +:ind-read + (setq + ind-to ind-from + ind-from (scan ind-from :eol :left :count 2) + ) + ;; If start of file reached + (and (= ind-to ind-from) (setq ind-startp t) (go :ind-process)) + + (setq + *ind-lines* (1+ *ind-lines*) + ind-to (scan ind-from :eol :right) + ind-line (read-text ind-from (- ind-to ind-from)) + ind-length (length ind-line) + ind-end ind-length + ind-noteol nil + ind-cache nil + ind-prev-state ind-state + ) + +;------------------------------------------------------------------------ +; Loop parsing backwards +:ind-loop + (setq ind-matches nil) + (dolist (token ind-tokens) + ;; Prepare to loop + (setq + ind-token (indtoken-regex token) + ind-left 0 + ) + ;; While the pattern matches + (loop + (setq ind-right ind-left) + (if + (consp + (setq + ind-match + (re-exec + ind-token + ind-line + :start ind-left + :end ind-end + :notbol (> ind-left 0) + :noteol ind-noteol + ) + ) + ) + + ;; Remember about match + (setq + ind-match (car ind-match) + ind-left (cdr ind-match) + ind-matches (cons (cons token ind-match) ind-matches) + ) + + ;; No match + (return) + ) + ;; matched an empty string + (and (= ind-left ind-right) (incf ind-left)) + + ;; matched a single eol or bol + (and (>= ind-left ind-end) (return)) + ) + ) + + ;; Add new matches to cache + (when ind-matches + (setq + ind-cache + (stable-sort + (nconc (nreverse ind-matches) ind-cache) #'< :key #'cadr + ) + ) + ) + + ;; If nothing in the cache + (or ind-cache (go :ind-process)) + + (setq + ind-left (cadar ind-cache) + ind-right (cddar ind-cache) + ind-matches (cdr ind-cache) + ) + + ;; If only one element in the cache + (or ind-matches (go :ind-parse)) + + (setq + ind-tleft (cadar ind-matches) + ind-tright (cddar ind-matches) + ) + + ;; Remove overlaps + (loop + (if (or (>= ind-tleft ind-right) (<= ind-tright ind-left)) + ;; No overlap + (progn + (setq + ind-left ind-tleft + ind-right ind-tright + ind-matches (cdr ind-matches) + ) + ;; If everything checked + (or ind-matches (return)) + ) + ;; Overlap found + (progn + (if (consp (cdr ind-matches)) + ;; There are yet items to be checked + (progn + (rplaca ind-matches (cadr ind-matches)) + (rplacd ind-matches (cddr ind-matches)) + ) + ;; Last item + (progn + (rplacd (last ind-cache 2) nil) + (return) + ) + ) + ) + ) + + ;; Prepare for next check + (setq + ind-tleft (cadar ind-matches) + ind-tright (cddar ind-matches) + ) + ) + +;------------------------------------------------------------------------ +; Process the matched tokens +:ind-parse + (setq ind-cache (nreverse ind-cache)) + +:ind-parse-loop + (or (setq ind-match (car ind-cache)) (go :ind-process)) + + (setq + ind-cache (cdr ind-cache) + ind-token (car ind-match) + ) + + (or (member ind-token ind-tokens :test #'eq) + (go :ind-parse-loop) + ) + + ;; If a state should be added + (when (setq ind-change (indtoken-token ind-token)) + (setq + ind-left (cadr ind-match) + ind-right (cddr ind-match) + + *ind-offset* + (+ ind-from ind-left) + + *ind-length* + (- ind-right ind-left) + + ind-state + (cons + (cons ind-change (cons *ind-offset* *ind-length*)) + ind-state + ) + + *ind-label* + (indtoken-label ind-token) + ) + + ;; Expand token code + ,(indent-token-code (eval ind-definition)) + ) + + ;; Check if needs to switch to another table + (when (setq ind-change (indtoken-switch ind-token)) + ;; Need to switch to a previous table + (if (integerp ind-change) + ;; Relative switch + (while (and ind-stack (minusp ind-change)) + (setq + ind-table (pop ind-stack) + ind-change (1+ ind-change) + ) + ) + ;; Search table in the stack + (until + (or + (null ind-stack) + (eq + (setq ind-table (pop ind-stack)) + ind-change + ) + ) + ) + ) + + ;; If no match or stack became empty + (and (null ind-table) + (setq + ind-table + (car (indent-tables ,ind-definition)) + ) + ) + ) + + ;; Check if needs to start a new table + ;; XXX use ind-tleft to reduce number of local variables + (when (setq ind-tleft (indtoken-begin ind-token)) + (setq + ind-change ind-tleft + ind-stack (cons ind-table ind-stack) + ind-table ind-change + ) + ) + + ;; If current "indent pattern table" changed + (when ind-change + (setq + ind-tokens (indtable-tokens ind-table) + ind-cache (nreverse ind-cache) + ind-end (cadr ind-match) + ind-noteol (> ind-length ind-end) + ) + (go :ind-loop) + ) + + (and ind-cache (go :ind-parse-loop)) + +;------------------------------------------------------------------------ +; Everything checked, process result +:ind-process + + ;; If stack is not empty, don't apply rules + (and ind-stack (not ind-startp) (go :ind-read)) + + (block ind-terminate-block + (setq ind-cache nil ind-tleft 0 ind-change (mapcar #'car ind-state)) + (dolist (entry ind-reduces) + (setq + *ind-token* (indreduce-token entry) + *ind-label* (indreduce-label entry) + ) + (dolist (rule (indreduce-rules entry)) + (loop + ;; Check if reduction can be applied + (or + (multiple-value-setq + (ind-match ind-length) + (indent-search-rule rule ind-change) + ) + (return) + ) + + (setq + ;; First element matched + ind-matches (nthcdr ind-match ind-state) + + ;; Offset of match + *ind-offset* (cadar ind-matches) + + *ind-token-list* (nthcdr ind-match ind-change) + + ;; Length of match, note that *ind-length* + ;; Will be transformed to zero bellow if + ;; the rule is deleting entries. + *ind-length* + (if (> ind-length 1) + (progn + (setq + ;; XXX using ind-tright, to reduce + ;; number of local variables... + ind-tright + (nth (1- ind-length) ind-matches) + + ind-right + (+ (cadr ind-tright) + (cddr ind-tright) + ) + ) + (- ind-right *ind-offset*) + ) + (cddar ind-matches) + ) + ) + + ;; XXX using ind-tleft as a counter, to reduce + ;; number of used variables... + (and (>= (incf ind-tleft) 1000) + ;; Should never apply so many reduce rules on + ;; every iteration, if needs to, something is + ;; wrong in the indentation definition... + (error "~D INDREDUCE iterations, ~ + now checking (~A ~A)" + ind-tleft *ind-token* rule + ) + ) + + ;; Check if should apply the reduction + (or + ;; Expand check code + ,(indent-check-code (eval ind-definition)) + (return) + ) + + (if (null *ind-token*) + ;; Remove match + (progn + (setq *ind-length* 0) + (if (= ind-match 0) + ;; Matched the first entry + (setq + ind-state + (nthcdr ind-length ind-matches) + ) + (progn + (setq + ind-matches + (nthcdr (1- ind-match) ind-state) + ) + (rplacd + ind-matches + (nthcdr (1+ ind-length) ind-matches) + ) + ) + ) + ) + + ;; Substitute/simplify + (progn + (rplaca (car ind-matches) *ind-token*) + (when (> ind-length 1) + (rplacd (cdar ind-matches) *ind-length*) + (rplacd + ind-matches + (nthcdr ind-length ind-matches) + ) + ) + ) + ) + (setq + ind-cache t + ind-change (mapcar #'car ind-state) + ) + + ;; Expand reduce code + ,(indent-reduce-code (eval ind-definition)) + ) + ) + ) + + ;; ind-cache will be T if at least one change was done + (and ind-cache (go :ind-process)) + + ;; Start of file reached + (or ind-startp (go :ind-read)) + + ) ;; end of ind-terminate-block + + + (block ind-terminate-block + (setq *ind-token-list* (mapcar #'car ind-state)) + (dolist (item ind-state) + (setq + *ind-token* (car item) + *ind-offset* (cadr item) + *ind-length* (cddr item) + ) + ;; Expand resolve code + ,(indent-resolve-code (eval ind-definition)) + (setq *ind-token-list* (cdr *ind-token-list*)) + ) + ) + + (and (integerp *indent*) + (integerp *offset*) + (indent-text *indent* *offset* ,ind-no-tabs) + ) + ) +) diff --git a/lisp/modules/lisp.lsp b/lisp/modules/lisp.lsp new file mode 100644 index 0000000..55d5e6c --- /dev/null +++ b/lisp/modules/lisp.lsp @@ -0,0 +1,174 @@ +;; +;; 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/modules/lisp.lsp,v 1.10 2002/12/20 04:32:47 paulo Exp $ +;; +(provide "lisp") + +(in-package "LISP") + +(export '( + second third fourth fifth sixth seventh eighth ninth tenth + pathname merge-pathnames + logtest signum + alphanumericp copy-seq push pop prog prog* + with-open-file with-output-to-string +)) + +(defun second (a) (nth 1 a)) +(defun third (a) (nth 2 a)) +(defun fourth (a) (nth 3 a)) +(defun fifth (a) (nth 4 a)) +(defun sixth (a) (nth 5 a)) +(defun seventh (a) (nth 6 a)) +(defun eighth (a) (nth 7 a)) +(defun ninth (a) (nth 8 a)) +(defun tenth (a) (nth 9 a)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; pathnames +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun pathname (filename) + (values (parse-namestring filename))) + +(defun merge-pathnames (pathname &optional defaults default-version) + (if (null default-version) + (parse-namestring pathname nil defaults) + (parse-namestring pathname nil + (make-pathname :defaults defaults :version default-version)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; math +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun logtest (integer1 integer2) + (not (zerop (logand integer1 integer2)))) + +(defun signum (number) + (if (zerop number) number (/ number (abs number)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; misc functions/macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun alphanumericp (char) + (or (alpha-char-p char) (not (null (digit-char-p char))))) + +(defun copy-seq (sequence) + (subseq sequence 0)) + +(defmacro prog (init &rest body) + `(block nil (let ,init (tagbody ,@body)))) + +(defmacro prog* (init &rest body) + `(block nil (let* ,init (tagbody ,@body)))) + +(defmacro with-open-file (file &rest body) + `(let ((,(car file) (open ,@(cdr file)))) + (unwind-protect + (progn ,@body) + (if ,(car file) (close ,(car file)))))) + +(defmacro with-output-to-string (stream &rest body) + `(let ((,(car stream) (make-string-output-stream))) + (unwind-protect + (progn ,@body (get-output-stream-string ,(car stream))) + (and ,(car stream) (close ,(car stream)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; setf +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defsetf car (list) (value) `(progn (rplaca ,list ,value) ,value)) +(defsetf cdr (list) (value) `(progn (rplacd ,list ,value) ,value)) + +(defsetf caar (list) (value) `(progn (rplaca (car ,list) ,value) ,value)) +(defsetf cadr (list) (value) `(progn (rplaca (cdr ,list) ,value) ,value)) +(defsetf cdar (list) (value) `(progn (rplacd (car ,list) ,value) ,value)) +(defsetf cddr (list) (value) `(progn (rplacd (cdr ,list) ,value) ,value)) +(defsetf caaar (list) (value) `(progn (rplaca (caar ,list) ,value) ,value)) +(defsetf caadr (list) (value) `(progn (rplaca (cadr ,list) ,value) ,value)) +(defsetf cadar (list) (value) `(progn (rplaca (cdar ,list) ,value) ,value)) +(defsetf caddr (list) (value) `(progn (rplaca (cddr ,list) ,value) ,value)) +(defsetf cdaar (list) (value) `(progn (rplacd (caar ,list) ,value) ,value)) +(defsetf cdadr (list) (value) `(progn (rplacd (cadr ,list) ,value) ,value)) +(defsetf cddar (list) (value) `(progn (rplacd (cdar ,list) ,value) ,value)) +(defsetf cdddr (list) (value) `(progn (rplacd (cddr ,list) ,value) ,value)) +(defsetf caaaar (list) (value) `(progn (rplaca (caaar ,list) ,value) ,value)) +(defsetf caaadr (list) (value) `(progn (rplaca (caadr ,list) ,value) ,value)) +(defsetf caadar (list) (value) `(progn (rplaca (cadar ,list) ,value) ,value)) +(defsetf caaddr (list) (value) `(progn (rplaca (caddr ,list) ,value) ,value)) +(defsetf cadaar (list) (value) `(progn (rplaca (cdaar ,list) ,value) ,value)) +(defsetf cadadr (list) (value) `(progn (rplaca (cdadr ,list) ,value) ,value)) +(defsetf caddar (list) (value) `(progn (rplaca (cddar ,list) ,value) ,value)) +(defsetf cadddr (list) (value) `(progn (rplaca (cdddr ,list) ,value) ,value)) +(defsetf cdaaar (list) (value) `(progn (rplacd (caaar ,list) ,value) ,value)) +(defsetf cdaadr (list) (value) `(progn (rplacd (caadr ,list) ,value) ,value)) +(defsetf cdadar (list) (value) `(progn (rplacd (cadar ,list) ,value) ,value)) +(defsetf cdaddr (list) (value) `(progn (rplacd (caddr ,list) ,value) ,value)) +(defsetf cddaar (list) (value) `(progn (rplacd (cdaar ,list) ,value) ,value)) +(defsetf cddadr (list) (value) `(progn (rplacd (cdadr ,list) ,value) ,value)) +(defsetf cdddar (list) (value) `(progn (rplacd (cddar ,list) ,value) ,value)) +(defsetf cddddr (list) (value) `(progn (rplacd (cdddr ,list) ,value) ,value)) + +(defsetf first (list) (value) `(progn (rplaca ,list ,value) ,value)) +(defsetf second (list) (value) `(progn (rplaca (nthcdr 1 ,list) ,value) ,value)) +(defsetf third (list) (value) `(progn (rplaca (nthcdr 2 ,list) ,value) ,value)) +(defsetf fourth (list) (value) `(progn (rplaca (nthcdr 3 ,list) ,value) ,value)) +(defsetf fifth (list) (value) `(progn (rplaca (nthcdr 4 ,list) ,value) ,value)) +(defsetf sixth (list) (value) `(progn (rplaca (nthcdr 5 ,list) ,value) ,value)) +(defsetf seventh (list) (value) `(progn (rplaca (nthcdr 6 ,list) ,value) ,value)) +(defsetf eighth (list) (value) `(progn (rplaca (nthcdr 7 ,list) ,value) ,value)) +(defsetf ninth (list) (value) `(progn (rplaca (nthcdr 8 ,list) ,value) ,value)) +(defsetf tenth (list) (value) `(progn (rplaca (nthcdr 9 ,list) ,value) ,value)) + +(defsetf rest (list) (value) `(progn (rplacd ,list ,value) ,value)) + +(defun lisp::nth-store (index list value) + (rplaca (nthcdr index list) value) value) +(defsetf nth lisp::nth-store) + +(defsetf aref (array &rest indices) (value) + `(lisp::vector-store ,array ,@indices ,value)) + +(defsetf get (symbol key &optional default) (value) + `(lisp::put ,symbol ,key ,value)) + +(defsetf symbol-plist lisp::set-symbol-plist) + +(defsetf gethash (key hash-table &optional default) (value) + `(lisp::puthash ,key ,hash-table ,value)) + +(defsetf char lisp::char-store) +(defsetf schar lisp::char-store) +(defsetf elt lisp::elt-store) +(defsetf svref lisp::elt-store) +(defsetf documentation lisp::documentation-store) + +(defsetf symbol-value set) + +(defsetf subseq (sequence start &optional end) (value) + `(progn (replace ,sequence ,value :start1 ,start :end1 ,end) ,value)) diff --git a/lisp/modules/progmodes/c.lsp b/lisp/modules/progmodes/c.lsp new file mode 100644 index 0000000..bc4474b --- /dev/null +++ b/lisp/modules/progmodes/c.lsp @@ -0,0 +1,1118 @@ +;; +;; Copyright (c) 2002 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/modules/progmodes/c.lsp,v 1.26 2003/01/29 03:05:54 paulo Exp $ +;; + +(require "syntax") +(require "indent") +(in-package "XEDIT") + +(defsynprop *prop-format* + "format" + :font "*lucidatypewriter-medium-r*12*" + :foreground "RoyalBlue2" + :underline t +) + +(defsynoptions *c-DEFAULT-style* + ;; Positive number. Basic indentation. + (:indentation . 4) + + ;; Boolean. Support for GNU style indentation. + (:brace-indent . nil) + + ;; Boolean. Add one indentation level to case and default? + (:case-indent . t) + + ;; Boolean. Remove one indentation level for labels? + (:label-dedent . t) + + ;; Boolean. Add one indentation level to continuations? + (:cont-indent . t) + + ;; Boolean. Move cursor to the indent column after pressing <Enter>? + (:newline-indent . t) + + ;; Boolean. Set to T if tabs shouldn't be used to fill indentation. + (:emulate-tabs . nil) + + ;; Boolean. Force a newline before braces? + (:newline-before-brace . nil) + + ;; Boolean. Force a newline after braces? + (:newline-after-brace . nil) + + ;; Boolean. Force a newline after semicolons? + (:newline-after-semi . nil) + + ;; Boolean. Only calculate indentation after pressing <Enter>? + ;; This may be useful if the parser does not always + ;; do what the user expects... + (:only-newline-indent . nil) + + ;; Boolean. Remove extra spaces from previous line. + ;; This should default to T when newline-indent is not NIL. + (:trim-blank-lines . t) + + ;; Boolean. If this hash-table entry is set, no indentation is done. + ;; Useful to temporarily disable indentation. + (:disable-indent . nil) +) + +;; BSD like style +(defsynoptions *c-BSD-style* + (:indentation . 8) + (:brace-indent . nil) + (:case-indent . nil) + (:label-dedent . t) + (:cont-indent . t) + (:newline-indent . t) + (:emulate-tabs . nil) + (:newline-before-brace . nil) + (:newline-after-brace . t) + (:newline-after-semi . t) + (:trim-blank-lines . t) +) + +;; GNU like style +(defsynoptions *c-GNU-style* + (:indentation . 2) + (:brace-indent . t) + (:case-indent . nil) + (:label-dedent . t) + (:cont-indent . t) + (:newline-indent . nil) + (:emulate-tabs . nil) + (:newline-before-brace . t) + (:newline-after-brace . t) + (:newline-after-semi . t) + (:trim-blank-lines . nil) +) + +;; K&R like style +(defsynoptions *c-K&R-style* + (:indentation . 5) + (:brace-indent . nil) + (:case-indent . nil) + (:label-dedent . t) + (:cont-indent . t) + (:newline-indent . t) + (:emulate-tabs . t) + (:newline-before-brace . t) + (:newline-after-brace . t) + (:newline-after-semi . t) + (:trim-blank-lines . t) +) + +(defvar *c-styles* '( + ("xedit" . *c-DEFAULT-style*) + ("BSD" . *c-BSD-style*) + ("GNU" . *c-GNU-style*) + ("K&R" . *c-K&R-style*) +)) + +(defvar *c-mode-options* *c-DEFAULT-style*) +; (setq *c-mode-options* *c-gnu-style*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; This is a very lazy "pattern matcher" for the C language. +;; If the syntax in the code is not correct, it may get confused, and +;; because it is "lazy" some wrong constructs will be recognized as +;; correct when reducing patterns. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defindent *c-mode-indent* :main + ;; this must be the first token + (indtoken "^\\s*" :start-of-line) + (indtoken "\\<case\\>" :c-case) + (indtoken "\\<default\\>" :c-default) + (indtoken "\\<do\\>" :do) + (indtoken "\\<if\\>" :c-if) + (indtoken "\\<else\\>" :c-else) + (indtoken "\\<for\\>" :c-for) + (indtoken "\\<switch\\>" :c-switch) + (indtoken "\\<while\\>" :c-while) + ;; Match identifiers and numbers as an expression + (indtoken "\\w+" :expression) + (indtoken ";" :semi :nospec t) + (indtoken "," :comma :nospec t) + (indtoken ":" :collon :nospec t) + ;; Ignore spaces before collon, this avoids dedenting ternary + ;; and bitfield definitions as the parser does not distinguish + ;; labels from those, another option would be to use the pattern + ;; "\\w+:", but this way should properly handle labels generated + ;; by macros, example: `MACRO_LABEL(value):' + (indtoken "\\s+:" nil) + + (indinit (c-braces 0)) + (indtoken "{" + :obrace + :nospec t + :code (decf c-braces) + ) + (indtoken "}" + :cbrace + :nospec t + :begin :braces + :code (incf c-braces) + ) + (indtable :braces + (indtoken "{" + :obrace + :nospec t + :switch -1 + :code (decf c-braces) + ) + (indtoken "}" + :cbrace + :nospec t + :begin :braces + :code (incf c-braces) + ) + ) + + (indinit (c-bra 0)) + (indtoken ")" :cparen :nospec t :code (incf c-bra)) + (indtoken "(" :oparen :nospec t :code (decf c-bra)) + (indtoken "]" :cbrack :nospec t :code (incf c-bra)) + (indtoken "[" :obrack :nospec t :code (decf c-bra)) + (indtoken "\\\\$" :continuation) + + ;; C++ style comment, disallow other tokens to match inside comment + (indtoken "//.*$" nil) + + (indtoken "#" :hash :nospec t) + + ;; if in the same line, reduce now, this must be done because the + ;; delimiters are identical + (indtoken "'([^\\']|\\\\.)*'" :expression) + (indtoken "\"([^\\\"]|\\\\.)*\"" :expression) + + (indtoken "\"" :cstring :nospec t :begin :string) + + (indtoken "'" :cconstant :nospec t :begin :constant) + + (indtoken "*/" :ccomment :nospec t :begin :comment) + ;; this must be the last token + (indtoken "$" :end-of-line) + + (indtable :string + ;; Ignore escaped characters + (indtoken "\\." nil) + ;; Return to the toplevel when the start of the string is found + (indtoken "\"" :ostring :nospec t :switch -1) + ) + (indtable :constant + ;; Ignore escaped characters + (indtoken "\\." nil) + ;; Return to the toplevel when the start of the character is found + (indtoken "'" :oconstant :nospec t :switch -1) + ) + (indtable :comment + (indtoken "/*" :ocomment :nospec t :switch -1) + ) + + ;; "Complex" statements + (indinit (c-complex 0) (c-cases 0)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Order of reduce rules here is important, process comment, + ;; continuations, preprocessor and set states when an eol is found. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (indinit (c-offset (point-max)) + (c-prev-offset c-offset) + ) + (indreduce :indent + t + ((:start-of-line)) + (and (= *ind-start* *ind-offset*) + (setq + *offset* (+ *ind-offset* *ind-length*) + ) + ) + (setq + c-prev-offset c-offset + c-offset *ind-offset* + ) + ) + + ;; Delete comments + (indreduce nil + t + ((:ocomment nil :ccomment)) + ) + + ;; Join in a single token to simplify removal of possible multiline + ;; preprocessor directives + (indinit c-continuation) + (indreduce :continuation + t + ((:continuation :end-of-line)) + (setq c-continuation t) + ) + + (indreduce :eol + t + ((:end-of-line)) + ;; Anything after the eol offset is safe to parse now + (setq c-continuation nil) + ) + + ;; Delete blank lines + (indreduce nil + t + ((:indent :eol)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Preprocessor + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce nil + (>= *ind-offset* *ind-start*) + ((:indent :hash)) + (setq *indent* 0) + (indent-macro-reject-left) + ) + (indreduce nil + t + ((:indent :hash nil :eol)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Expressions + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :expression + t + ;; Reduce to a single expression + ((:expression :parens) + (:expression :bracks) + (:expression :expression) + ;; These may be multiline + (:ostring (not :ostring) :cstring) + (:oconstant (not :oconstant) :cconstant) + ) + ) + + (indreduce :expression + t + ((:expression :eol :indent :expression) + (:expression :eol :expression) + ) + ) + + (indreduce :exp-comma + t + ((:expression :comma) + ) + ) + + ;; A semicollon, start a statement + (indreduce :stat + t + ((:semi)) + ) + + ;; Expression following (possibly empty) statement + (indreduce :stat + t + (((or :expression :exp-comma) :stat)) + ) + + ;; Multiline statements + (indreduce :stat + t + (((or :expression :exp-comma) :eol :indent :stat) + ;; rule below may have removed the :indent + ((or :expression :exp-comma) :eol :stat) + ) + ) + + (indinit c-exp-indent) + ;; XXX This rule avoids parsing large amounts of code + (indreduce :stat + t + ;; Eat eol if following expression + ((:indent :stat :eol) + (:indent :stat) + ) + (if + (or + (null c-exp-indent) + (/= (cdar c-exp-indent) (+ *ind-offset* *ind-length*)) + ) + ;; A new statement, i.e. not just joining a multiline one + (push + (cons + (offset-indentation *ind-offset* :resolve t) + (+ *ind-offset* *ind-length*) + ) + c-exp-indent + ) + ;; Update start of statement + (rplaca + (car c-exp-indent) + (offset-indentation *ind-offset* :resolve t) + ) + ) + (when (consp (cdr c-exp-indent)) + (if (and + (zerop c-complex) + (zerop c-cases) + (zerop c-bra) + (= (caar c-exp-indent) (caadr c-exp-indent)) + ) + ;; Two statements with the same indentation + (progn + (setq *indent* (caar c-exp-indent)) + (indent-macro-reject-left) + ) + ;; Different indentation or complex state + (progn + (rplacd c-exp-indent nil) + (setq c-complex 0) + ) + ) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle braces + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :stat + ;; If block finishes before current line, group as a statement + (< (+ *ind-offset* *ind-length*) *ind-start*) + ((:obrace (not :obrace) :cbrace)) + ) + (indreduce :obrace + ;; If not in the first line + (< *ind-offset* *ind-start*) + ;; If the opening { is the first non blank char in the line + ((:indent :obrace)) + (setq *indent* (offset-indentation (+ *ind-offset* *ind-length*))) + + ;; XXX This may be the starting brace of a switch + (setq c-case-flag nil) + (indent-macro-reject-left) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Labels + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; XXX this frequently doesn't do what is expected, should redefine + ;; some rules, as it frequently will dedent while typing something + ;; like test ? exp1 : exp2 + ;; ^ dedents here because it reduces everything + ;; before ':' to a single :expression token. + (indreduce :label + t + ((:indent :expression :collon :eol)) + (when (and *label-dedent* (>= *ind-offset* *ind-start*)) + (setq + *indent* + (- (offset-indentation *ind-offset* :resolve t) *base-indent*) + ) + (indent-macro-reject-left) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle if + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :if + t + ((:c-if :parens) + ) + (incf c-complex) + ) + + (indreduce :else + t + ((:c-else)) + (incf c-complex) + ) + + ;; Join + (indreduce :else-if + t + ((:else :if) + (:else :eol :indent :if) + ) + (incf c-complex) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle for + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Join with the parentheses + (indreduce :for + t + ((:c-for :parens) + ) + (incf c-complex) + ) + ;; Before current line, simplify + (indreduce :stat + (< (+ *ind-offset* *ind-length*) *ind-point*) + ((:for :stat) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle while and do + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :while + t + ((:c-while :parens) + ;; Assume that it is yet being edited, or adjusting indentation + (:c-while) + ) + (incf c-complex) + ) + (indreduce :stat + t + ((:do :stat :while) + (:while :stat) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle switch + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indinit c-case-flag) + + (indreduce :switch + t + ((:c-switch :parens) + ) + ) + ;; Transform in a statement + (indreduce :stat + (< (+ *ind-offset* *ind-length*) *ind-start*) + ((:switch :stat) + ;; Do it now or some rule may stop parsing, and calculate + ;; a wrong indentation for nested switches + (:switch :eol :indent :stat) + ) + ) + ;; An open switch + (indreduce :obrace + (and + (<= c-braces 0) + (> *ind-start* *ind-offset*) + ) + ((:indent :switch :obrace) + ) + (setq + *indent* (offset-indentation *ind-offset* :resolve t) + c-case-flag nil + ) + (indent-macro-reject-left) + ) + (indreduce :obrace + (and + (<= c-braces 0) + (> *ind-start* *ind-offset*) + ) + ((:indent :switch :eol :indent :obrace) + ) + (setq + *indent* (- (offset-indentation *ind-offset* :resolve t) *base-indent*) + c-case-flag nil + ) + (and *brace-indent* (incf *indent* *base-indent*)) + (indent-macro-reject-left) + ) + ;; Before current line + (indreduce :case + (and + (or + (not *case-indent*) + (prog1 c-case-flag (setq c-case-flag t)) + ) + (<= c-braces 0) + (< *ind-offset* *ind-start*) + ) + ((:indent :case) + ) + (setq + *indent* (offset-indentation *ind-offset* :resolve t) + c-case-flag nil + ) + (indent-macro-reject-left) + ) + (indreduce :case + t + ((:c-case :expression :collon) + (:c-default :collon) + ;; Assume that it is yet being edited, or adjusting indentation + (:c-case) + (:c-default) + ) + (and (>= *ind-offset* *ind-start*) + (incf c-cases) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle parentheses and brackets + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Reduce matches + (indreduce :parens + t + ((:oparen (not :oparen) :cparen)) + (when + (and + (< *ind-offset* *ind-start*) + (> (+ *ind-offset* *ind-length*) *ind-start*) + ) + (setq *indent* (1+ (offset-indentation *ind-offset* :align t))) + (indent-macro-reject-left) + ) + ) + (indreduce :bracks + t + ((:obrack (not :obrack) :cbrack)) + (when + (and + (< *ind-offset* *ind-start*) + (> (+ *ind-offset* *ind-length*) *ind-start*) + ) + (setq *indent* (1+ (offset-indentation *ind-offset* :align t))) + (indent-macro-reject-left) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Assuming previous lines have correct indentation, this allows + ;; resolving the indentation fastly + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Line ended with an open brace + (indreduce :obrace + (< *ind-offset* *ind-start*) + ((:indent (or :for :while :if :else-if :else :do) :obrace) + ) + (setq *indent* (offset-indentation *ind-offset* :resolve t)) + (indent-macro-reject-left) + ) + ;; Adjust indentation level if current line starts with an open brace + (indreduce nil + (< *ind-offset* *ind-start* (+ *ind-offset* *ind-length*)) + ;; Just set initial indentation + ((:indent (or :for :while :if :else-if :else :do) :eol :indent :obrace) + ) + (setq + *indent* + (- (offset-indentation *ind-offset* :resolve t) *base-indent*) + ) + (and *brace-indent* (incf *indent* *base-indent*)) + (indent-macro-reject-left) + ) + ;; Previous rule failed, current line does not start with an open brace + (indreduce :flow + ;; first statement is in current line + (and + (<= c-braces 0) + (> (+ *ind-offset* *ind-length*) *ind-start* *ind-offset*) + ) + ((:indent (or :for :while :if :else-if :else :do) :eol :indent) + ) + (setq *indent* (offset-indentation *ind-offset* :resolve t)) + (indent-macro-reject-left) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Simplify, remove old (:eol :indent) + ;; This must be the last rule, to avoid not matching the + ;; rules for fast calculation of indentation above + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce nil + (> *ind-offset* c-prev-offset) + ((:eol :indent)) + ) + + + (indinit (c-flow 0)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; If + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indinit c-if-flow) + (indresolve :if + (and (< *ind-offset* *ind-start*) + (push c-flow c-if-flow) + (incf *indent* *base-indent*) + (incf c-flow) + ) + ) + (indresolve (:else-if :else) + (when c-if-flow + (while (< c-flow (car c-if-flow)) + (incf *indent* *base-indent*) + (incf c-flow) + ) + (or (eq *ind-token* :else-if) (pop c-if-flow)) + ) + (and (< *ind-offset* *ind-start*) + (incf *indent* *base-indent*) + (incf c-flow) + ) + ) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; For/while/do + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indinit c-do-flow) + (indresolve (:for :while :do) + (if (eq *ind-token* :do) + (and (< *ind-offset* *ind-start*) (push c-flow c-do-flow)) + (when (and c-do-flow (eq *ind-token* :while)) + (while (< c-flow (car c-do-flow)) + (incf *indent* *base-indent*) + (incf c-flow) + ) + (pop c-do-flow) + ) + ) + (and (< *ind-offset* *ind-start*) + (incf *indent* *base-indent*) + (incf c-flow) + ) + ) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Switch + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indresolve :switch + (setq c-case-flag nil) + ) + (indresolve (:case :c-case) + (if (< *ind-offset* *ind-start*) + (or c-case-flag + (setq + *indent* + (+ (offset-indentation *ind-offset* :resolve t) + *base-indent* + ) + ) + ) + (if c-case-flag + (and (= (decf c-cases) 0) + (decf *indent* *base-indent*) + ) + (or *case-indent* + (decf *indent* *base-indent*) + ) + ) + ) + (setq c-case-flag t) + ) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Braces/flow control + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indresolve :flow + (incf *indent* *base-indent*) + ) + (indresolve :obrace + (and (< *ind-offset* *ind-start*) + (incf *indent* *base-indent*) + ) + ) + (indresolve :cbrace + (decf *indent* *base-indent*) + (and *case-indent* c-case-flag + (decf *indent* *base-indent*) + (setq c-case-flag nil) + ) + (and (not *offset*) (>= *ind-offset* *ind-start*) + (setq *offset* *ind-offset*) + ) + ) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Statements + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indresolve :stat + (when (< *ind-offset* *ind-start*) + (while (> c-flow 0) + (setq + *indent* (- *indent* *base-indent*) + c-flow (1- c-flow) + ) + ) + ) + (and + *cont-indent* + (< *ind-offset* *ind-start*) + (> (+ *ind-offset* *ind-length*) *ind-start*) + (incf *indent* *base-indent*) + ) + ) + + (indresolve :expression + (and + *cont-indent* + (zerop c-bra) + (> *indent* 0) + (< *ind-offset* *ind-start*) + (> (+ *ind-offset* *ind-length*) *ind-start*) + (incf *indent* *base-indent*) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Open + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indresolve (:oparen :obrack) + (and (< *ind-offset* *ind-start*) + (setq *indent* (1+ (offset-indentation *ind-offset* :align t))) + ) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Find a "good" offset to start parsing backwards, so that it should +;; always generate the same results. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun c-offset-indent (&aux char (point (point))) + ;; Skip spaces forward + (while (member (setq char (char-after point)) indent-spaces) + (incf point) + ) + (or (characterp char) (return-from c-offset-indent point)) + + ;; Skip word chars + (when (alphanumericp char) + (while (and (setq char (char-after point)) (alphanumericp char)) + (incf point) + ) + (or (characterp char) (return-from c-offset-indent point)) + + ;; Skip spaces forward + (while (member (setq char (char-after point)) indent-spaces) + (incf point) + ) + (or (characterp char) (return-from c-offset-indent point)) + ) + + ;; don't include " or ' to avoid parsing strings "inverted" + (if (member char '(#\Newline #\" #\')) point (1+ point)) +) +(compile 'c-offset-indent) + +(defun c-should-indent (options) + (when (hash-table-p options) + ;; check if previous line has extra spaces + (and (gethash :trim-blank-lines options) + (indent-clear-empty-line) + ) + + ;; indentation disabled? + (and (gethash :disable-indent options) + (return-from c-should-indent) + ) + + (let* + ( + (point (point)) + (start (scan point :eol :left)) + (char (char-before point)) + offset + match + text + ) + + ;; at the start of an empty file + (or (characterp char) + (return-from c-should-indent) + ) + + ;; if at bol and should indent only when starting a line + (and (gethash :only-newline-indent options) + (return-from c-should-indent (= point start)) + ) + + (and + (char= char #\;) + (gethash :newline-after-semi options) + (return-from c-should-indent t) + ) + + ;; if one of these was typed, must check indentation + (and (member char '(#\{ #\} #\: #\] #\) #\#)) + (return-from c-should-indent t) + ) + + ;; at the start of a line + (and (= point start) + (return-from c-should-indent (gethash :newline-indent options)) + ) + + ;; if first character + (and (= point (1+ start)) + (return-from c-should-indent t) + ) + + ;; check if is the first non-blank character in a new line + (when + (and + (gethash :cont-indent options) + (= point (scan point :eol :right)) + (alphanumericp char) + ) + (setq offset (1- point)) + (while + (and + (> offset start) + (member (char-before offset) indent-spaces) + ) + (decf offset) + ) + ;; line has only one character with possible spaces before it + (and (<= offset start) + (return-from c-should-indent t) + ) + ) + + ;; check for keywords that change indentation + (when (alphanumericp char) + (setq offset (1- point)) + (while + (and + (alphanumericp (char-before offset)) + (> offset start) + ) + (decf offset) + ) + (setq + text (read-text offset (- point offset)) + match (re-exec #.(re-comp "(case|else|while)\\w?\\>") + text) + ) + (and + (consp match) + (return-from c-should-indent (<= (- (caar match) offset) 2)) + ) + ) + ) + ) + ;; Should not indent + nil +) +(compile 'c-should-indent) + + +(defun c-indent-check (syntax syntable options + &aux start point char left brace change) + (setq + point (point) + char (char-before point) + left point + brace (member char '(#\{ #\})) + ) + + (when + (and brace (gethash :newline-before-brace options)) + (setq start (scan point :eol :left)) + (while + (and + (> (decf left) start) + (member (char-before left) indent-spaces) + ) + ;; skip blanks + ) + (when (> left start) + (replace-text left left (string #\Newline)) + (c-indent syntax syntable) + (setq change t) + ) + ) + + (when + (or + (and brace (not change) (gethash :newline-after-brace options)) + (and (char= char #\;) (gethash :newline-after-semi options)) + ) + (setq left (point)) + (replace-text left left (string #\Newline)) + (goto-char (1+ left)) + (c-indent syntax syntable) + ) +) + +(defun c-indent (syntax syntable) + (let* + ( + (options (syntax-options syntax)) + *base-indent* + *brace-indent* + *case-indent* + *label-dedent* + *cont-indent* + ) + + (or (c-should-indent options) (return-from c-indent)) + + (setq + *base-indent* (gethash :indentation options 4) + *brace-indent* (gethash :brace-indent options nil) + *case-indent* (gethash :case-indent options t) + *label-dedent* (gethash :label-dedent options t) + *cont-indent* (gethash :cont-indent options t) + ) + + (indent-macro + *c-mode-indent* + (c-offset-indent) + (gethash :emulate-tabs options) + ) + + (c-indent-check syntax syntable options) + ) +) +(compile 'c-indent) + +(defsyntax *c-mode* :main nil #'c-indent *c-mode-options* + ;; All recognized C keywords. + (syntoken + (string-concat + "\\<(" + "asm|auto|break|case|catch|char|class|const|continue|default|" + "delete|do|double|else|enum|extern|float|for|friend|goto|if|" + "inline|int|long|new|operator|private|protected|public|register|" + "return|short|signed|sizeof|static|struct|switch|template|this|" + "throw|try|typedef|union|unsigned|virtual|void|volatile|while" + ")\\>") + :property *prop-keyword*) + + ;; Numbers, this is optional, comment this rule if xedit is + ;; too slow to load c files. + (syntoken + (string-concat + "\\<(" + ;; Integers + "(\\d+|0x\\x+)(u|ul|ull|l|ll|lu|llu)?|" + ;; Floats + "\\d+\\.?\\d*(e[+-]?\\d+)?[lf]?" + ")\\>") + :icase t + :property *prop-number* + ) + + ;; String start rule. + (syntoken "\"" :nospec t :begin :string :contained t) + + ;; Character start rule. + (syntoken "'" :nospec t :begin :character :contained t) + + ;; Preprocessor start rule. + (syntoken "^\\s*#\\s*\\w+" :begin :preprocessor :contained t) + + ;; Comment start rule. + (syntoken "/*" :nospec t :begin :comment :contained t) + + ;; C++ style comments. + (syntoken "//.*" :property *prop-comment*) + + ;; Punctuation, this is also optional, comment this rule if xedit is + ;; too slow to load c files. + (syntoken "[][(){}/*+:;=<>,&.!%|^~?-][][(){}*+:;=<>,&.!%|^~?-]?" + :property *prop-punctuation*) + + + ;; Rules for comments. + (syntable :comment *prop-comment* #'default-indent + ;; Match nested comments as an error. + (syntoken "/*" :nospec t :property *prop-error*) + + (syntoken "XXX|TODO|FIXME" :property *prop-annotation*) + + ;; Rule to finish a comment. + (syntoken "*/" :nospec t :switch -1) + ) + + ;; Rules for strings. + (syntable :string *prop-string* #'default-indent + ;; Ignore escaped characters, this includes \". + (syntoken "\\\\.") + + ;; Match, most, printf arguments. + (syntoken "%%|%([+-]?\\d+)?(l?[deEfgiouxX]|[cdeEfgiopsuxX])" + :property *prop-format*) + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Rule to finish a string. + (syntoken "\"" :nospec t :switch -1) + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" :begin :error) + ) + + ;; Rules for characters. + (syntable :character *prop-constant* nil + ;; Ignore escaped characters, this includes \'. + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Rule to finish a character constant. + (syntoken "'" :nospec t :switch -1) + + ;; Don't allow constants continuing in the next line. + (syntoken ".?$" :begin :error) + ) + + ;; Rules for preprocessor. + (syntable :preprocessor *prop-preprocessor* #'default-indent + ;; Preprocessor includes comments. + (syntoken "/*" :nospec t :begin :comment :contained t) + + ;; Ignore lines finishing with a backslash. + (syntoken "\\\\$") + + ;; Return to previous state if end of line found. + (syntoken ".?$" :switch -1) + ) + + (syntable :error *prop-error* nil + (syntoken "^.*$" :switch -2) + ) + + ;; You may also want to comment this rule if the parsing is + ;; noticeably slow. + (syntoken "\\c" :property *prop-control*) +) diff --git a/lisp/modules/progmodes/html.lsp b/lisp/modules/progmodes/html.lsp new file mode 100644 index 0000000..86f8eea --- /dev/null +++ b/lisp/modules/progmodes/html.lsp @@ -0,0 +1,327 @@ +;; +;; Copyright (c) 2002 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/modules/progmodes/html.lsp,v 1.3 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +#| + This is not a validation tool for html. + + It is possible to, using macros generate all combinations of text attributes, + to properly handle <b>...<i>...</i>...</b> etc, as well as generating macros + to automatically closing tags, but for now this file was built to work as an + experience with the syntax highlight code. +|# + +(defsynprop *prop-html-default* + "default" + :font "-*-lucida-medium-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Gray10") + +(defsynprop *prop-html-bold* + "bold" + :font "-*-lucida-bold-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-italic* + "italic" + :font "-*-lucida-medium-i-*-*-14-*-*-*-*-*-*-1" + :foreground "Gray10") + +(defsynprop *prop-html-pre* + "pre" + :font "-*-courier-medium-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Gray10") + +(defsynprop *prop-html-link* + "link" + :font "-*-lucida-medium-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Blue" + :underline "t") + +(defsynprop *prop-html-small* + "small" + :font "-*-lucida-medium-r-*-*-10-*-*-*-*-*-*-1" + :foreground "Gray10") + +(defsynprop *prop-html-big* + "big" + :font "-*-lucida-medium-r-*-*-20-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-name* + "name" + :font "-*-lucida-bold-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Black" + :background "rgb:e/f/e") + +(defsynprop *prop-html-h1* + "h1" + :font "-*-lucida-bold-r-*-*-20-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-h2* + "h2" + :font "-*-lucida-bold-r-*-*-17-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-h4* + "h4" + :font "-*-lucida-bold-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-h5* + "h5" + :font "-*-lucida-bold-r-*-*-10-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-li* + "li" + :font "-*-lucida-bold-r-*-*-8-*-*-*-*-*-*-1" + :foreground "rgb:0/5/0" + :underline t) + +(defsynprop *prop-html-hr* + "hr" + :font "-*-courier-bold-r-*-*-12-*-*-*-*-*-*-1" + :foreground "rgb:0/5/0" + :overstrike t) + +(defsynprop *prop-html-title* + "title" + :font "-*-lucida-medium-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Red3" + :underline "t") + +(defsynprop *prop-html-tag* + "tag" + :font "-*-courier-medium-r-*-*-10-*-*-*-*-*-*-1" + :foreground "green4") + +(defsynprop *prop-html-string* + "string" + :font "-*-lucida-medium-r-*-*-10-*-*-*-*-*-*-1" + :foreground "RoyalBlue2") + +(defsynprop *prop-html-comment* + "comment" + :font "-*-courier-medium-o-*-*-10-*-*-*-*-*-*-1" + :foreground "SlateBlue3") + +(defsynprop *prop-html-entity* + "entity" + :font "-*-lucida-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Red4") + +(defsynprop *prop-html-unknown* + "unknown" + :font "-*-courier-bold-r-*-*-10-*-*-*-*-*-*-1" + :foreground "yellow" + :background "red") + +(defmacro html-syntoken (name) + `(syntoken (string-concat "<" ,name "\\>") + :icase t :contained t + :begin (intern (string-concat ,name "$") 'keyword))) +(defmacro html-syntable (name property) + `(let + ((label (intern (string-concat ,name "$") 'keyword)) + (nested-label (intern (string (gensym)) 'keyword))) + (syntable label *prop-html-tag* nil + (synaugment :generic-tag) + (syntoken ">" :nospec t :property *prop-html-tag* :begin nested-label) + (syntable nested-label ,property nil + (syntoken (string-concat "</" ,name ">") + :icase t :nospec t :property *prop-html-tag* :switch -2) + (syntoken (string-concat "</" ,name "\\s*$") + :icase t :contained t :begin :continued-end-tag) + (synaugment :main))))) + + +(defsyntax *html-mode* :main *prop-html-default* nil nil + (syntoken "<!--" :nospec t :contained t :begin :comment) + (syntable :comment *prop-html-comment* nil + (syntoken "-->" :nospec t :switch -1)) + (syntoken "&([a-zA-Z0-9_.-]+|#\\x\\x?);?" :property *prop-html-entity*) + (syntoken "<li>" :nospec t :icase t :property *prop-html-li*) + (syntoken "<hr>" :nospec t :icase t :property *prop-html-hr*) + + (syntoken "<img\\>" :icase t :contained t :begin :tag) + (syntoken "<(p|br)>" :icase t :property *prop-html-tag*) + + ;; If in the toplevel, unbalanced! + ;; XXX When adding new nested tables, don't forget to update this pattern. + (syntoken + (string-concat + "</(" + "b|strong|i|em|address|pre|code|tt|small|big|a|span|div|" + "h1|h2|h3|h4|h5|title|font|ol|ul|dl|dt|dd|menu" + ")\\>") + :icase t :property *prop-html-unknown* :begin :unbalanced) + (syntable :unbalanced *prop-html-unknown* nil + (syntoken ">" :nospec t :switch :main) + (synaugment :generic-tag) + ) + + #|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + ;; XXX ONLY add a rule for "html", "head" and "body" if you want to do a + ;; more complete check for common errors. If you add those rules, it will + ;; reparse the entire file at every character typed (unless there are + ;; errors in which case the parser resets the state). + ;; For visualization only that would be OK... + ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||# + + (html-syntoken "b") + (html-syntable "b" *prop-html-bold*) + (html-syntoken "strong") + (html-syntable "strong" *prop-html-bold*) + + (html-syntoken "i") + (html-syntable "i" *prop-html-italic*) + (html-syntoken "em") + (html-syntable "em" *prop-html-italic*) + (html-syntoken "address") + (html-syntable "address" *prop-html-italic*) + + (html-syntoken "pre") + (html-syntable "pre" *prop-html-pre*) + (html-syntoken "code") + (html-syntable "code" *prop-html-pre*) + (html-syntoken "tt") + (html-syntable "tt" *prop-html-pre*) + + (html-syntoken "small") + (html-syntable "small" *prop-html-small*) + + (html-syntoken "big") + (html-syntable "big" *prop-html-big*) + + ;; Cannot hack html-syntoken and html-syntable to handle this, + ;; as the option to <a may be in the next line. + (syntoken "<a\\>" :icase t :contained t :begin :a) + (syntable :a *prop-html-tag* nil + ;; Tag is open + (syntoken "\\<href\\>" :icase t :begin :a-href) + (syntoken "\\<name\\>" :icase t :begin :a-name) + (syntoken "<" :nospec t :property *prop-html-unknown* :switch -2) + (synaugment :generic-tag) + (syntoken ">" :nospec t :begin :a-generic-text) + (syntable :a-href *prop-html-tag* nil + (syntoken ">" :nospec t :begin :a-href-text) + (synaugment :generic-tag) + (syntable :a-href-text *prop-html-link* nil + (syntoken "</a>" + :icase t :nospec t :property *prop-html-tag* :switch -3) + (syntoken "</a\\s*$" :icase t :begin :continued-nested-end-tag) + (synaugment :main) + ) + ) + (syntable :a-name *prop-html-tag* nil + (syntoken ">" :nospec t :begin :a-name-text) + (synaugment :generic-tag) + (syntable :a-name-text *prop-html-name* nil + (syntoken "</a>" + :icase t :nospec t :property *prop-html-tag* :switch -3) + (syntoken "</a\\s*$" :icase t :begin :continued-nested-end-tag) + (synaugment :main) + ) + ) + (syntable :a-generic-text nil nil + (syntoken "</a>" + :icase t :nospec t :property *prop-html-tag* :switch -2) + (syntoken "<a/\\s$" :icase t :begin :continued-end-tag) + (synaugment :main) + ) + ) + + ;; Do nothing, just check start/end tags + (html-syntoken "ol") + (html-syntable "ol" nil) + (html-syntoken "ul") + (html-syntable "ul" nil) + (html-syntoken "dl") + (html-syntable "dl" nil) + ;; Maybe <dt> and <dd> should be in a special table, to not require + ;; and ending tag. + ;; XXX Maybe should also add a table for <p>. + (html-syntoken "dt") + (html-syntable "dt" nil) + (html-syntoken "dd") + (html-syntable "dd" nil) + + (html-syntoken "span") + (html-syntable "span" nil) + (html-syntoken "div") + (html-syntable "div" nil) + (html-syntoken "menu") + (html-syntable "menu" nil) + + (html-syntoken "h1") + (html-syntable "h1" *prop-html-h1*) + (html-syntoken "h2") + (html-syntable "h2" *prop-html-h2*) + (html-syntoken "h3") + (html-syntable "h3" *prop-html-bold*) + (html-syntoken "h4") + (html-syntable "h4" *prop-html-h4*) + (html-syntoken "h5") + (html-syntable "h5" *prop-html-h5*) + (html-syntoken "title") + (html-syntable "title" *prop-html-title*) + + (html-syntoken "font") + (html-syntable "font" *prop-control*) + + (syntoken "<" :nospec t :contained t :begin :tag) + (syntable :generic-tag *prop-html-tag* nil + (syntoken "\"" :nospec t :contained t :begin :string) + (syntoken "<" :nospec t :property *prop-html-unknown*) + ) + (syntable :tag *prop-html-tag* nil + (syntoken ">" :nospec t :switch -1) + (synaugment :generic-tag) + ) + ;; Tag ended in a newline, common practice... + (syntable :continued-end-tag *prop-html-tag* nil + (syntoken ">" :nospec t :switch -3) + (synaugment :generic-tag) + ) + (syntable :continued-nested-end-tag *prop-html-tag* nil + (syntoken ">" :nospec t :switch -4) + (synaugment :generic-tag) + ) + + (syntable :string *prop-html-string* nil + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -1) + ) +) diff --git a/lisp/modules/progmodes/imake.lsp b/lisp/modules/progmodes/imake.lsp new file mode 100644 index 0000000..ea34ed6 --- /dev/null +++ b/lisp/modules/progmodes/imake.lsp @@ -0,0 +1,188 @@ +;; +;; Copyright (c) 2002 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/modules/progmodes/imake.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-shell* + "shell" + :font "*courier-bold-r*12*" + :foreground "Red4" +) + +(defsynprop *prop-variable* + "variable" + :font "*courier-medium-r*12*" + :foreground "Red3" +) + +;; The syntax-highlight definition does not try to flag errors, just show +;; tabs in the start of lines for better visualization. +(defsynprop *prop-tabulation* + "tabulation" + :font "*courier-medium-r*12*" + :background "Gray90" +) + +(defsynprop *prop-xcomm* + "xcomm" + :font "*courier-medium-o*12*" + :foreground "SkyBlue4" +) + + +(defsyntax *imake-mode* :main nil nil nil + (syntoken "^\\s*XCOMM\\W?.*$" + :property *prop-xcomm*) + + (syntoken "^\\t+" + :property *prop-tabulation*) + + (syntoken "$(" + :nospec t + :begin :shell + :property *prop-shell*) + + (syntoken "[][(){};$<=>&@/\\,.:~!|*?'`+-]" + :property *prop-shell*) + + ;; Preprocessor start rule. + (syntoken "^\\s*#\\s*\\w+" + :begin :preprocessor + :contained t) + + ;; Comment start rule. + (syntoken "/*" + :nospec t + :begin :comment + :contained t) + + ;; String start rule. + (syntoken "\"" + :begin :string + :nospec t + :contained t) + + ;; Quoted string start rule. + (syntoken "\\\"" + :begin :quoted-string + :nospec t + :contained t) + + (syntable :shell *prop-variable* nil + (syntoken ")" + :nospec t + :property *prop-shell* + :switch -1) + ) + + ;; Rules for comments. + (syntable :comment *prop-comment* nil + + ;; Match nested comments as an error. + (syntoken "/*" + :nospec t + :property *prop-error*) + + (syntoken "XXX|TODO|FIXME" + :property *prop-annotation*) + + ;; Rule to finish a comment. + (syntoken "*/" + :nospec t + :switch -1) + ) + + ;; Rules for preprocessor. + (syntable :preprocessor *prop-preprocessor* nil + + ;; Preprocessor includes comments. + (syntoken "/*" + :nospec t + :begin :comment + :contained t) + + ;; Visualization help, show tabs in the start of lines. + (syntoken "^\\t+" + :property *prop-tabulation*) + + ;; Ignore lines finishing with a backslash. + (syntoken "\\\\$") + + ;; Return to previous state if end of line found. + (syntoken ".?$" + :switch -1) + ) + + ;; Rules for strings. + (syntable :string *prop-string* nil + + ;; Ignore escaped characters, this includes \". + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Rule to finish a string. + (syntoken "\"" + :nospec t + :switch -1) + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" + :begin :error) + ) + + ;; Rules for quoted strings. + (syntable :quoted-string *prop-constant* nil + + ;; Rule to finish the quoted string. + (syntoken "\\\"" + :nospec t + :switch -1) + + ;; Ignore escaped characters + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" + :begin :error) + ) + + (syntable :error *prop-error* nil + (syntoken "^.*$" + :switch -2) + ) +) diff --git a/lisp/modules/progmodes/lisp.lsp b/lisp/modules/progmodes/lisp.lsp new file mode 100644 index 0000000..ebf2c10 --- /dev/null +++ b/lisp/modules/progmodes/lisp.lsp @@ -0,0 +1,384 @@ +;; +;; Copyright (c) 2002 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/modules/progmodes/lisp.lsp,v 1.9 2003/01/30 02:46:26 paulo Exp $ +;; + +(require "syntax") +(require "indent") +(in-package "XEDIT") + +(defsynprop *prop-special* + "special" + :font "*courier-bold-r*12*" + :foreground "NavyBlue" +) + +(defsynprop *prop-quote* + "quote" + :font "*courier-bold-r*12*" + :foreground "Red3" +) + +(defsynprop *prop-package* + "package" + :font "*lucidatypewriter-medium-r*12*" + :foreground "Gold4" +) + +(defsynprop *prop-unreadable* + "unreadable" + :font "*courier-medium-r*12*" + :foreground "Gray25" + :underline t +) + +(defsynoptions *lisp-DEFAULT-style* + ;; Positive number. Basic indentation. + (:indentation . 2) + + ;; Boolean. Move cursor to the indent column after pressing <Enter>? + (:newline-indent . t) + + ;; Boolean. Use spaces instead of tabs to fill indentation? + (:emulate-tabs . nil) + + ;; Boolean. Remove extra spaces from previous line. + ;; This should default to T when newline-indent is not NIL. + (:trim-blank-lines . t) + + ;; Boolean. If this hash-table entry is set, no indentation is done. + ;; Useful to temporarily disable indentation. + (:disable-indent . nil) +) + +(defvar *lisp-mode-options* *lisp-DEFAULT-style*) + +(defindent *lisp-mode-indent* :main + ;; this must be the first token + (indtoken "^\\s*" :indent + :code (or *offset* (setq *offset* (+ *ind-offset* *ind-length*)))) + ;; ignore single line comments + (indtoken ";.*$" nil) + ;; multiline comments + (indtoken "|#" :comment :nospec t :begin :comment) + ;; characters + (indtoken "#\\\\(\\W|\\w+(-\\w+)?)" :character) + ;; numbers + (indtoken + (string-concat + "(\\<|[+-])\\d+(" + ;; integers + "(\\>|\\.(\\s|$))|" + ;; ratios + "/\\d+\\>|" + ;;floats + "\\.?\\d*([SsFfDdLlEe][+-]?\\d+)?\\>" + ")") + :number) + ;; symbols, with optional package + (indtoken + (string-concat + ;; optional package name and ending ':' + "([A-Za-z_0-9%-]+:)?" + ;; internal symbol if after package name, or keyword + ":?" + ;; symbol name + "[][{}A-Za-z_0-9!$%&/<=>^~*+-]+") + :symbol) + ;; strings in the same line + (indtoken "\"([^\\\"]|\\\\.)*\"" :string) + ;; multiline strings + (indtoken "\"" :cstring :nospec t :begin :string) + ;; "quoted" symbols in the same line + (indtoken "\\|([^\\|]|\\\\.)*\\|" :symbol) + ;; multiline + (indtoken "|" :csymbol :nospec t :begin :symbol) + (indtoken "#" :hash :nospec t) + + (indinit (parens 0)) + (indtoken "(" :oparen :nospec t :code (incf parens)) + (indtoken ")" :cparen :nospec t :code (decf parens)) + + (indtable :comment + ;; multiline comments can nest + (indtoken "|#" nil :nospec t :begin :comment) + (indtoken "#|" nil :nospec t :switch -1)) + + (indtable :string + ;; Ignore escaped characters + (indtoken "\\." nil) + ;; Return to the toplevel when the start of the string is found + (indtoken "\"" :ostring :nospec t :switch -1)) + + (indtable :symbol + ;; Ignore escaped characters + (indtoken "\\." nil) + ;; Return to the toplevel when the start of the symbol is found + (indtoken "|" :osymbol :nospec t :switch -1)) + + ;; ignore comments + (indreduce nil + t + ((:comment))) + + ;; reduce multiline strings + (indreduce :string + t + ((:ostring (not :ostring) :cstring))) + + ;; reduce multiline symbols + (indreduce :symbol + t + ((:osymbol (not :osymbol) :csymbol))) + + ;; reduce basic types, don't care if inside list or not + (indreduce :element + t + ((:number) + (:string) + (:character) + (:element :element) + (:indent :element))) + + (indreduce :symbol + t + ((:symbol :symbol) + (:symbol :element) + (:indent :symbol))) + + ;; the "real" indentation value, to make easier parsing code like: + ;; (foo (bar (baz (blah + ;; ^ ^ + ;; | | + ;; indent | + ;; effective indentation to be used + (indinit (indent 0)) + + ;; indentation values of opening parenthesis. + (indinit stack) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; if before current line and open parenthesis >= 0, use indentation + ;; of current line to calculate relative indentation. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :oparen ;; simple list? + (and (>= parens 0) (< *ind-offset* *ind-start*)) + ((:indent :oparen)) + (setq + *indent* (offset-indentation (+ *ind-offset* *ind-length*) :resolve t) + indent *indent*) + (indent-macro-reject-left)) + + ;; reduce list if there isn't indentation change + (indreduce :element + t + ((:oparen (not :oparen) :cparen))) + + (indresolve :oparen + (setq + *indent* + (offset-indentation + (+ *ind-offset* *ind-length* -1 *base-indent*) :align t)) + (push *indent* stack) + (incf indent *base-indent*) + (if (< *indent* indent) (setq *indent* indent))) + + (indresolve :cparen + (decf indent *base-indent*) + (setq *indent* (pop stack)) + (if (null stack) + (setq *indent* indent) + (setq *indent* (car stack)))) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Find a "good" offset to start parsing backwards, so that it should +;; always generate the same results. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun lisp-offset-indent (&aux char (point (scan (point) :eol :left))) + ;; skip spaces + (while (member (setq char (char-after point)) indent-spaces) + (incf point)) + (if (member char '(#\))) (1+ point) point)) + +(defun lisp-should-indent (options &aux char point start) + (when (hash-table-p options) + ;; check if previous line has extra spaces + (and (gethash :trim-blank-lines options) + (indent-clear-empty-line)) + + ;; indentation disabled? + (and (gethash :disable-indent options) + (return-from lisp-should-indent)) + + (setq + point (point) + char (char-before (point)) + start (scan point :eol :left)) + + ;; at the start of a line + (and (= point start) + (return-from lisp-should-indent (gethash :newline-indent options))) + + ;; if first character + (and (= point (1+ start)) (return-from lisp-should-indent t)) + + ;; if closing parenthesis and first nonblank char + (when (and (characterp char) (char= char #\))) + (decf point) + (while + (and (> point start) (member (char-before point) indent-spaces)) + (decf point)) + (return-from lisp-should-indent (<= point start))) + ) + ;; should not indent + nil) + +(defun lisp-indent (syntax syntable) + (let* + ((options (syntax-options syntax)) + *base-indent*) + + (or (lisp-should-indent options) (return-from lisp-indent)) + + (setq *base-indent* (gethash :indentation options 2)) + + (indent-macro + *lisp-mode-indent* + (lisp-offset-indent) + (gethash :emulate-tabs options)))) + +(compile 'lisp-indent) + +(defsyntax *lisp-mode* :main nil #'lisp-indent *lisp-mode-options* + ;; highlight car and parenthesis + (syntoken "\\(+\\s*[][{}A-Za-z_0-9!$%&/<=>?^~*:+-]*\\)*" + :property *prop-keyword*) + (syntoken "\\)+" :property *prop-keyword*) + + ;; nil and t + (syntoken "\\<(nil|t)\\>" :icase t :property *prop-special*) + + (syntoken "|" :nospec t :begin :unreadable :contained t) + + ;; keywords + (syntoken ":[][{}A-Za-z_0-9!$%&/<=>^~+-]+" :property *prop-constant*) + + ;; special symbol. + (syntoken "\\*[][{}A-Za-z_0-9!$%&7=?^~+-]+\\*" + :property *prop-special*) + + ;; special identifiers + (syntoken "&(aux|key|optional|rest)\\>" :icase t :property *prop-constant*) + + ;; numbers + (syntoken + ;; since lisp is very liberal in what can be a symbol, this pattern + ;; will not always work as expected, since \< and \> will not properly + ;; work for all characters that may be in a symbol name + (string-concat + "(\\<|[+-])\\d+(" + ;; integers + "(\\>|\\.(\\s|$))|" + ;; ratios + "/\\d+\\>|" + ;;floats + "\\.?\\d*([SsFfDdLlEe][+-]?\\d+)?\\>" + ")") + :property *prop-number*) + + ;; characters + (syntoken "#\\\\(\\W|\\w+(-\\w+)?)" :property *prop-constant*) + + ;; quotes + (syntoken "[`'.]|,@?" :property *prop-quote*) + + ;; package names + (syntoken "[A-Za-z_0-9%-]+::?" :property *prop-package*) + + ;; read time evaluation + (syntoken "#\\d+#" :property *prop-preprocessor*) + (syntoken "#([+'cCsS-]|\\d+[aA=])?" :begin :preprocessor :contained t) + + (syntoken "\\c" :property *prop-control*) + + ;; symbols, do nothing, just resolve conflicting matches + (syntoken "[][{}A-Za-z_0-9!$%&/<=>^~*+-]+") + + (syntable :simple-comment *prop-comment* nil + (syntoken "$" :switch -1) + (syntoken "XXX|FIXME|TODO" :property *prop-annotation*)) + + (syntable :comment *prop-comment* nil + ;; comments can nest + (syntoken "#|" :nospec t :begin :comment) + ;; return to previous state + (syntoken "|#" :nospec t :switch -1) + (syntoken "XXX|FIXME|TODO" :property *prop-annotation*)) + + (syntable :unreadable *prop-unreadable* nil + ;; ignore escaped characters + (syntoken "\\\\.") + (syntoken "|" :nospec t :switch -1)) + + (syntable :string *prop-string* nil + ;; ignore escaped characters + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -1)) + + (syntable :preprocessor *prop-preprocessor* nil + ;; a symbol + (syntoken "[][{}A-Za-z_0-9!$%&/<=>^~:*+-]+" :switch -1) + + ;; conditional expression + (syntoken "(" :nospec t :begin :preprocessor-expression :contained t) + + (syntable :preprocessor-expression *prop-preprocessor* nil + ;; recursive + (syntoken "(" :nospec t :begin :preprocessor-recursive :contained t) + (syntoken ")" :nospec t :switch -2) + + (syntable :preprocessor-recursive *prop-preprocessor* nil + (syntoken "(" :nospec t + :begin :preprocessor-recursive + :contained t) + (syntoken ")" :nospec t :switch -1) + (synaugment :comments-and-strings)) + (synaugment :comments-and-strings)) + (synaugment :comments-and-strings)) + + (syntable :comments-and-strings nil nil + (syntoken "\"" :nospec t :begin :string :contained t) + (syntoken "#|" :nospec t :begin :comment :contained t) + (syntoken ";" :begin :simple-comment :contained t)) + + (synaugment :comments-and-strings) +) diff --git a/lisp/modules/progmodes/make.lsp b/lisp/modules/progmodes/make.lsp new file mode 100644 index 0000000..d5cbc00 --- /dev/null +++ b/lisp/modules/progmodes/make.lsp @@ -0,0 +1,135 @@ +;; +;; Copyright (c) 2002 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/modules/progmodes/make.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-shell* + "shell" + :font "*courier-bold-r*12*" + :foreground "Red4" +) + +(defsynprop *prop-variable* + "variable" + :font "*courier-medium-r*12*" + :foreground "Red3" +) + +;; The syntax-highlight definition does not try to flag errors, just show +;; tabs in the start of lines for better visualization. +(defsynprop *prop-tabulation* + "tabulation" + :font "*courier-medium-r*12*" + :background "Gray90" +) + + +(defsyntax *make-mode* :main nil nil nil + (syntoken "^\\t+" :property *prop-tabulation*) + + (syntoken "^\\.\\w+" :property *prop-keyword*) + + (syntoken "$(" + :nospec t + :begin :shell + :property *prop-shell*) + + (syntoken "[][(){};$<=>&@/\\,.:~!|*?'`+-]" + :property *prop-shell*) + + ;; Preprocessor start rule. + (syntoken "#.*" + :property *prop-comment*) + + ;; String start rule. + (syntoken "\"" + :begin :string + :nospec t + :contained t) + + ;; Quoted string start rule. + (syntoken "\\\"" + :begin :quoted-string + :nospec t + :contained t) + + (syntable :shell *prop-variable* nil + (syntoken ")" + :nospec t + :property *prop-shell* + :switch -1) + ) + + ;; Rules for strings. + (syntable :string *prop-string* nil + + ;; Ignore escaped characters, this includes \". + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Rule to finish a string. + (syntoken "\"" + :nospec t + :switch -1) + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" + :begin :error) + ) + + ;; Rules for quoted strings. + (syntable :quoted-string *prop-constant* nil + + ;; Rule to finish the quoted string. + (syntoken "\\\"" + :nospec t + :switch -1) + + ;; Ignore escaped characters + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" + :begin :error) + ) + + (syntable :error *prop-error* nil + (syntoken "^.*$" + :switch -2) + ) +) diff --git a/lisp/modules/progmodes/man.lsp b/lisp/modules/progmodes/man.lsp new file mode 100644 index 0000000..77a59a8 --- /dev/null +++ b/lisp/modules/progmodes/man.lsp @@ -0,0 +1,160 @@ +;; +;; Copyright (c) 2002 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/modules/progmodes/man.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-man-b* + "b" + :font "*courier-bold-r*12*" + :foreground "gray12" +) + +(defsynprop *prop-man-i* + "i" + :font "*courier-medium-o*12*" + :foreground "black" +) + +(defsynprop *prop-man-bi* + "bi" + :font "*courier-bold-o*12*" + :foreground "gray20" +) + +(defsynprop *prop-man-th* + "th" + :font "-*-courier-*-*-*-*-18-*-*-*-*-*-*-1" + :foreground "Red3" +) + +(defsynprop *prop-man-sh* + "sh" + :font "-*-courier-*-*-*-*-14-*-*-*-*-*-*-1" + :foreground "OrangeRed3" +) + +(defsynprop *prop-man-ss* + "ss" + :font "-*-courier-*-*-*-*-12-*-*-*-*-*-*-1" + :foreground "Gold4" +) + +(defsynprop *prop-man-escape* + "escape" + :font "*lucidatypewriter-medium-r*12*" + :foreground "RoyalBlue4" +) + +(defsynprop *prop-man-string* + "string" + :font "*lucidatypewriter-bold-r*12*" + :foreground "RoyalBlue3" +; :underline t +) + +(defmacro man-syntoken (pattern) + `(syntoken (string-concat "^\\.(" ,pattern ")(\\s+|$)") + :icase t +; :contained t + :property *prop-preprocessor* + :begin (intern (string ,pattern) 'keyword))) + +(defmacro man-syntable (pattern property) + `(syntable (intern (string ,pattern) 'keyword) ,property nil + (syntoken "$" :switch -1) + (synaugment :extras))) + + +(defsyntax *man-mode* :main nil nil nil + (syntoken "^\\.\\\\\".*" + :property *prop-comment*) + + (man-syntoken "b|br|nm") + (man-syntable "b|br|nm" *prop-man-b*) + + (man-syntoken "i|ir|ri|ip") + (man-syntable "i|ir|ri|ip" *prop-man-i*) + + (man-syntoken "th|dt") + (man-syntable "th|dt" *prop-man-th*) + + (man-syntoken "sh") + (man-syntable "sh" *prop-man-sh*) + + (man-syntoken "ss") + (man-syntable "ss" *prop-man-ss*) + + (man-syntoken "bi") + (man-syntable "bi" *prop-man-bi*) + + ;; Anything not matched... + (syntoken "^\\.[a-z][a-z](\\s+|$)" + :icase t + :property *prop-preprocessor*) + + (syntable :extras nil nil + (syntoken "\\<__\\l+__\\>" + :property *prop-constant*) + (syntoken "\\\\fB" + :property *prop-preprocessor* + :begin :b) + (syntoken "\\\\fI" + :property *prop-preprocessor* + :begin :i) + (syntoken "\\\\f\\u" + :property *prop-preprocessor*) + + (syntoken "\\\\\\*?." + :property *prop-man-escape*) + + (syntoken "\"" + :property *prop-man-string*) + + (syntable :i *prop-man-i* nil + (syntoken "$" + :switch :main) + (syntoken "\\\\f\\u" + :property *prop-preprocessor* + :switch -1) + ) + (syntable :b *prop-man-b* nil + (syntoken "$" + :switch :main) + (syntoken "\\\\f\\u" + :property *prop-preprocessor* + :switch -1) + ) + ) + + (synaugment :extras) +) diff --git a/lisp/modules/progmodes/rpm.lsp b/lisp/modules/progmodes/rpm.lsp new file mode 100644 index 0000000..bd0cc6c --- /dev/null +++ b/lisp/modules/progmodes/rpm.lsp @@ -0,0 +1,166 @@ +;; +;; Copyright (c) 2003 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/modules/progmodes/rpm.lsp,v 1.1 2003/01/16 03:50:46 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +;; Only for testing, unifinished, good for viewing but too slow for real use... +#| +(defsynprop *prop-rpm-special* + "rpm-special" + :font "*courier-bold-r*12*" + :foreground "NavyBlue" +) + +(defsynprop *prop-rpm-escape* + "rpm-escape" + :font "*lucidatypewriter-medium-r*12*" + :foreground "Red3") + +;; main package is implicit +(defsyntax *rpm-mode* :package nil nil nil + (syntable :sections nil nil + (syntoken "^%package" + :icase t + :switch :package + ;; XXX :begin :package was added just to test finishing and + ;; starting a new syntax-table, unfortunately if using it + ;; this way, frequently the entire file will be reparsed + ;; at every character typed. + ;; TODO study these cases and implement code to avoid it, + ;; the easiest way is limiting the number of backtracked lines, + ;; the screen contents sometimes could not correctly reflect + ;; file contents in this case... + :begin :package + :property *prop-rpm-special*) + (syntoken "^%(build|setup|install|pre|preun|post|postun)\\>" + :icase t + :property *prop-rpm-special* + :switch :package + :begin :shell) + ;; %changelog, XXX no rules to return to the toplevel + (syntoken "^%changelog\\>" + :icase t + :switch :package + :begin :changelog + :property *prop-rpm-special*) + (syntable :changelog nil nil + ;; ignore if escaped + (syntoken "%%") + ;; "warn" if not escaped + (syntoken "%" :property *prop-control*) + ;; emails + (syntoken "<[a-z0-9_-]+@[a-z0-9_-]+\\.\\w+(\\.\\w+)?>" + :icase t + :property *prop-string*) + ) + ;; comments + (syntoken "#" :contained t :nospec t :begin :comment) + (syntable :comment *prop-comment* nil + ;; some macros are expanded even when inside comments, and may + ;; cause surprises, "warn" about it + (syntoken "%\\{?\\w+\\}?" :property *prop-rpm-special*) + (syntoken "$" :switch -1) + ) + (synaugment :global) + ) + + ;; may appear anywhere + (syntable :global nil nil + ;; preprocessor like commands + (syntoken "^%(define|if|ifarch|else|endif)\\>" + :icase t + :property *prop-preprocessor*) + ;; variables + (syntoken "%\\{.*\\}" :property *prop-constant*) + ) + + ;; example: "Group: ..." or "Group(pt_BR): ..." + (syntoken "^\\w+(\\(\\w+\\))?:" :property *prop-keyword*) + + ;; for sections with shell commands + (syntable :shell nil nil + (syntoken "\\<(if|then|elif|else|fi|for|do|done|case|esac|while|until)\\>" + :property *prop-keyword*) + (syntable :strings nil nil + (syntoken "\"" :nospec t :begin :string :contained t) + (syntable :string *prop-string* nil + (syntoken "\\$\\(?\\w+\\)?" :property *prop-constant*) + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -1) + ) + (syntoken "\'" :nospec t :begin :constant :contained t) + (syntable :constant *prop-constant* nil + (syntoken "\\\\.") + (syntoken "\'" :nospec t :switch -1) + ) + (syntoken "\`" :nospec t :begin :escape :contained t) + (syntable :escape *prop-rpm-escape* nil + (syntoken "\\$\\(?\\w+\\)?" :property *prop-constant*) + (syntoken "\\\\.") + (syntoken "\`" :nospec t :switch -1) + ) + ) + (synaugment :strings :sections) + ) + (synaugment :sections) +) +|# + + +(defsyntax *rpm-mode* :package nil nil nil + ;; commands, macro definitions, etc + (syntoken "^\\s*%\\s*\\w+" :property *prop-keyword*) + + ;; rpm "variables" + (syntoken "%\\{.*\\}" :property *prop-constant*) + + ;; package info, example: "Group: ...", "Group(pt_BR): ...", etc. + (syntoken "^\\w+(\\(\\w+\\))?:" :property *prop-preprocessor*) + + ;; comments + (syntoken "#" :contained t :nospec t :begin :comment) + (syntable :comment *prop-comment* nil + ;; some macros are expanded even when inside comments, and may + ;; cause surprises, "warn" about it + (syntoken "%define\\>" :property *prop-control*) + (syntoken "%\\{?\\w+\\}?" :property *prop-string*) + (syntoken "$" :switch -1) + ) + + ;; emails + (syntoken "<?[a-z0-9_-]+@[a-z0-9_-]+\\.\\w+(\\.\\w+)*>?" + :icase t + :property *prop-string*) + ;; links + (syntoken "\\<(http|ftp)://\\S+" :property *prop-string*) +) diff --git a/lisp/modules/progmodes/sgml.lsp b/lisp/modules/progmodes/sgml.lsp new file mode 100644 index 0000000..511aae5 --- /dev/null +++ b/lisp/modules/progmodes/sgml.lsp @@ -0,0 +1,428 @@ +;; +;; Copyright (c) 2002 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/modules/progmodes/sgml.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +;; Default property the text is shown. +(defsynprop *prop-sgml-default* + "default" + :font "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Gray10" +) + +(defsynprop *prop-sgml-default-short* + "default-short" + :font "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Gray10" + :underline t +) + +;; Large font. +(defsynprop *prop-sgml-sect* + "sect" + :font "-*-helvetica-bold-r-*-*-17-*-*-*-*-*-*-1" + :foreground "Gray20" +) + +;; Monospaced property. +(defsynprop *prop-sgml-tt* + "tt" + :font "-*-courier-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Black" +) + +;; Italic property. +(defsynprop *prop-sgml-it* + "it" + :font "-*-helvetica-medium-o-*-*-12-*-*-*-*-*-*-1" + :foreground "Black" +) + +;; Bold font property. +(defsynprop *prop-sgml-bf* + "bf" + :font "-*-helvetica-bold-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Gray10" +) + +;; Looks like a link... +(defsynprop *prop-sgml-link* + "link" + :font "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "blue" + :underline t +) + +;; Monospaced, also looks like a link... +(defsynprop *prop-sgml-email* + "email" + :font "-*-courier-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "blue" + :underline t +) + +;; Another monospaced property, +(defsynprop *prop-sgml-screen* + "screen" + :font "-*-fixed-*-*-*-*-*-*-*-*-*-*-*-1" + :foreground "Gray10" +) + +(defsynprop *prop-sgml-maybe-entity* + "maybe-entity" + :font "*lucidatypewriter-medium-r*12*" + :foreground "VioletRed4" + :background "LightYellow" +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The macros sgml-syntoken and sgml-syntable allows creating rules for +;; matching text inside tags in the format: +;; <tag> or <tag arg=value> or <tag arg1=value ... argn=value> +;; any-text +;; </tag> +;; The generated rules don't allow things like: < tag> or </tag > +;; +;; This could also be done as a normal definition, with a starting rule like: +;; "<(tag1|tag2|tag3)\\>" +;; and an ending rule like: +;; "</(tag1|tag2|tag3)>" +;; But is implemented in way that will fail on purpose for things like: +;; <tag1>any text</tag3></tag1> +;; +;; NOTE: These definitions aren't cheap in the time required to process the +;; file, and are just adaptations/tests with the syntax-highlight code, +;; probably it is better to avoid using it in other syntax definitions. +;; NOTE2: It cannot be defined as a single macro because it is required to +;; generate 2 entries in the main SGML syntax highlight definition, +;; or, should generate the entire definition from a macro; you will +;; need to type the tag name twice, but shouldn't be a problem if +;; you are using sgml :-) +;; XXX: Maybe the syntax-highlight code could save the starting match and +;; apply a regex generated at run-time to check for the ending tag, +;; but this probably would make the parser too slow, better to have +;; a specialized parser if that is required... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro sgml-syntoken (name) + `(syntoken (string-concat "<" ,name "\\>") + :icase t + :contained t + :begin (intern (string-concat ,name "$") 'keyword)) +) +(defmacro sgml-syntable (name property) + `(let + ( + (label (intern (string-concat ,name "$") 'keyword)) + (nested-label (intern (string (gensym)) 'keyword)) + ) + (syntable label *prop-preprocessor* nil + ;; tag is still open, process any options + (synaugment :generic-tag) + (syntoken ">" + :nospec t + :property *prop-preprocessor* + :begin nested-label) + ;; Generate a nested table that includes everything, and only + ;; returns when the closing tag is found. + (syntable nested-label ,property nil + (syntoken (string-concat "</" ,name ">") + :icase t + :nospec t + :property *prop-preprocessor* + :switch -2) + (synaugment :main) + ) + ) + ) +) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Generate tokens for tags that don't require and ending tag. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro sgml-syntable-simple (name property) + `(let + ( + (label (intern (string-concat ,name "$") 'keyword)) + (nested-label (intern (string (gensym)) 'keyword)) + ) + (syntable label *prop-preprocessor* nil + ;; tag is still open, process any options + (synaugment :generic-tag) + (syntoken ">" + :nospec t + :property *prop-preprocessor* + :begin nested-label) + ;; Generate a nested table that finishes whenever an unmatched + ;; start or end tag is found. + (syntable nested-label ,property nil + (syntoken "</" + :icase t + :nospec t + :contained t + :begin :simple-nested-tag) + ;; These will take precedence over other rules + (syntoken "<" + :icase t + :nospec t + :contained t + :begin :simple-nested-tag) + (syntoken "<p>" + :icase t + :nospec t + :property *prop-preprocessor* + :switch :main) + (synaugment :main) + ) + ) + ) +) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Define some macros to generate tokens for tags in the format: +;; <tag/ ... / +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro sgml-syntoken-short (name) + `(syntoken (string-concat "<" ,name "/") + :icase t + :property *prop-preprocessor* + :begin (intern (string-concat ,name "/") 'keyword)) +) +(defmacro sgml-syntable-short (name property) + `(syntable (intern (string-concat ,name "/") 'keyword) ,property nil + (syntoken "/" + :nospec t + :property *prop-preprocessor* + :switch -1) + (syntoken "</?\\w+>" + :property *prop-control* + :switch :main) + ) +) + + +;; The main SGML syntax table +(defsyntax *sgml-mode* :main *prop-sgml-default* nil nil + ;; Comments + (syntoken "<!--" + :nospec t + :contained t + :begin :comment) + (syntable :comment *prop-comment* nil + ;; Only one rule, to finish the comment. + (syntoken "-->" + :nospec t + :switch -1) + ) + + ;; Entities + (syntoken "&[a-zA-Z0-9_.-]+;" + :property *prop-constant*) + ;; Probably an entity, missing ending `;' + (syntoken "&[a-zA-Z0-9_.-]+" + :property *prop-sgml-maybe-entity*) + + ;; Strings + (syntable :string *prop-string* nil + ;; Ignore escaped characters. + (syntoken "\\\\.") + ;; Rule to finish the string. + (syntoken "\"" + :nospec t + :switch -1) + ) + + ;; Links + (syntable :link *prop-preprocessor* nil + ;; No link string following "url=" + (syntoken ">" + :nospec t + :property *prop-control* + :switch -1) + (syntoken "\"" + :nospec t + :contained t + :begin :link-string) + (syntable :link-string *prop-sgml-link* nil + ;; Ignore escaped characters. + (syntoken "\\\\.") + ;; Rule to finish the link, note that returns two levels. + (syntoken "\"" + :nospec t + :switch -2) + ) + ) + + ;; "Special" tag + (syntoken "<!" + :nospec t + :contained t + :begin :special-tag) + ;; Rules for "special" tags + (syntable :special-tag *prop-preprocessor* nil + (syntoken "[" + :nospec t + :property *prop-preprocessor* + :begin :brackets) + ;; Finish the "special" tag + (syntoken ">" + :nospec t + :switch -1) + (syntable :brackets *prop-sgml-default* nil + (syntoken "]" + :nospec t + :property *prop-preprocessor* + :switch -1) + ;; Allow nesting. + (syntoken "[" + :nospec t + :property *prop-preprocessor* + :begin :brackets) + ;; Entities. + (syntoken "%[a-zA-Z0-9_.-]+;?" + :property *prop-annotation*) + ;; Allow everything inside the brackets + (synaugment :main) + ) + ;; Don't use generic tag tokens, only create a rule for strings + (syntoken "\"" + :nospec t + :begin :string + :contained t) + ;; Allow everything inside the "special" tag + (synaugment :main) + ) + + ;; Some "short" tags + (sgml-syntoken-short "tt") + (sgml-syntable-short "tt" *prop-sgml-tt*) + (sgml-syntoken-short "it") + (sgml-syntable-short "it" *prop-sgml-it*) + (sgml-syntoken-short "bf") + (sgml-syntable-short "bf" *prop-sgml-bf*) + (sgml-syntoken-short "em") + (sgml-syntable-short "em" *prop-sgml-bf*) + + ;; Short tag + (syntoken "<\\w+/" + :property *prop-preprocessor* + :begin :short-tag) + (syntable :short-tag *prop-sgml-default-short* nil + (syntoken "/" + :nospec t + :property *prop-preprocessor* + :switch -1) + (syntoken "</?\\w+>" + :property *prop-control* + :switch -1) + ) + + ;; Don't allow spaces, this may and may not be the start of a tag, + ;; but the syntax-highlight definition is not specialized... + (syntoken "<([^/a-zA-Z]|$)" + :property *prop-control*) + + ;; Some tags that require an end tag + (sgml-syntoken "tt") + (sgml-syntable "tt" *prop-sgml-tt*) + (sgml-syntoken "code") + (sgml-syntable "code" *prop-sgml-tt*) + (sgml-syntoken "tag") + (sgml-syntable "tag" *prop-sgml-tt*) + (sgml-syntoken "verb") + (sgml-syntable "verb" *prop-sgml-tt*) + (sgml-syntoken "programlisting") + (sgml-syntable "programlisting" *prop-sgml-tt*) + (sgml-syntoken "it") + (sgml-syntable "it" *prop-sgml-it*) + (sgml-syntoken "bf") + (sgml-syntable "bf" *prop-sgml-bf*) + (sgml-syntoken "em") + (sgml-syntable "em" *prop-sgml-bf*) + (sgml-syntoken "mail") + (sgml-syntable "mail" *prop-sgml-email*) + (sgml-syntoken "email") + (sgml-syntable "email" *prop-sgml-email*) + (sgml-syntoken "screen") + (sgml-syntable "screen" *prop-sgml-screen*) + (sgml-syntoken "tscreen") + (sgml-syntable "tscreen" *prop-sgml-screen*) + + + ;; Helper for tags that don't need an ending one. + ;; NOTE: Since the parser is not specialized, if the tag is + ;; folowed by one that has a special property defined here, + ;; it may not be detected, i.e. put a <p> after the <sect> + ;; and it will work. + (syntable :simple-nested-tag *prop-preprocessor* nil + ;; tag is still open, process any options + (synaugment :generic-tag) + (syntoken ">" + :nospec t + :property *prop-preprocessor* + :switch -3) + ) + (sgml-syntoken "sect") + (sgml-syntable-simple "sect" *prop-sgml-sect*) + (sgml-syntoken "sect1") + (sgml-syntable-simple "sect1" *prop-sgml-sect*) + (sgml-syntoken "sect2") + (sgml-syntable-simple "sect2" *prop-sgml-sect*) + + ;; Generic tags + (syntoken "<" + :nospec t + :contained t + :begin :tag) + ;; Table :generic-tag is defined to be augmented, no rule to finish it. + (syntable :generic-tag *prop-preprocessor* nil + ;; Start string + (syntoken "\"" + :nospec t + :begin :string + :contained t) + ;; Start url link + (syntoken "url=" + :nospec t + :begin :link) + ;; Cannot nest + (syntoken "<" + :nospec t + :property *prop-control*) + ) + (syntable :tag *prop-preprocessor* nil + ;; Finish the tag + (syntoken ">" + :nospec t + :switch -1) + ;; Import generic definitions + (synaugment :generic-tag) + ) +) diff --git a/lisp/modules/progmodes/sh.lsp b/lisp/modules/progmodes/sh.lsp new file mode 100644 index 0000000..79679ed --- /dev/null +++ b/lisp/modules/progmodes/sh.lsp @@ -0,0 +1,113 @@ +;; +;; Copyright (c) 2003 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/modules/progmodes/sh.lsp,v 1.1 2003/01/16 03:50:46 paulo Exp $ +;; + +(require "syntax") +(require "indent") +(in-package "XEDIT") + +(defsynprop *prop-escape* + "escape" + :font "*lucidatypewriter-medium-r*12*" + :foreground "Red3") + +(defsynprop *prop-variable* + "variable" + :font "*lucidatypewriter-medium-r*12*" + :foreground "Gold4") + +(defsynprop *prop-backslash* + "backslash" + :font "*courier-bold-r*12*" + :foreground "green4") + +;; XXX it would be interesting if "here-documents" could be parsed +;; just searching for "<<\s*EOF\\>" and then for "^EOF\\>" should +;; handle most cases, but would be a hack... +(defsyntax *sh-mode* :main nil #'default-indent nil + ;; keywords and common commands/builtins + (syntoken "\\<(if|then|elif|else|fi|case|in|esac|for|do|done|while|until|break|continue|eval|exit|exec|test|echo|cd|shift|local|return)\\>" + :property *prop-keyword*) + + ; comments + (syntoken "#.*$" :property *prop-comment*) + + ;; punctuation + (syntoken "[][;:*?(){}<>&!|$#]+" :property *prop-punctuation*) + + ;; variable declaration + (syntoken "\\w+=" :property *prop-preprocessor*) + + ;; numbers + (syntoken "\\<\\d+\\>" :property *prop-number*) + + ;; escaped characters at toplevel + (syntoken "\\\\." :property *prop-backslash*) + + ;; single quote + (syntoken "'" :nospec t :contained t :begin :single) + (syntable :single *prop-constant* nil + ;; do nothing, escaped characters + (syntoken "\\\\.") + (syntoken "'" :nospec t :switch -1) + ) + + ;; double quote + (syntoken "\"" :nospec t :contained t :begin :double) + (syntable :double *prop-string* #'default-indent + ;; escaped characters + (syntoken "\\\\." :property *prop-backslash*) + (syntoken "\"" :nospec t :switch -1) + ;; rule to start escape + (syntoken "`" :nospec t :contained t :begin :escape) + ;; ignore single quote, required because escape is augmented + (syntoken "'" :nospec t) + (synaugment :escape :variable) + ) + + ;; escaped commands + (syntoken "`" :nospec t :contained t :begin :escape) + (syntable :escape *prop-escape* #'default-indent + ;; escaped characters + (syntoken "\\\\." :property *prop-backslash*) + (syntoken "`" :nospec t :switch -1) + ;; rule to start double quote inside escape + (syntoken "\"" :nospec t :contained t :begin :double) + ;; rule to start single quote + (syntoken "'" :nospec t :contained t :begin :single) + (synaugment :double :variable) + ) + + (syntable :variable nil nil + (syntoken "\\$\\w+" :property *prop-variable*) + ) + (synaugment :variable) +) diff --git a/lisp/modules/progmodes/xconf.lsp b/lisp/modules/progmodes/xconf.lsp new file mode 100644 index 0000000..dea70a2 --- /dev/null +++ b/lisp/modules/progmodes/xconf.lsp @@ -0,0 +1,68 @@ +;; +;; Copyright (c) 2003 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/modules/progmodes/xconf.lsp,v 1.1 2003/01/16 03:50:46 paulo Exp $ +;; + +(require "syntax") +(require "indent") +(in-package "XEDIT") + +(defsyntax *xconf-mode* :main nil #'default-indent nil + ;; section start + (syntoken "\\<(Section|SubSection)\\>" + :property *prop-keyword* :icase t :begin :section) + ;; just for fun, highlight the section name differently + (syntable :section *prop-constant* #'default-indent + (syntoken "\"" :nospec t :begin :name) + (syntable :name *prop-constant* nil + ;; ignore escaped characters + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -2) + ) + ) + + ;; section end + (syntoken "\\<(EndSection|EndSubSection)\\>" + :property *prop-keyword* :icase t) + + ;; numeric options + (syntoken "\\<\\d+(\\.\\d+)?\\>" :property *prop-number*) + + ;; comments + (syntoken "#.*$" :property *prop-comment*) + + ;; strings + (syntoken "\"" :nospec t :begin :string :contained t) + (syntable :string *prop-string* #'default-indent + ;; ignore escaped characters + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -1) + ) +) diff --git a/lisp/modules/progmodes/xlog.lsp b/lisp/modules/progmodes/xlog.lsp new file mode 100644 index 0000000..6bc8b57 --- /dev/null +++ b/lisp/modules/progmodes/xlog.lsp @@ -0,0 +1,102 @@ +;; +;; Copyright (c) 2003 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/modules/progmodes/xlog.lsp,v 1.1 2003/01/16 06:25:51 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-xlog-probe* + "xlog-probe" + :font "*courier-medium-r*12*" + :background "rgb:c/f/c") + +(defsynprop *prop-xlog-config* + "xlog-config" + :font "*courier-medium-r*12*" + :background "rgb:c/e/f") + +(defsynprop *prop-xlog-default* + "xlog-default" + :font "*courier-medium-r*12*" + :background "rgb:e/c/f") + +(defsynprop *prop-xlog-warning* + "xlog-warning" + :font "*courier-bold-r*12*" + :foreground "Red4" + :background "Yellow1" +) + +(defsynprop *prop-xlog-error* + "xlog-error" + :font "*courier-bold-r*12*" + :foreground "Yellow2" + :background "Red3" +) + +(defsyntax *xlog-mode* :main nil nil nil + ;; highlight version + (syntoken "^XFree86 Version \\S+" :property *prop-annotation*) + + ;; release date + (syntoken "^Release Date: " :property *prop-keyword* :begin :note) + + ;; highlight operating system description + (syntoken "^Build Operating System: " :property *prop-keyword* :begin :note) + + (syntable :note *prop-annotation* nil (syntoken "$" :switch -1)) + + ;; don't highlight info lines + (syntoken "^\\(II\\) " :property *prop-keyword*) + + ;; default lines + (syntoken "^\\(==\\) " :property *prop-keyword* :begin :default) + (syntable :default *prop-xlog-default* nil (syntoken "$" :switch -1)) + + ;; probe lines + (syntoken "^\\(--\\) " :property *prop-keyword* :begin :probe) + (syntable :probe *prop-xlog-probe* nil (syntoken "$" :switch -1)) + + ;; config lines + (syntoken "^\\(\\*\\*\\) " :property *prop-keyword* :begin :config) + (syntable :config *prop-xlog-config* nil (syntoken "$" :switch -1)) + + ;; warnings + (syntoken "^\\(WW\\) " :property *prop-keyword* :begin :warning) + (syntable :warning *prop-xlog-warning* nil (syntoken "$" :switch -1)) + + ;; errors + (syntoken "^\\(EE\\) " :property *prop-keyword* :begin :error) + (syntable :error *prop-xlog-error* nil (syntoken "$" :switch -1)) + + ;; command line and "uncommon" messages + (syntoken "^\\(..\\) " :property *prop-control* :begin :warning) +) diff --git a/lisp/modules/progmodes/xrdb.lsp b/lisp/modules/progmodes/xrdb.lsp new file mode 100644 index 0000000..c0a099c --- /dev/null +++ b/lisp/modules/progmodes/xrdb.lsp @@ -0,0 +1,115 @@ +;; +;; Copyright (c) 2002 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/modules/progmodes/xrdb.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-xrdb-comment* + "xrdb-comment" + :font "*courier-medium-o*12*" + :foreground "sienna" +) + +(defsynprop *prop-xrdb-special* + "format" + :font "*lucidatypewriter-medium-r*12*" + :foreground "RoyalBlue4" +) + +(defsynprop *prop-xrdb-punctuation* + "punctuation" + :font "-*-courier-bold-r-*-*-14-*-*-*-*-*-*-1" + :foreground "OrangeRed4" +) + +(defsyntax *xrdb-mode* :main nil nil nil + (syntoken "^\\s*!.*" + :property *prop-xrdb-comment*) + (syntoken "^\\s*#.*" + :property *prop-preprocessor*) + (syntoken "\\*|\\.|\\?" + :property *prop-xrdb-punctuation* + :begin :resource) + (syntoken "." + :nospec t + :begin :resource) + + ;; Extra comments + (syntoken "/*" :nospec t :begin :comment :contained t) + (syntable :comment *prop-comment* nil + (syntoken "/*" :nospec t :property *prop-error*) + ;; Rule to finish a comment. + (syntoken "*/" :nospec t :switch -1) + ) + + (syntable :resource nil nil + (syntoken "\\*|\\.|\\?" :property *prop-xrdb-punctuation*) + (syntoken ":\\s*" :property *prop-xrdb-punctuation* :begin :value) + ) + + (syntable :value *prop-string* nil + (syntoken "\\\\$" :property *prop-constant*) + + + ;; If the pattern ends at a newline, must switch to the previous state. + ;; Not sure yet how to better handle this. The parser does not detect + ;; eol because it is a match to the empty string. A possible hack + ;; would be to check if the pattern string ends in a "$", but probably + ;; better in this case to have a syntoken option, to tell the parser + ;; an eol may exist. + (syntoken + (string-concat + "(" + "\\d+|" ;; numbers + "(#\\x+|rgb:\\x+/\\x+/\\x+)|" ;; color spec + "#\\w+" ;; translation table + ")$") + :property *prop-xrdb-special* :switch -2) + (syntoken "(\\\\n?|\")$" + :property *prop-constant* :switch -2) + + ;; XXX Cut&paste of the above, only without the match to eol + (syntoken + (string-concat + "(" + "\\d+|" + "(#\\x+|rgb:\\x+/\\x+/\\x+)|" + "#\\w+" + ")") + :property *prop-xrdb-special*) + (syntoken "(\\\\n?|\")" + :property *prop-constant*) + + (syntoken "/*" :nospec t :begin :comment :contained t) + (syntoken ".?$" :switch -2) + ) +) diff --git a/lisp/modules/psql.c b/lisp/modules/psql.c new file mode 100644 index 0000000..6945947 --- /dev/null +++ b/lisp/modules/psql.c @@ -0,0 +1,983 @@ +/* + * 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/modules/psql.c,v 1.12 2002/11/23 08:26:52 paulo Exp $ */ + +#include <stdlib.h> +#include <libpq-fe.h> +#undef USE_SSL /* cannot get it to compile... */ +#include <postgres.h> +#include <utils/geo_decls.h> +#include "internal.h" +#include "private.h" + +/* + * Prototypes + */ +int psqlLoadModule(void); + +LispObj *Lisp_PQbackendPID(LispBuiltin*); +LispObj *Lisp_PQclear(LispBuiltin*); +LispObj *Lisp_PQconsumeInput(LispBuiltin*); +LispObj *Lisp_PQdb(LispBuiltin*); +LispObj *Lisp_PQerrorMessage(LispBuiltin*); +LispObj *Lisp_PQexec(LispBuiltin*); +LispObj *Lisp_PQfinish(LispBuiltin*); +LispObj *Lisp_PQfname(LispBuiltin*); +LispObj *Lisp_PQfnumber(LispBuiltin*); +LispObj *Lisp_PQfsize(LispBuiltin*); +LispObj *Lisp_PQftype(LispBuiltin*); +LispObj *Lisp_PQgetlength(LispBuiltin*); +LispObj *Lisp_PQgetvalue(LispBuiltin*); +LispObj *Lisp_PQhost(LispBuiltin*); +LispObj *Lisp_PQnfields(LispBuiltin*); +LispObj *Lisp_PQnotifies(LispBuiltin*); +LispObj *Lisp_PQntuples(LispBuiltin*); +LispObj *Lisp_PQoptions(LispBuiltin*); +LispObj *Lisp_PQpass(LispBuiltin*); +LispObj *Lisp_PQport(LispBuiltin*); +LispObj *Lisp_PQresultStatus(LispBuiltin*); +LispObj *Lisp_PQsetdb(LispBuiltin*); +LispObj *Lisp_PQsetdbLogin(LispBuiltin*); +LispObj *Lisp_PQsocket(LispBuiltin*); +LispObj *Lisp_PQstatus(LispBuiltin*); +LispObj *Lisp_PQtty(LispBuiltin*); +LispObj *Lisp_PQuser(LispBuiltin*); + +/* + * Initialization + */ +static LispBuiltin lispbuiltins[] = { + {LispFunction, Lisp_PQbackendPID, "pq-backend-pid connection"}, + {LispFunction, Lisp_PQclear, "pq-clear result"}, + {LispFunction, Lisp_PQconsumeInput, "pq-consume-input connection"}, + {LispFunction, Lisp_PQdb, "pq-db connection"}, + {LispFunction, Lisp_PQerrorMessage, "pq-error-message connection"}, + {LispFunction, Lisp_PQexec, "pq-exec connection query"}, + {LispFunction, Lisp_PQfinish, "pq-finish connection"}, + {LispFunction, Lisp_PQfname, "pq-fname result field-number"}, + {LispFunction, Lisp_PQfnumber, "pq-fnumber result field-name"}, + {LispFunction, Lisp_PQfsize, "pq-fsize result field-number"}, + {LispFunction, Lisp_PQftype, "pq-ftype result field-number"}, + {LispFunction, Lisp_PQgetlength, "pq-getlength result tupple field-number"}, + {LispFunction, Lisp_PQgetvalue, "pq-getvalue result tupple field-number &optional type"}, + {LispFunction, Lisp_PQhost, "pq-host connection"}, + {LispFunction, Lisp_PQnfields, "pq-nfields result"}, + {LispFunction, Lisp_PQnotifies, "pq-notifies connection"}, + {LispFunction, Lisp_PQntuples, "pq-ntuples result"}, + {LispFunction, Lisp_PQoptions, "pq-options connection"}, + {LispFunction, Lisp_PQpass, "pq-pass connection"}, + {LispFunction, Lisp_PQport, "pq-port connection"}, + {LispFunction, Lisp_PQresultStatus, "pq-result-status result"}, + {LispFunction, Lisp_PQsetdb, "pq-setdb host port options tty dbname"}, + {LispFunction, Lisp_PQsetdbLogin, "pq-setdb-login host port options tty dbname login password"}, + {LispFunction, Lisp_PQsocket, "pq-socket connection"}, + {LispFunction, Lisp_PQstatus, "pq-status connection"}, + {LispFunction, Lisp_PQtty, "pq-tty connection"}, + {LispFunction, Lisp_PQuser, "pq-user connection"}, +}; + +LispModuleData psqlLispModuleData = { + LISP_MODULE_VERSION, + psqlLoadModule +}; + +static int PGconn_t, PGresult_t; + +/* + * Implementation + */ +int +psqlLoadModule(void) +{ + int i; + char *fname = "PSQL-LOAD-MODULE"; + + PGconn_t = LispRegisterOpaqueType("PGconn*"); + PGresult_t = LispRegisterOpaqueType("PGresult*"); + + GCDisable(); + /* NOTE: Implemented just enough to make programming examples + * (and my needs) work. + * Completing this is an exercise to the reader, or may be implemented + * when/if required. + */ + LispExecute("(DEFSTRUCT PG-NOTIFY RELNAME BE-PID)\n" + "(DEFSTRUCT PG-POINT X Y)\n" + "(DEFSTRUCT PG-BOX HIGH LOW)\n" + "(DEFSTRUCT PG-POLYGON SIZE NUM-POINTS BOUNDBOX POINTS)\n"); + + /* enum ConnStatusType */ + (void)LispSetVariable(ATOM2("PG-CONNECTION-OK"), + REAL(CONNECTION_OK), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-BAD"), + REAL(CONNECTION_BAD), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-STARTED"), + REAL(CONNECTION_STARTED), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-MADE"), + REAL(CONNECTION_MADE), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-AWAITING-RESPONSE"), + REAL(CONNECTION_AWAITING_RESPONSE), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-AUTH-OK"), + REAL(CONNECTION_AUTH_OK), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-SETENV"), + REAL(CONNECTION_SETENV), fname, 0); + + + /* enum ExecStatusType */ + (void)LispSetVariable(ATOM2("PGRES-EMPTY-QUERY"), + REAL(PGRES_EMPTY_QUERY), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-COMMAND-OK"), + REAL(PGRES_COMMAND_OK), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-TUPLES-OK"), + REAL(PGRES_TUPLES_OK), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-COPY-OUT"), + REAL(PGRES_COPY_OUT), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-COPY-IN"), + REAL(PGRES_COPY_IN), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-BAD-RESPONSE"), + REAL(PGRES_BAD_RESPONSE), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-NONFATAL-ERROR"), + REAL(PGRES_NONFATAL_ERROR), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-FATAL-ERROR"), + REAL(PGRES_FATAL_ERROR), fname, 0); + GCEnable(); + + for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++) + LispAddBuiltinFunction(&lispbuiltins[i]); + + return (1); +} + +LispObj * +Lisp_PQbackendPID(LispBuiltin *builtin) +/* + pq-backend-pid connection + */ +{ + int pid; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + pid = PQbackendPID(conn); + + return (INTEGER(pid)); +} + +LispObj * +Lisp_PQclear(LispBuiltin *builtin) +/* + pq-clear result + */ +{ + PGresult *res; + + LispObj *result; + + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + PQclear(res); + + return (NIL); +} + +LispObj * +Lisp_PQconsumeInput(LispBuiltin *builtin) +/* + pq-consume-input connection + */ +{ + int result; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + result = PQconsumeInput(conn); + + return (INTEGER(result)); +} + +LispObj * +Lisp_PQdb(LispBuiltin *builtin) +/* + pq-db connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQdb(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQerrorMessage(LispBuiltin *builtin) +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQerrorMessage(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQexec(LispBuiltin *builtin) +/* + pq-exec connection query + */ +{ + PGconn *conn; + PGresult *res; + + LispObj *connection, *query; + + query = ARGUMENT(1); + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + CHECK_STRING(query); + res = PQexec(conn, THESTR(query)); + + return (res ? OPAQUE(res, PGresult_t) : NIL); +} + +LispObj * +Lisp_PQfinish(LispBuiltin *builtin) +/* + pq-finish connection + */ +{ + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + PQfinish(conn); + + return (NIL); +} + +LispObj * +Lisp_PQfname(LispBuiltin *builtin) +/* + pq-fname result field-number + */ +{ + char *string; + int field; + PGresult *res; + + LispObj *result, *field_number; + + field_number = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + string = PQfname(res, field); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQfnumber(LispBuiltin *builtin) +/* + pq-fnumber result field-name + */ +{ + int number; + int field; + PGresult *res; + + LispObj *result, *field_name; + + field_name = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_STRING(field_name); + number = PQfnumber(res, THESTR(field_name)); + + return (INTEGER(number)); +} + +LispObj * +Lisp_PQfsize(LispBuiltin *builtin) +/* + pq-fsize result field-number + */ +{ + int size, field; + PGresult *res; + + LispObj *result, *field_number; + + field_number = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + size = PQfsize(res, field); + + return (INTEGER(size)); +} + +LispObj * +Lisp_PQftype(LispBuiltin *builtin) +{ + Oid oid; + int field; + PGresult *res; + + LispObj *result, *field_number; + + field_number = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + oid = PQftype(res, field); + + return (INTEGER(oid)); +} + +LispObj * +Lisp_PQgetlength(LispBuiltin *builtin) +/* + pq-getlength result tupple field-number + */ +{ + PGresult *res; + int tuple, field, length; + + LispObj *result, *otupple, *field_number; + + field_number = ARGUMENT(2); + otupple = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(otupple); + tuple = FIXNUM_VALUE(otupple); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + length = PQgetlength(res, tuple, field); + + return (INTEGER(length)); +} + +LispObj * +Lisp_PQgetvalue(LispBuiltin *builtin) +/* + pq-getvalue result tuple field &optional type-specifier + */ +{ + char *string; + double real = 0.0; + PGresult *res; + int tuple, field, isint = 0, isreal = 0, integer; + + LispObj *result, *otupple, *field_number, *type; + + type = ARGUMENT(3); + field_number = ARGUMENT(2); + otupple = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(otupple); + tuple = FIXNUM_VALUE(otupple); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + string = PQgetvalue(res, tuple, field); + + if (type != UNSPEC) { + char *typestring; + + CHECK_SYMBOL(type); + typestring = ATOMID(type); + + if (strcmp(typestring, "INT16") == 0) { + integer = *(short*)string; + isint = 1; + goto simple_type; + } + else if (strcmp(typestring, "INT32") == 0) { + integer = *(int*)string; + isint = 1; + goto simple_type; + } + else if (strcmp(typestring, "FLOAT") == 0) { + real = *(float*)string; + isreal = 1; + goto simple_type; + } + else if (strcmp(typestring, "REAL") == 0) { + real = *(double*)string; + isreal = 1; + goto simple_type; + } + else if (strcmp(typestring, "PG-POLYGON") == 0) + goto polygon_type; + else if (strcmp(typestring, "STRING") != 0) + LispDestroy("%s: unknown type %s", + STRFUN(builtin), typestring); + } + +simple_type: + return (isint ? INTEGER(integer) : isreal ? DFLOAT(real) : + (string ? STRING(string) : NIL)); + +polygon_type: + { + LispObj *poly, *box, *p = NIL, *cdr, *obj; + POLYGON *polygon; + int i, size; + + size = PQgetlength(res, tuple, field); + polygon = (POLYGON*)(string - sizeof(int)); + + GCDisable(); + /* get polygon->boundbox */ + cdr = EVAL(CONS(ATOM("MAKE-PG-POINT"), + CONS(KEYWORD("X"), + CONS(REAL(polygon->boundbox.high.x), + CONS(KEYWORD("Y"), + CONS(REAL(polygon->boundbox.high.y), NIL)))))); + obj = EVAL(CONS(ATOM("MAKE-PG-POINT"), + CONS(KEYWORD("X"), + CONS(REAL(polygon->boundbox.low.x), + CONS(KEYWORD("Y"), + CONS(REAL(polygon->boundbox.low.y), NIL)))))); + box = EVAL(CONS(ATOM("MAKE-PG-BOX"), + CONS(KEYWORD("HIGH"), + CONS(cdr, + CONS(KEYWORD("LOW"), + CONS(obj, NIL)))))); + /* get polygon->p values */ + for (i = 0; i < polygon->npts; i++) { + obj = EVAL(CONS(ATOM("MAKE-PG-POINT"), + CONS(KEYWORD("X"), + CONS(REAL(polygon->p[i].x), + CONS(KEYWORD("Y"), + CONS(REAL(polygon->p[i].y), NIL)))))); + if (i == 0) + p = cdr = CONS(obj, NIL); + else { + RPLACD(cdr, CONS(obj, NIL)); + cdr = CDR(cdr); + } + } + + /* make result */ + poly = EVAL(CONS(ATOM("MAKE-PG-POLYGON"), + CONS(KEYWORD("SIZE"), + CONS(REAL(size), + CONS(KEYWORD("NUM-POINTS"), + CONS(REAL(polygon->npts), + CONS(KEYWORD("BOUNDBOX"), + CONS(box, + CONS(KEYWORD("POINTS"), + CONS(QUOTE(p), NIL)))))))))); + GCEnable(); + + return (poly); + } +} + +LispObj * +Lisp_PQhost(LispBuiltin *builtin) +/* + pq-host connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQhost(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQnfields(LispBuiltin *builtin) +/* + pq-nfields result + */ +{ + int nfields; + PGresult *res; + + LispObj *result; + + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + nfields = PQnfields(res); + + return (INTEGER(nfields)); +} + +LispObj * +Lisp_PQnotifies(LispBuiltin *builtin) +/* + pq-notifies connection + */ +{ + LispObj *result, *code, *cod = COD; + PGconn *conn; + PGnotify *notifies; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + if ((notifies = PQnotifies(conn)) == NULL) + return (NIL); + + GCDisable(); + code = CONS(ATOM("MAKE-PG-NOTIFY"), + CONS(KEYWORD("RELNAME"), + CONS(STRING(notifies->relname), + CONS(KEYWORD("BE-PID"), + CONS(REAL(notifies->be_pid), NIL))))); + COD = CONS(code, COD); + GCEnable(); + result = EVAL(code); + COD = cod; + + free(notifies); + + return (result); +} + +LispObj * +Lisp_PQntuples(LispBuiltin *builtin) +/* + pq-ntuples result + */ +{ + int ntuples; + PGresult *res; + + LispObj *result; + + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + ntuples = PQntuples(res); + + return (INTEGER(ntuples)); +} + +LispObj * +Lisp_PQoptions(LispBuiltin *builtin) +/* + pq-options connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQoptions(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQpass(LispBuiltin *builtin) +/* + pq-pass connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQpass(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQport(LispBuiltin *builtin) +/* + pq-port connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQport(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQresultStatus(LispBuiltin *builtin) +/* + pq-result-status result + */ +{ + int status; + PGresult *res; + + LispObj *result; + + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + status = PQresultStatus(res); + + return (INTEGER(status)); +} + +LispObj * +LispPQsetdb(LispBuiltin *builtin, int loginp) +/* + pq-setdb host port options tty dbname + pq-setdb-login host port options tty dbname login password + */ +{ + PGconn *conn; + char *host, *port, *options, *tty, *dbname, *login, *password; + + LispObj *ohost, *oport, *ooptions, *otty, *odbname, *ologin, *opassword; + + if (loginp) { + opassword = ARGUMENT(6); + ologin = ARGUMENT(5); + } + else + opassword = ologin = NIL; + odbname = ARGUMENT(4); + otty = ARGUMENT(3); + ooptions = ARGUMENT(2); + oport = ARGUMENT(1); + ohost = ARGUMENT(0); + + if (ohost != NIL) { + CHECK_STRING(ohost); + host = THESTR(ohost); + } + else + host = NULL; + + if (oport != NIL) { + CHECK_STRING(oport); + port = THESTR(oport); + } + else + port = NULL; + + if (ooptions != NIL) { + CHECK_STRING(ooptions); + options = THESTR(ooptions); + } + else + options = NULL; + + if (otty != NIL) { + CHECK_STRING(otty); + tty = THESTR(otty); + } + else + tty = NULL; + + if (odbname != NIL) { + CHECK_STRING(odbname); + dbname = THESTR(odbname); + } + else + dbname = NULL; + + if (ologin != NIL) { + CHECK_STRING(ologin); + login = THESTR(ologin); + } + else + login = NULL; + + if (opassword != NIL) { + CHECK_STRING(opassword); + password = THESTR(opassword); + } + else + password = NULL; + + conn = PQsetdbLogin(host, port, options, tty, dbname, login, password); + + return (conn ? OPAQUE(conn, PGconn_t) : NIL); +} + +LispObj * +Lisp_PQsetdb(LispBuiltin *builtin) +/* + pq-setdb host port options tty dbname + */ +{ + return (LispPQsetdb(builtin, 0)); +} + +LispObj * +Lisp_PQsetdbLogin(LispBuiltin *builtin) +/* + pq-setdb-login host port options tty dbname login password + */ +{ + return (LispPQsetdb(builtin, 1)); +} + +LispObj * +Lisp_PQsocket(LispBuiltin *builtin) +/* + pq-socket connection + */ +{ + int sock; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + sock = PQsocket(conn); + + return (INTEGER(sock)); +} + +LispObj * +Lisp_PQstatus(LispBuiltin *builtin) +/* + pq-status connection + */ +{ + int status; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + status = PQstatus(conn); + + return (INTEGER(status)); +} + +LispObj * +Lisp_PQtty(LispBuiltin *builtin) +/* + pq-tty connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQtty(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQuser(LispBuiltin *builtin) +/* + pq-user connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQuser(conn); + + return (string ? STRING(string) : NIL); +} diff --git a/lisp/modules/syntax.lsp b/lisp/modules/syntax.lsp new file mode 100644 index 0000000..c297235 --- /dev/null +++ b/lisp/modules/syntax.lsp @@ -0,0 +1,1452 @@ +;; +;; Copyright (c) 2002 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/modules/syntax.lsp,v 1.11 2003/01/16 03:50:46 paulo Exp $ +;; + +(provide "syntax") +(require "xedit") +(in-package "XEDIT") + +(defvar *syntax-symbols* '( + syntax-highlight defsyntax defsynprop synprop-p syntax-p + syntable syntoken synaugment + *prop-default* *prop-keyword* *prop-number* *prop-string* + *prop-constant* *prop-comment* *prop-preprocessor* + *prop-punctuation* *prop-error* *prop-annotation* +)) +(export *syntax-symbols*) +(in-package "USER") +(dolist (symbol xedit::*syntax-symbols*) + (import symbol) +) +(in-package "XEDIT") +(makunbound '*syntax-symbols*) + +#| +TODO: +o Add a command to match without increment the offset in the input, this + may be useful for example in a case like: + some-table + match "<" + switch -1 + match "<" <- the table already eated this, so it won't be matched. + This must be carefully checked at compile time, such instruction should + be in a token that returns or starts a new one, and even then, may need + runtime check to make sure it won't enter an infinite loop. +o Allow combining properties, this is supported in Xaw, and could allow some + very interesting effects for complex documents. +o Maybe have an separated function/loop for tables that don't have tokens + that start/switch to another table, and/or have the contained attribute set. + This could allow running considerably faster. +o Do a better handling of interactive edition for tokens that start and end + with the same pattern, as an example strings, if the user types '"', it + will parse up to the end of the file, "inverting" all strings. +o Allow generic code to be run once a match is found, such code could handle + some defined variables and take decisions based on the parser state. This + should be detected at compile time, to maybe run a different parser for + such syntax tables, due to the extra time building the environment to + call the code. This would be useful to "really" parse documents with + complex syntax, for example, a man page source file. +o Add command to change current default property without initializing a new + state. +o Fix problems matching EOL. Since EOL is an empty string match, if there + is a rule to match only EOL, but some other rule matches up to the end + of the input, the match to EOL will not be recognized. Currently the only + way to handle this is to have a nested table that always returns once a + match is found, so that it will restart the match loop code even if the + input is at EOL. + One possible solution would be to add the ending newline to the input, + and then instead of matching "$", should match "\\n". +o XXX Usage of the variable newline-property must be reviewed in function + syntax-highlight, if the text property has a background attribute, + visual effect will look "strange", will paint a square with the + background attribute at the end of every line in the matched text. +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Some annotations to later write documentation for the module... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| + The current interface logic should be easy to understand for people +that have written lex scanners before. It has some extended semantics, +that could be translated to stacked BEGIN() statements in lex, but +currently does not have rules for matches in the format RE/TRAILING, as +well as code attached to rules (the biggest difference) and/or things +like REJECT and unput(). Also, at least currently, it is *really* quite +slower than lex. + + MATCHING RULES + -------------- + When two tokens are matched at the same input offset, the longest +token is used, if the length is the same, the first definition is +used. For example: + token1 => int + token2 => [A-Za-z]+ + input => integer + Token1 matches "int" and token2 matches "integer", but since token2 is +longer, it is used. But in the case: + token1 => int + token2 => [A-Za-z]+ + input => int + Both, token1 and token2 match "int", since token1 is defined first, it +is used. +|# + + +;; Initialize some default properties that may be shared in syntax +;; highlight definitions. Use of these default properties is encouraged, +;; so that "tokens" will be shown identically when editing program +;; sources in different programming languages. +(defsynprop *prop-default* + "default" + :font "*courier-medium-r*12*" + :foreground "black") + +(defsynprop *prop-keyword* + "keyword" + :font "*courier-bold-r*12*" + :foreground "gray12") + +(defsynprop *prop-number* + "number" + :font "*courier-bold-r*12*" + :foreground "OrangeRed3") + +(defsynprop *prop-string* + "string" + :font "*lucidatypewriter-medium-r*12*" + :foreground "RoyalBlue2") + +(defsynprop *prop-constant* + "constant" + :font "*lucidatypewriter-medium-r*12*" + :foreground "VioletRed3") + +(defsynprop *prop-comment* + "comment" + :font "*courier-medium-o*12*" + :foreground "SlateBlue3") + +(defsynprop *prop-preprocessor* + "preprocessor" + :font "*courier-medium-r*12*" + :foreground "green4") + +(defsynprop *prop-punctuation* + "punctuation" + :font "*courier-bold-r*12*" + :foreground "gray12") + +;; Control characters, not always errors... +(defsynprop *prop-control* + "control" + :font "*courier-bold-r*12*" + :foreground "yellow2" + :background "red3") + +(defsynprop *prop-error* + "error" + :font "*new century schoolbook-bold*24*" + :foreground "yellow" + :background "red") + +(defsynprop *prop-annotation* + "annotation" + :font "*courier-medium-r*12*" + :foreground "black" + :background "PaleGreen") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The "main" definition of the syntax highlight coding interface. +;; Creates a "special" variable with the given name, associating to +;; it an already compiled syntax table. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro defsyntax (variable label property indent options &rest lists) + `(if (boundp ',variable) + ,variable + (progn + (proclaim '(special ,variable)) + (setq ,variable + (compile-syntax-table + (string ',variable) ,options + (syntable ,label ,property ,indent ,@lists) + ) + ) + ) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just a wrapper to create a hash-table and bound it to a symbol. +;; Example of call: +;; (defsynoptions *my-syntax-options* +;; (:indent . 8) +;; (:indent-option-1 . 1) +;; (:indent-option-2 . 2) +;; ) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro defsynoptions (variable &rest options) + `(if (boundp ',variable) + ,variable + (progn + (proclaim '(special ,variable)) + (setq ,variable (make-hash-table :initial-contents ',options)) + ) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; These definitions should be "private". +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defstruct syntoken + regex ;; A compiled regexp. + property ;; NIL for default, or a synprop structure. + contained ;; Only used when switch/begin is not NIL. Values: + ;; NIL -> just switch to or begin new + ;; syntax table. + ;; (not NIL) -> apply syntoken property + ;; (or default one) to matched + ;; text *after* switching to or + ;; beginning a new syntax table. + switch ;; Values for switch are: + ;; NIL -> do nothing + ;; A keyword -> switch to the syntax table + ;; identified by the keyword. + ;; A negative integer -> Pop the stack + ;; -<swich-value> times. + ;; A common value is -1, + ;; to switch to the previous + ;; state, but some times + ;; it is desired to return + ;; two or more times in + ;; in the stack. + ;; NOTE: This is actually a jump, the stack is + ;; popped until the named syntax table is found, + ;; if the stack becomes empty, a new state is + ;; implicitly created. + begin ;; NIL or a keyword (like switch), but instead of + ;; popping the stack, it pushes the current syntax + ;; table to the stack and sets a new current one. +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just a wrapper to make-syntoken. +;; TODO: Add support for structure constructors. +;; XXX: Note that the NOSUB only works with the xedit regex, it +;; will still return the match offsets, but will ignore subexpressions, +;; that is, parenthesis are used only for grouping. +;; TODO: Create a new version of the re-exec call that returns +;; offsets in the format (<from> . <to>) and not +;; ((<from0> . <to0>) ... (<fromN> . <toN>)). Only the global result +;; is expected/used, so there is no reason to allocate more than one +;; cons cell per call. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun syntoken (pattern + &key icase nospec property contained switch begin (nosub t) + &aux + (regex + (re-comp pattern :icase icase :nospec nospec :nosub nosub) + ) + check) + + ;; Don't allow a regex that matches the null string enter the + ;; syntax table list. + (if (consp (setq check (re-exec regex "" :noteol t :notbol t))) +#+xedit (error "SYNTOKEN: regex matches empty string ~S" regex) +#-xedit () + ) + + (make-syntoken + :regex regex + :property property + :contained contained + :switch switch + :begin begin + ) +) + + +;; This structure is defined only to do some type checking, it just +;; holds a list of keywords. +(defstruct synaugment + labels ;; List of keywords labeling syntax tables. +) + +(defstruct syntable + label ;; A keyword naming this syntax table. + property ;; NIL or a default synprop structure. + indent ;; Indentation function for the syntax table. + tokens ;; A list of syntoken structures. + tables ;; A list of syntable structures. + augments ;; A list of synaugment structures, used only + ;; at "compile time", so that a table can be + ;; used before it's definition. + bol ;; One of the tokens match the empty string at + ;; the start of a line (loop optimization hint). + ;; Field filled at "link" time. + eol ;; Same comments as bol, but in this case, for + ;; the empty string at the end of a line. +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just call make-syntable, but sorts the elements by type, allowing +;; a cleaner code when defining the syntax highlight rules. +;; XXX Same comments as for syntoken about the use of a constructor for +;; structures. TODO: when/if clos is implemented in the interpreter. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun syntable (label default-property indent &rest definitions) + + ;; Check for possible errors in the arguments. + (unless (keywordp label) + (error "SYNTABLE: ~A is not a keyword" label) + ) + (unless + (or + (null default-property) + (synprop-p default-property) + ) + (error "SYNTABLE: ~A is an invalid text property" + default-property + ) + ) + + ;; Don't allow unknown data in the definition list. + ;; XXX typecase should be added to the interpreter, and since + ;; the code is traversing the entire list, it could build + ;; now the arguments to make-syntable. + (dolist (item definitions) + (unless + (or + + ;; Allow NIL in the definition list, so that one + ;; can put conditionals in the syntax definition, + ;; and if the conditional is false, fill the slot + ;; with a NIL value. + (atom item) + (syntoken-p item) + (syntable-p item) + (synaugment-p item) + ) + (error "SYNTABLE: invalid syntax table argument ~A" item) + ) + ) + + ;; Build the syntax table. + (make-syntable + :label label + :property default-property + :indent indent + :tokens (remove-if-not #'syntoken-p definitions) + :tables (remove-if-not #'syntable-p definitions) + :augments (remove-if-not #'synaugment-p definitions) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just to do a "preliminary" error checking, every element must be a +;; a keyword, and also check for reserved names. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun synaugment (&rest keywords) + (dolist (keyword keywords) + (unless (keywordp keyword) + (error "SYNAUGMENT: bad syntax table label ~A" keyword) + ) + ) + (make-synaugment :labels keywords) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Recursive compile utility function. +;; Returns a cons in the format: +;; car => List of all syntoken structures +;; (including child tables). +;; cdr => List of all child syntable structures. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun list-syntable-elements (table &aux result sub-result) + (setq + result + (cons + (syntable-tokens table) + (syntable-tables table)) + ) + + ;; For every child syntax table. + (dolist (child (syntable-tables table)) + + ;; Recursively call list-syntable-elements. + (setq sub-result (list-syntable-elements child)) + + (rplaca result (append (car result) (car sub-result))) + (rplacd result (append (cdr result) (cdr sub-result))) + ) + + ;; Return the pair of nested tokens and tables. + result +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Append tokens of the augment list to the tokens of the specified +;; syntax table. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-syntax-augment-list (table table-list + &aux labels augment tokens) + + ;; Create a list of all augment tables. + (dolist (augment (syntable-augments table)) + (setq labels (append labels (synaugment-labels augment))) + ) + + ;; Remove duplicates and references to "itself", + ;; without warnings? + (setq + labels + (remove + (syntable-label table) + (remove-duplicates labels :from-end t) + ) + ) + + ;; Check if the specified syntax tables exists! + (dolist (label labels) + (unless + (setq + augment + (car (member label table-list :key #'syntable-label)) + ) + (error "COMPILE-SYNTAX-AUGMENT-LIST: Cannot augment ~A in ~A" + label + (syntable-label table) + ) + ) + + ;; Increase list of tokens. + (setq tokens (append tokens (syntable-tokens augment))) + ) + + ;; Store the tokens in the augment list. They will be added + ;; to the syntax table in the second pass. + (setf (syntable-augments table) tokens) + + ;; Recurse on every child table. + (dolist (child (syntable-tables table)) + (compile-syntax-augment-list child table-list) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just add the augmented tokens to the token list, recursing on +;; every child syntax table. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun link-syntax-augment-table (table) + (setf + (syntable-tokens table) + ;; When augmenting a table, duplicated tokens or different tokens + ;; that use the same regex pattern should be common. + (remove-duplicates + (nconc (syntable-tokens table) (syntable-augments table)) + :key #'syntoken-regex + :test #'equal + :from-end t + ) + + ;; Don't need to keep this list anymore. + (syntable-augments table) + () + ) + + ;; Check if one of the tokens match the empty string at the + ;; start or end of a text line. XXX The fields bol and eol + ;; are expected to be initialized to NIL. + (dolist (token (syntable-tokens table)) + (when (consp (re-exec (syntoken-regex token) "" :noteol t)) + (setf (syntable-bol table) t) + (return) + ) + ) + (dolist (token (syntable-tokens table)) + (when (consp (re-exec (syntoken-regex token) "" :notbol t)) + (setf (syntable-eol table) t) + (return) + ) + ) + + (dolist (child (syntable-tables table)) + (link-syntax-augment-table child) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; "Compile" the main structure of the syntax highlight code. +;; Variables "switches" and "begins" are used only for error checking. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-syntax-table (name options main-table &aux syntax elements + switches begins tables properties) + (unless (stringp name) + (error "COMPILE-SYNTAX-TABLE: ~A is not a string" name) + ) + + (setq + elements + (list-syntable-elements main-table) + + switches + (remove-if + #'null + (car elements) + :key #'syntoken-switch + ) + + begins + (remove-if-not + #'keywordp + (car elements) + :key #'syntoken-begin + ) + + ;; The "main-table" isn't in the list, because + ;; list-syntable-elements includes only the child tables; + ;; this is done to avoid the need of removing duplicates here. + tables + (cons main-table (cdr elements)) + ) + + ;; Check for typos in the keywords, or for not defined syntax tables. + (dolist (item (mapcar #'syntoken-switch switches)) + (unless + (or + (and + (integerp item) + (minusp item) + ) + (member item tables :key #'syntable-label) + ) + (error "COMPILE-SYNTAX-TABLE: SWITCH ~A cannot be matched" + item + ) + ) + ) + (dolist (item (mapcar #'syntoken-begin begins)) + (unless (member item tables :key #'syntable-label) + (error "COMPILE-SYNTAX-TABLE: BEGIN ~A cannot be matched" + item + ) + ) + ) + + ;; Create a list of all properties used by the syntax. + (setq + properties + (delete-duplicates + + ;; Remove explicitly set to "default" properties. + (remove nil + + (append + + ;; List all properties in the syntoken list. + (mapcar + #'syntoken-property + (car elements) + ) + + ;; List all properties in the syntable list. + (mapcar + #'syntable-property + tables + ) + ) + ) + :test #'string= + :key #'synprop-name + ) + ) + + ;; Provide a default property if none specified. + (unless + (member + "default" + properties + :test #'string= + :key #'synprop-name + ) + (setq properties (append (list *prop-default*) properties)) + ) + + + ;; Now that a list of all nested syntax tables is known, compile the + ;; augment list. Note that even the main-table can be augmented to + ;; include tokens of one of it's children. + + ;; Adding the tokens of the augment tables must be done in + ;; two passes, or it may cause surprises due to "inherited" + ;; tokens, as the augment table was processed first, and + ;; increased it's token list. + (compile-syntax-augment-list main-table tables) + + ;; Now just append the augmented tokens to the table's token list. + (link-syntax-augment-table main-table) + + ;; Change all syntoken switch and begin fields to point to the + ;; syntable. + (dolist (item switches) + (if (keywordp (syntoken-switch item)) + ;; A switch may be relative, check if a keyword + ;; was specified. + (setf + (syntoken-switch item) + (car + (member + (syntoken-switch item) + tables + :key #'syntable-label + ) + ) + ) + ) + ) + (dolist (item begins) + (setf + (syntoken-begin item) + (car + (member + (syntoken-begin item) + tables + :key #'syntable-label + ) + ) + ) + ) + + ;; Don't need to add a entity for default properties + (dolist (item (car elements)) + (and + (syntoken-property item) + (string= (synprop-name (syntoken-property item)) "default") + (setf (syntoken-property item) ()) + ) + ) + (dolist (item tables) + (and + (syntable-property item) + (string= (synprop-name (syntable-property item)) "default") + (setf (syntable-property item) ()) + ) + ) + + (setq syntax + (make-syntax + :name name + :options options + :labels tables + :quark + (compile-syntax-property-list + name + properties + ) + :token-count + (length (car elements)) + ) + ) + + ;; Ready to run! +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Loop applying the specifed syntax table to the text. +;; XXX This function needs a review. Should compile the regex patterns +;; with newline sensitive match (and scan the entire file), and keep a +;; cache of matched tokens (that may be at a very longer offset), and, +;; when the match is removed from the cache, readd the token to the +;; token-list; if the token does not match, it will not be in the cache, +;; but should be removed from the token-list. If properly implemented, it +;; should be somewhat like 4 times faster, but I would not be surprised +;; if it becames even faster. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun syntax-highlight (*syntax* + &optional + (*from* (point-min)) + (*to* (point-max)) + interactive + &aux +#+debug (*line-number* 0) + stream + indent-table + ) + + ;; Make sure the property list is in use. + ;; The interactive flag is only set after loading the file. + (or interactive + (property-list (syntax-quark *syntax*)) + ) + +#+debug + (setq *from* 0 *to* 0) + +#-debug + (and (>= *from* *to*) (return-from syntax-highlight (values *from* nil))) + + ;; Remove any existing properties from the text. + (clear-entities *from* (1+ *to*)) + + (setq stream +#-debug (make-string-input-stream (read-text *from* (- *to* *from*))) +#+debug *standard-input* + ) + + (prog* + ( + ;; Used to check if end of file found but syntax stack did + ;; not finish. + (point-max (point-max)) + + ;; Used in interactive mode, to return the syntax table + ;; where the cursor is located. + (point (point)) + + ;; The current stack of states. + stack + + ;; The current syntable. + (syntax-table (car (syntax-labels *syntax*))) + + ;; The current syntable's default property. + (default-property (syntable-property syntax-table)) + + ;; Add this property to newlines as a hint to the interactive + ;; callback, so that it knows from where to restart parsing. + newline-property + + ;; The tokens in the current syntax table that may match, + ;; i.e. the items in this list are not in nomatch. + token-list + + ;; A pointer to the syntable token list, if token-list is + ;; eq to this value, cannot change it inplace. + current-token-list + + ;; Help to avoid allocating too many new object cells, and + ;; optmizes a bit time in [n]?set-difference. + ;; This optimizes only the processing of one line of text + ;; as nomatch must be rebuilt when reading a new line of text. + token-list-stack + + ;; Matches for the current list of tokens. + matches + + ;; Line of text. + line + + ;; Length of the text line. + length + + ;; A inverse cache, don't call re-exec when the regex is + ;; already known to not match. + nomatch + + ;; Use cache as a list of matches to avoid repetitive + ;; unnecessary calls to re-exec. + ;; cache is a list in which every element has the format: + ;; (token . (start . end)) + ;; Line of text. + cache + + ;; Used just to avoid a function call at every re-exec call. + notbol + + match + + start + left + right + result + property + + ;; Beginig a new syntax table? + begin + + ;; Switching to another syntax table? + switch + + ;; Property flag when changing the current syntax table. + contained + + ;; Flag to know if syntax table has changed. + change + + ;; Variables used when removing invalid elements from the + ;; the cache. + item + from + to + ) + +;----------------------------------------------------------------------- +:read +#+debug-verbose + (format t "** Entering :READ stack length is ~D~%" (length stack)) +#+debug (format t "~%[~D]> " (incf *line-number*)) + + ;; If input has finished, return. + (unless (setq line (read-line stream nil nil)) + (when + (and + ;; If a nested syntax table wasn't finished + (consp stack) + (< + (setq *to* (scan *from* :eol :right)) + point-max + ) + ) + (setq line (read-text *from* (- *to* *from*))) + (clear-entities *from* (1+ *to*)) + (go :again) + ) +#-debug (close stream) + (return) + ) + +;------------------------------------------------------------------------ +:again + (setq + start 0 + length (length line) + token-list (syntable-tokens syntax-table) + current-token-list token-list + token-list-stack () + nomatch () + cache () + ) + + + ;; If empty line, and current table does not have matches for + ;; the empty string at start or end of a text line. + (when + (and + (= length 0) + (not (syntable-eol syntax-table)) + (not (syntable-bol syntax-table))) +#+debug-verbose + (format t "Empty line and table has no match to bol or eol~%") + + (and newline-property + (add-entity *from* 1 (synprop-quark newline-property))) + (go :update) + ) + +;------------------------------------------------------------------------ +:loop +#+debug-verbose + (format t "** Entering :LOOP at offset ~D in table ~A, cache has ~D items~%" + start + (syntable-label syntax-table) + (length cache)) + + (setq notbol (> start 0)) + + ;; For every token that may match. + (dolist + (token + (setq + token-list + (if (eq token-list current-token-list) + (set-difference token-list nomatch :test #'eq) + (nset-difference token-list nomatch :test #'eq) + ) + ) + ) + + ;; Try to fetch match from cache. + (if (setq match (member token cache :test #'eq :key #'car)) + ;; Match is in the cache. + + (progn + ;; Match must be moved to the beginning of the + ;; matches list, as a match from another syntax + ;; table may be also in the cache, but before + ;; the match for the current token. +#+debug-verbose (format t "cached: {~A:~S} ~A~%" + (cdar match) + (subseq line (cadar match) (cddar match)) + (syntoken-regex token)) + + ;; Remove the match from the cache. + (if (eq match cache) + + ;; This could be changed to only set "matches" + ;; if it is not the first element of cache, + ;; but is unsafe, because other tokens may + ;; be added to "matches", and will end up + ;; before when joining "matches" and "cache". + (progn + (setq cache (cdr cache)) + (rplacd match matches) + (setq matches match)) + + (progn + (if (= (length match) 1) + (progn + (rplacd (last cache 2) nil) + (rplacd match matches) + (setq matches match)) + (progn + (setq matches (cons (car match) matches)) + (rplaca match (cadr match)) + (rplacd match (cddr match))) + ) + ) + ) + + ;; Exit loop if the all the remaining + ;; input was matched. + (when + (and + (= start (cadar match)) + (= length (cddar match)) + ) +#+debug-verbose (format t "Rest of line match~%") + (return) + ) + ) + + ;; Not in the cache, call re-exec. + (if + (consp + (setq + match + (re-exec + (syntoken-regex token) + line + :start start + :notbol notbol))) + + ;; Match found. + (progn +#+debug-verbose (format t "Adding to cache: {~A:~S} ~A~%" + (car match) + (subseq line (caar match) (cdar match)) + (syntoken-regex token)) + + ;; Only the first pair is used. + (setq match (car match)) + + (cond + ( + (or + (null matches) + ;; No overlap and after most + ;; recent match. + (>= (car match) (cddar matches)) + ;; No overlap and before most + ;; recent match. + (<= (cdr match) (cadar matches)) + ) + (setq + matches + (cons (cons token match) matches) + ) + ) + ( + (or + ;; Overlap, but start before most + ;; recent match. + (< (car match) (cadar matches)) + (and + ;; Same offset as most recent + ;; match, but is longer. + (= (car match) (cadar matches)) + (> (cdr match) (cddar matches)) + ) + ) + (rplaca (car matches) token) + (rplacd (car matches) match) +#+debug-verbose (format t "Replaced most recent match~%") + ) + (t +#+debug-verbose (format t "Ignored~%") + ;; XXX The interpreter does not yet implement + ;; implicit tagbody in dolist, just comment + ;; the go call in that case. (Will just do + ;; an unecessary test...) + (go :ignored) + ) + ) + + ;; Exit loop if the all the remaining + ;; input was matched. + (when + (and + (= start (car match)) + (= length (cdr match))) +#+debug-verbose (format t "Rest of line match~%") + (return)) + ) + + ;; Match not found. + (progn +#+debug-verbose (format t "Adding to nomatch: ~A~%" + (syntoken-regex token)) + (setq nomatch (cons token nomatch))) + ) + ) +:ignored + ) + + ;; Add matches to the beginning of the cache list. + (setq + ;; Put matches with smaller offset first. + cache + (stable-sort (nconc (nreverse matches) cache) #'< :key #'cadr) + + ;; Make sure that when the match loop is reentered, this + ;; variable is NIL. + matches + () + ) + + ;; While the first entry in the cache is not from the current table. + (until (or (null cache) (member (caar cache) token-list :test #'eq)) + +#+debug-verbose + (format t "Not in the current table, removing {~A:~S} ~A~%" + (cdar cache) + (subseq line (cadar cache) (cddar cache)) + (syntoken-regex (caar cache))) + + (setq cache (cdr cache)) + ) + + + ;; If nothing was matched in the entire/remaining line. + (unless cache + (when default-property + (if + (or + (null result) + (> start (cadar result)) + (not (eq (cddar result) default-property))) + (setq + result + (cons + (cons start (cons length default-property)) + result + ) + ) + (rplaca (cdar result) length) + ) + ) + +#+debug-verbose + (format t "No match until end of line~%") + + ;; Result already known, and there is no syntax table + ;; change, bypass :PARSE. + (and interactive + (null indent-table) + (<= 0 (- point *from*) length) + (setq indent-table syntax-table)) + (go :process) + ) + +#+debug-verbose + (format t "Removing first candidate from cache {~A:~S} ~A~%" + (cdar cache) + (subseq line (cadar cache) (cddar cache)) + (syntoken-regex (caar cache)) + ) + + ;; Prepare to choose best match. + (setq + match (car cache) + left (cadr match) + right (cddr match) + cache (cdr cache) + ) + + ;; First element can be safely removed now. + ;; If there is only one, skip loop below. + (or cache (go :parse)) + + ;; Remove elements of cache that must be discarded. + (setq + item (car cache) + from (cadr item) + to (cddr item) + ) + + (loop + (if + (or + + ;; If everything removed from the cache. + (null item) + + ;; Or next item is at a longer offset than the + ;; end of current match. + (>= from right) + ) + (return) + ) + + (and + ;; If another match at the same offset. + (= left from) + + ;; And if this match is longer than the current one. + (> to right) + + (member (car item) token-list :test #'eq) + + (setq + match item + right to + ) + ) + +#+debug-verbose + (format t "Removing from cache {~A:~S} ~A~%" + (cdar cache) + (subseq line from to) + (syntoken-regex (caar cache))) + + (setq + cache (cdr cache) + item (car cache) + from (cadr item) + to (cddr item) + ) + ) + + +;----------------------------------------------------------------------- +:parse +#+debug-verbose + (format t "** Entering :PARSE~%") + + (setq + + ;; Change match value to the syntoken. + match (car match) + + begin (syntoken-begin match) + switch (syntoken-switch match) + contained (syntoken-contained match) + change (or begin switch) + ) + + ;; Check for unmatched leading text. + (when (and default-property (> left start)) +#+debug-verbose (format t "No match in {(~D . ~D):~S}~%" + start + left + (subseq line start left) + ) + (if + (or + (null result) + (> start (cadar result)) + (not (eq (cddar result) default-property))) + (setq + result + (cons + (cons start (cons left default-property)) + result + ) + ) + (rplaca (cdar result) left) + ) + ) + + ;; If the syntax table is not changed, + ;; or if the new table requires that the + ;; current default property be used. + (unless (and change contained) + + (and + (> right left) + (setq + property + (or + ;; If token specifies the property. + (syntoken-property match) + default-property + ) + ) + + ;; Add matched text. + (if + (or + (null result) + (> left (cadar result)) + (not (eq (cddar result) property)) + ) + (setq + result + (cons + (cons left (cons right property)) + result + ) + ) + (rplaca (cdar result) right) + ) + ) + +#+debug-verbose + (format t "(0)Match found for {(~D . ~D):~S}~%" + left + right + (subseq line left right) + ) + ) + + + ;; Update start offset in the input now! + (and interactive + (null indent-table) + (<= start (- point *from*) right) + (setq indent-table syntax-table)) + (setq start right) + + + ;; When changing the current syntax table. + (when change + (when switch + (if (numberp switch) + + ;; If returning to a previous state. + ;; Don't generate an error if the stack + ;; becomes empty? + (while + (< switch 0) + + (setq + syntax-table (pop stack) + token-list (pop token-list-stack) + switch (1+ switch) + ) + ) + + ;; Else, not to a previous state, but + ;; returning to a named syntax table, + ;; search for it in the stack. + (while + (and + + (setq + token-list (pop token-list-stack) + syntax-table (pop stack) + ) + + (not (eq switch syntax-table)) + ) + ;; Empty loop. + ) + ) + + ;; If no match found while popping + ;; the stack. + (unless syntax-table + + ;; Return to the topmost syntax table. + (setq + syntax-table + (car (syntax-labels *syntax*)) + ) + ) + +#+debug-verbose (format t "switching to ~A offset: ~D~%" + (syntable-label syntax-table) + start + ) + + (if (null token-list) + (setq token-list (syntable-tokens syntax-table)) + ) + ) + + (when begin + ;; Save state for a possible + ;; :SWITCH later. + (setq + stack (cons syntax-table stack) + token-list-stack (cons token-list token-list-stack) + token-list (syntable-tokens begin) + syntax-table begin + ) +#+debug-verbose (format t "begining ~A offset: ~D~%" + (syntable-label syntax-table) + start + ) + ) + + ;; Change current syntax table. + (setq + default-property (syntable-property syntax-table) + current-token-list (syntable-tokens syntax-table) + ) + + ;; Set newline property, to help interactive callback + ;; Only need to have a defined value, for now don't care + ;; about wich value is being used, neither if there is + ;; a value to be set. + (if (null stack) + (setq newline-property nil) + (or newline-property + (setq newline-property default-property) + (setq newline-property (syntoken-property match)) + ) + ) + + ;; If processing of text was deferred. + (when contained + + (and + (> right left) + (setq + property + (or + (syntoken-property match) + default-property + ) + ) + ;; Add matched text with the updated property. + (if + (or + (null result) + (> left (cadar result)) + (not (eq (cddar result) property)) + ) + (setq + result + (cons + (cons left (cons right property)) + result + ) + ) + (rplaca (cdar result) right) + ) + ) + +#+debug-verbose (format t "(1)Match found for {(~D . ~D):~S}~%" + left + right + (subseq line left right) + ) + ) + + (go :loop) + ) + + +;----------------------------------------------------------------------- + ;; Wait for the end of the line to process, so that + ;; it is possible to join sequential matches with the + ;; same text property. + (and (or cache (< start length)) (go :loop)) +:process + +#+debug-verbose + (format t "** Entering :PROCESS~%") + + (if result + (progn + ;; If the last property was at the end of the line, + ;; there are nested syntax tables, and there is a + ;; default property, include the newline in the property, + ;; as a hint to the interactive callback. + (and + newline-property + (if + (and + (eq (cddar result) newline-property) + (= length (cadar result)) + ) + (rplaca (cdar result) (1+ length)) + (setq + result + (cons + (cons length (cons (1+ length) newline-property)) + result + ) + ) + ) + ) + + ;; Result was created in reversed order. + (nreverse result) + (dolist (item result) + (setq + left (car item) + right (cadr item) + property (cddr item)) + + ;; Use the information. + (add-entity + (+ *from* left) + (- right left) + (synprop-quark property)) + ) + ) + + (and newline-property + (add-entity + (+ *from* length) + 1 + (synprop-quark newline-property)) + ) + ) + +;------------------------------------------------------------------------ +:update + ;; Prepare for new matches. + (setq + result nil + + ;; Update offset to read text. + ;; Add 1 for the skipped newline. + *from* (+ *from* length 1) + ) + + (go :read) + ) + +#+debug (terpri) + (values *to* indent-table) +) + +(compile 'syntax-highlight) diff --git a/lisp/modules/x11.c b/lisp/modules/x11.c new file mode 100644 index 0000000..3cdb0bc --- /dev/null +++ b/lisp/modules/x11.c @@ -0,0 +1,666 @@ +/* + * 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/modules/x11.c,v 1.10 2002/11/23 08:26:52 paulo Exp $ */ + +#include <stdlib.h> +#include <string.h> +#include "internal.h" +#include "private.h" +#include <X11/Xlib.h> + +/* + * Prototypes + */ +int x11LoadModule(void); + +LispObj *Lisp_XOpenDisplay(LispBuiltin *builtin); +LispObj *Lisp_XCloseDisplay(LispBuiltin *builtin); +LispObj *Lisp_XDefaultRootWindow(LispBuiltin *builtin); +LispObj *Lisp_XDefaultScreen(LispBuiltin *builtin); +LispObj *Lisp_XDefaultScreenOfDisplay(LispBuiltin *builtin); +LispObj *Lisp_XBlackPixel(LispBuiltin *builtin); +LispObj *Lisp_XBlackPixelOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XWidthOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XHeightOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XWhitePixel(LispBuiltin *builtin); +LispObj *Lisp_XWhitePixelOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XDefaultGC(LispBuiltin *builtin); +LispObj *Lisp_XDefaultGCOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XCreateSimpleWindow(LispBuiltin *builtin); +LispObj *Lisp_XMapWindow(LispBuiltin *builtin); +LispObj *Lisp_XDestroyWindow(LispBuiltin *builtin); +LispObj *Lisp_XFlush(LispBuiltin *builtin); +LispObj *Lisp_XRaiseWindow(LispBuiltin *builtin); +LispObj *Lisp_XBell(LispBuiltin *builtin); + +LispObj *Lisp_XDrawLine(LispBuiltin *builtin); + +/* + * Initialization + */ +static LispBuiltin lispbuiltins[] = { + {LispFunction, Lisp_XOpenDisplay, "x-open-display &optional display-name"}, + {LispFunction, Lisp_XCloseDisplay, "x-close-display display"}, + {LispFunction, Lisp_XDefaultRootWindow, "x-default-root-window display"}, + {LispFunction, Lisp_XDefaultScreen, "x-default-screen display"}, + {LispFunction, Lisp_XDefaultScreenOfDisplay, "x-default-screen-of-display display"}, + {LispFunction, Lisp_XBlackPixel, "x-black-pixel display &optional screen"}, + {LispFunction, Lisp_XBlackPixelOfScreen, "x-black-pixel-of-screen screen"}, + {LispFunction, Lisp_XWhitePixel, "x-white-pixel display &optional screen"}, + {LispFunction, Lisp_XWhitePixelOfScreen, "x-white-pixel-of-screen screen"}, + {LispFunction, Lisp_XDefaultGC, "x-default-gc display &optional screen"}, + {LispFunction, Lisp_XDefaultGCOfScreen, "x-default-gc-of-screen screen"}, + {LispFunction, Lisp_XCreateSimpleWindow, "x-create-simple-window display parent x y width height &optional border-width border background"}, + {LispFunction, Lisp_XMapWindow, "x-map-window display window"}, + {LispFunction, Lisp_XDestroyWindow, "X-DESTROY-WINDOW"}, + {LispFunction, Lisp_XFlush, "x-flush display"}, + {LispFunction, Lisp_XDrawLine, "x-draw-line display drawable gc x1 y1 x2 y2"}, + {LispFunction, Lisp_XBell, "x-bell display &optional percent"}, + {LispFunction, Lisp_XRaiseWindow, "x-raise-window display window"}, + {LispFunction, Lisp_XWidthOfScreen, "x-width-of-screen screen"}, + {LispFunction, Lisp_XHeightOfScreen, "x-height-of-screen screen"}, +}; + +LispModuleData x11LispModuleData = { + LISP_MODULE_VERSION, + x11LoadModule +}; + +static int x11Display_t, x11Screen_t, x11Window_t, x11GC_t; + +/* + * Implementation + */ +int +x11LoadModule(void) +{ + int i; + + x11Display_t = LispRegisterOpaqueType("Display*"); + x11Screen_t = LispRegisterOpaqueType("Screen*"); + x11Window_t = LispRegisterOpaqueType("Window"); + x11GC_t = LispRegisterOpaqueType("GC"); + + for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++) + LispAddBuiltinFunction(&lispbuiltins[i]); + + return (1); +} + +LispObj * +Lisp_XOpenDisplay(LispBuiltin *builtin) +/* +x-open-display &optional display-name + */ +{ + LispObj *display_name; + char *dname; + + display_name = ARGUMENT(0); + + if (display_name == UNSPEC) + dname = NULL; + else { + CHECK_STRING(display_name); + dname = THESTR(display_name); + } + + return (OPAQUE(XOpenDisplay(dname), x11Display_t)); +} + +LispObj * +Lisp_XCloseDisplay(LispBuiltin *builtin) +/* + x-close-display display + */ +{ + LispObj *display; + + display = ARGUMENT(0); + + if (!CHECKO(display, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(display)); + + XCloseDisplay((Display*)(display->data.opaque.data)); + + return (NIL); +} + +LispObj * +Lisp_XDefaultRootWindow(LispBuiltin *builtin) +/* + x-default-root-window display + */ +{ + LispObj *display; + + display = ARGUMENT(0); + + if (!CHECKO(display, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(display)); + + return (OPAQUE(DefaultRootWindow((Display*)(display->data.opaque.data)), + x11Window_t)); +} + +LispObj * +Lisp_XDefaultScreen(LispBuiltin *builtin) +/* + x-default-screen display + */ +{ + LispObj *display; + + display = ARGUMENT(0); + + if (!CHECKO(display, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(display)); + + return (INTEGER(DefaultScreen((Display*)(display->data.opaque.data)))); +} + +LispObj * +Lisp_XDefaultScreenOfDisplay(LispBuiltin *builtin) +/* + x-default-screen-of-display display + */ +{ + LispObj *display; + + display = ARGUMENT(0); + + if (!CHECKO(display, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(display)); + + return (OPAQUE(DefaultScreenOfDisplay((Display*)(display->data.opaque.data)), + x11Screen_t)); +} + +LispObj * +Lisp_XBlackPixel(LispBuiltin *builtin) +/* + x-black-pixel display &optional screen + */ +{ + Display *display; + int screen; + + LispObj *odisplay, *oscreen; + + oscreen = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (oscreen == UNSPEC) + screen = DefaultScreen(display); + else + CHECK_INDEX(oscreen); + else + screen = FIXNUM_VALUE(oscreen); + + if (screen >= ScreenCount(display)) + LispDestroy("%s: screen index %d too large, %d screens available", + STRFUN(builtin), screen, ScreenCount(display)); + + return (INTEGER(BlackPixel(display, screen))); +} + +LispObj * +Lisp_XBlackPixelOfScreen(LispBuiltin *builtin) +/* + x-black-pixel-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (INTEGER(XBlackPixelOfScreen((Screen*)(screen->data.opaque.data)))); +} + +LispObj * +Lisp_XWhitePixel(LispBuiltin *builtin) +/* + x-white-pixel display &optional screen + */ +{ + Display *display; + int screen; + + LispObj *odisplay, *oscreen; + + oscreen = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (oscreen == UNSPEC) + screen = DefaultScreen(display); + else + CHECK_FIXNUM(oscreen); + else + screen = FIXNUM_VALUE(oscreen); + + if (screen >= ScreenCount(display)) + LispDestroy("%s: screen index %d too large, %d screens available", + STRFUN(builtin), screen, ScreenCount(display)); + + return (INTEGER(WhitePixel(display, screen))); +} + +LispObj * +Lisp_XWhitePixelOfScreen(LispBuiltin *builtin) +/* + x-white-pixel-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (INTEGER(WhitePixelOfScreen((Screen*)(screen->data.opaque.data)))); +} + +LispObj * +Lisp_XDefaultGC(LispBuiltin *builtin) +/* + x-default-gc display &optional screen + */ +{ + Display *display; + int screen; + + LispObj *odisplay, *oscreen; + + oscreen = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (oscreen == UNSPEC) + screen = DefaultScreen(display); + else + CHECK_FIXNUM(oscreen); + else + screen = FIXNUM_VALUE(oscreen); + + if (screen >= ScreenCount(display)) + LispDestroy("%s: screen index %d too large, %d screens available", + STRFUN(builtin), screen, ScreenCount(display)); + + return (OPAQUE(DefaultGC(display, screen), x11GC_t)); +} + +LispObj * +Lisp_XDefaultGCOfScreen(LispBuiltin *builtin) +/* + x-default-gc-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (OPAQUE(DefaultGCOfScreen((Screen*)(screen->data.opaque.data)), + x11GC_t)); +} + +LispObj * +Lisp_XCreateSimpleWindow(LispBuiltin *builtin) +/* + x-create-simple-window display parent x y width height &optional border-width border background + */ +{ + Display *display; + Window parent; + int x, y; + unsigned int width, height, border_width; + unsigned long border, background; + + LispObj *odisplay, *oparent, *ox, *oy, *owidth, *oheight, + *oborder_width, *oborder, *obackground; + + obackground = ARGUMENT(8); + oborder = ARGUMENT(7); + oborder_width = ARGUMENT(6); + oheight = ARGUMENT(5); + owidth = ARGUMENT(4); + oy = ARGUMENT(3); + ox = ARGUMENT(2); + oparent = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (!CHECKO(oparent, x11Window_t)) + LispDestroy("%s: cannot convert %s to Window", + STRFUN(builtin), STROBJ(oparent)); + parent = (Window)(oparent->data.opaque.data); + + CHECK_FIXNUM(ox); + x = FIXNUM_VALUE(ox); + + CHECK_FIXNUM(oy); + y = FIXNUM_VALUE(oy); + + CHECK_INDEX(owidth); + width = FIXNUM_VALUE(owidth); + + CHECK_INDEX(oheight); + height = FIXNUM_VALUE(oheight); + + /* check &OPTIONAL parameters */ + if (oborder_width == UNSPEC) + border_width = 1; + else + CHECK_INDEX(oborder_width); + else + border_width = FIXNUM_VALUE(oborder_width); + + if (oborder == UNSPEC) + border = BlackPixel(display, DefaultScreen(display)); + else + CHECK_LONGINT(oborder); + else + border = LONGINT_VALUE(oborder); + + if (obackground == UNSPEC) + background = WhitePixel(display, DefaultScreen(display)); + else + CHECK_LONGINT(obackground); + else + background = LONGINT_VALUE(obackground); + + return (OPAQUE( + XCreateSimpleWindow(display, parent, x, y, width, height, + border_width, border, background), + x11Window_t)); +} + +LispObj * +Lisp_XMapWindow(LispBuiltin *builtin) +/* + x-map-window display window + */ +{ + Display *display; + Window window; + + LispObj *odisplay, *owindow; + + owindow = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (!CHECKO(owindow, x11Window_t)) + LispDestroy("%s: cannot convert %s to Window", + STRFUN(builtin), STROBJ(owindow)); + window = (Window)(owindow->data.opaque.data); + + XMapWindow(display, window); + + return (owindow); +} + +LispObj * +Lisp_XDestroyWindow(LispBuiltin *builtin) +/* + x-destroy-window display window + */ +{ + Display *display; + Window window; + + LispObj *odisplay, *owindow; + + owindow = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (!CHECKO(owindow, x11Window_t)) + LispDestroy("%s: cannot convert %s to Window", + STRFUN(builtin), STROBJ(owindow)); + window = (Window)(owindow->data.opaque.data); + + XDestroyWindow(display, window); + + return (NIL); +} + +LispObj * +Lisp_XFlush(LispBuiltin *builtin) +/* + x-flush display + */ +{ + Display *display; + + LispObj *odisplay; + + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + XFlush(display); + + return (odisplay); +} + +LispObj * +Lisp_XDrawLine(LispBuiltin *builtin) +/* + x-draw-line display drawable gc x1 y1 x2 y2 + */ +{ + Display *display; + Drawable drawable; + GC gc; + int x1, y1, x2, y2; + + LispObj *odisplay, *odrawable, *ogc, *ox1, *oy1, *ox2, *oy2; + + oy2 = ARGUMENT(6); + ox2 = ARGUMENT(5); + oy1 = ARGUMENT(4); + ox1 = ARGUMENT(3); + ogc = ARGUMENT(2); + odrawable = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + /* XXX correct check when drawing to pixmaps implemented */ + if (!CHECKO(odrawable, x11Window_t)) + LispDestroy("%s: cannot convert %s to Drawable", + STRFUN(builtin), STROBJ(odrawable)); + drawable = (Drawable)(odrawable->data.opaque.data); + + if (!CHECKO(ogc, x11GC_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(ogc)); + gc = (GC)(ogc->data.opaque.data); + + CHECK_FIXNUM(ox1); + x1 = FIXNUM_VALUE(ox1); + + CHECK_FIXNUM(oy1); + y1 = FIXNUM_VALUE(oy1); + + CHECK_FIXNUM(ox2); + x2 = FIXNUM_VALUE(ox2); + + CHECK_FIXNUM(oy2); + y2 = FIXNUM_VALUE(oy2); + + XDrawLine(display, drawable, gc, x1, y1, x2, y2); + + return (odrawable); +} + +LispObj * +Lisp_XBell(LispBuiltin *builtin) +/* + x-bell &optional percent + */ +{ + Display *display; + int percent; + + LispObj *odisplay, *opercent; + + opercent = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (opercent == UNSPEC) + percent = 0; + else + CHECK_FIXNUM(opercent); + else + percent = FIXNUM_VALUE(opercent); + + if (percent < -100 || percent > 100) + LispDestroy("%s: percent value %d out of range -100 to 100", + STRFUN(builtin), percent); + + XBell(display, percent); + + return (odisplay); +} + +LispObj * +Lisp_XRaiseWindow(LispBuiltin *builtin) +/* + x-raise-window display window + */ +{ + Display *display; + Window window; + + LispObj *odisplay, *owindow; + + owindow = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (!CHECKO(owindow, x11Window_t)) + LispDestroy("%s: cannot convert %s to Window", + STRFUN(builtin), STROBJ(owindow)); + window = (Window)(owindow->data.opaque.data); + + XRaiseWindow(display, window); + + return (owindow); +} + +LispObj * +Lisp_XWidthOfScreen(LispBuiltin *builtin) +/* + x-width-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (FIXNUM(WidthOfScreen((Screen*)(screen->data.opaque.data)))); +} + +LispObj * +Lisp_XHeightOfScreen(LispBuiltin *builtin) +/* + x-height-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (FIXNUM(HeightOfScreen((Screen*)(screen->data.opaque.data)))); +} diff --git a/lisp/modules/xaw.c b/lisp/modules/xaw.c new file mode 100644 index 0000000..c2b372b --- /dev/null +++ b/lisp/modules/xaw.c @@ -0,0 +1,665 @@ +/* + * 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/modules/xaw.c,v 1.14 2002/11/23 08:26:52 paulo Exp $ */ + +#include <stdlib.h> +#include <X11/Intrinsic.h> +#include <X11/StringDefs.h> +#include <X11/Xaw/AsciiSink.h> +#include <X11/Xaw/AsciiSrc.h> +#include <X11/Xaw/AsciiText.h> +#include <X11/Xaw/Box.h> +#include <X11/Xaw/Command.h> +#include <X11/Xaw/Dialog.h> +#include <X11/Xaw/Form.h> +#include <X11/Xaw/Grip.h> +#include <X11/Xaw/Label.h> +#include <X11/Xaw/List.h> +#include <X11/Xaw/MenuButton.h> +#include <X11/Xaw/MultiSink.h> +#include <X11/Xaw/MultiSrc.h> +#include <X11/Xaw/Paned.h> +#include <X11/Xaw/Panner.h> +#include <X11/Xaw/Porthole.h> +#include <X11/Xaw/Repeater.h> +#include <X11/Xaw/Scrollbar.h> +#include <X11/Xaw/Simple.h> +#include <X11/Xaw/SimpleMenu.h> +#include <X11/Xaw/SmeBSB.h> +#include <X11/Xaw/Sme.h> +#include <X11/Xaw/SmeLine.h> +#include <X11/Xaw/StripChart.h> +#include <X11/Xaw/Text.h> +#include <X11/Xaw/TextSink.h> +#include <X11/Xaw/TextSrc.h> +#include <X11/Xaw/Tip.h> +#include <X11/Xaw/Toggle.h> +#include <X11/Xaw/Tree.h> +#include <X11/Xaw/Viewport.h> +#include <X11/Vendor.h> +#include "internal.h" +#include "private.h" + +/* + * Types + */ +typedef struct { + LispObj *object; + void *data; +} WidgetData; + +/* + * Prototypes + */ +int xawLoadModule(void); +void LispXawCleanupCallback(Widget, XtPointer, XtPointer); + +/* until a better/smarter interface be written... */ +LispObj *Lisp_XawCoerceToListReturnStruct(LispBuiltin*); +LispObj *Lisp_XawScrollbarCoerceToReal(LispBuiltin*); + +LispObj *Lisp_XawFormDoLayout(LispBuiltin*); +LispObj *Lisp_XawListChange(LispBuiltin*); +LispObj *Lisp_XawListHighlight(LispBuiltin*); +LispObj *Lisp_XawListUnhighlight(LispBuiltin*); +LispObj *Lisp_XawTextGetSource(LispBuiltin*); +LispObj *Lisp_XawTextLastPosition(LispBuiltin*); +LispObj *Lisp_XawTextReplace(LispBuiltin*); +LispObj *Lisp_XawTextSearch(LispBuiltin*); +LispObj *Lisp_XawTextGetInsertionPoint(LispBuiltin*); +LispObj *Lisp_XawTextSetInsertionPoint(LispBuiltin*); +LispObj *Lisp_XawScrollbarSetThumb(LispBuiltin*); + +/* + * Initialization + */ + +static LispBuiltin lispbuiltins[] = { + {LispFunction, Lisp_XawCoerceToListReturnStruct, "xaw-coerce-to-list-return-struct opaque"}, + {LispFunction, Lisp_XawScrollbarCoerceToReal, "xaw-scrollbar-coerce-to-real opaque"}, + + {LispFunction, Lisp_XawScrollbarSetThumb, "xaw-scrollbar-set-thumb widget top &optional shown"}, + {LispFunction, Lisp_XawFormDoLayout, "xaw-form-do-layout widget force"}, + {LispFunction, Lisp_XawListChange, "xaw-list-change widget list &optional longest resize"}, + {LispFunction, Lisp_XawListHighlight, "xaw-list-highlight widget index"}, + {LispFunction, Lisp_XawListUnhighlight, "xaw-list-unhighlight widget"}, + {LispFunction, Lisp_XawTextGetSource, "xaw-text-get-source widget"}, + {LispFunction, Lisp_XawTextLastPosition, "xaw-text-last-position widget"}, + {LispFunction, Lisp_XawTextReplace, "xaw-text-replace widget left right text"}, + {LispFunction, Lisp_XawTextSearch, "xaw-text-search widget direction text"}, + {LispFunction, Lisp_XawTextGetInsertionPoint, "xaw-text-get-insertion-point widget"}, + {LispFunction, Lisp_XawTextSetInsertionPoint, "xaw-text-set-insertion-point widget position"}, +}; + +LispModuleData xawLispModuleData = { + LISP_MODULE_VERSION, + xawLoadModule +}; + +static int xawWidget_t, xawWidgetClass_t, xawListReturnStruct_t, xawFloatp_t; +static WidgetData **list_data; +static int num_list_data; + +/* + * Implementation + */ +int +xawLoadModule(void) +{ + int i; + char *fname = "XAW-LOAD-MODULE"; + + xawWidget_t = LispRegisterOpaqueType("Widget"); + xawWidgetClass_t = LispRegisterOpaqueType("WidgetClass"); + xawListReturnStruct_t = LispRegisterOpaqueType("XawListReturnStruct"); + xawFloatp_t = LispRegisterOpaqueType("float*"); + + LispExecute("(DEFSTRUCT XAW-LIST-RETURN-STRUCT STRING INDEX)\n"); + + GCDisable(); + (void)LispSetVariable(ATOM2("ASCII-SINK-OBJECT-CLASS"), + OPAQUE(asciiSinkObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("ASCII-SRC-OBJECT-CLASS"), + OPAQUE(asciiSinkObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("ASCII-TEXT-WIDGET-CLASS"), + OPAQUE(asciiTextWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("BOX-WIDGET-CLASS"), + OPAQUE(boxWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("COMMAND-WIDGET-CLASS"), + OPAQUE(commandWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("DIALOG-WIDGET-CLASS"), + OPAQUE(dialogWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("FORM-WIDGET-CLASS"), + OPAQUE(formWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("GRIP-WIDGET-CLASS"), + OPAQUE(gripWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("LABEL-WIDGET-CLASS"), + OPAQUE(labelWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("LIST-WIDGET-CLASS"), + OPAQUE(listWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("MENU-BUTTON-WIDGET-CLASS"), + OPAQUE(menuButtonWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("MULTI-SINK-OBJEC-TCLASS"), + OPAQUE(multiSinkObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("MULTI-SRC-OBJECT-CLASS"), + OPAQUE(multiSrcObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("PANED-WIDGET-CLASS"), + OPAQUE(panedWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("PANNER-WIDGET-CLASS"), + OPAQUE(pannerWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("PORTHOLE-WIDGET-CLASS"), + OPAQUE(portholeWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("REPEATER-WIDGET-CLASS"), + OPAQUE(repeaterWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SCROLLBAR-WIDGET-CLASS"), + OPAQUE(scrollbarWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SIMPLE-MENU-WIDGET-CLASS"), + OPAQUE(simpleMenuWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SIMPLE-WIDGET-CLASS"), + OPAQUE(simpleWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SME-BSB-OBJECT-CLASS"), + OPAQUE(smeBSBObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SME-LINE-OBJECT-CLASS"), + OPAQUE(smeLineObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SME-OBJECT-CLASS"), + OPAQUE(smeObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("STRIP-CHART-WIDGET-CLASS"), + OPAQUE(stripChartWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TEXT-WIDGET-CLASS"), + OPAQUE(textWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TEXT-SINKOBJECT-CLASS"), + OPAQUE(textSinkObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TEXT-SRC-OBJECT-CLASS"), + OPAQUE(textSrcObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TIP-WIDGET-CLASS"), + OPAQUE(tipWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TOGGLE-WIDGET-CLASS"), + OPAQUE(toggleWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TREE-WIDGET-CLASS"), + OPAQUE(treeWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("VIEWPORT-WIDGET-CLASS"), + OPAQUE(viewportWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("VENDOR-SHELL-WIDGET-CLASS"), + OPAQUE(vendorShellWidgetClass, xawWidgetClass_t), + fname, 0); + + /* return codes of XawTextReplace */ + (void)LispSetVariable(ATOM2("XAW-REPLACE-ERROR"), + INTEGER(XawReplaceError), fname, 0); + (void)LispSetVariable(ATOM2("XAW-EDIT-DONE"), + INTEGER(XawEditDone), fname, 0); + (void)LispSetVariable(ATOM2("XAW-EDIT-ERROR"), + INTEGER(XawEditError), fname, 0); + (void)LispSetVariable(ATOM2("XAW-POSITION-ERROR"), + INTEGER(XawPositionError), fname, 0); + + /* return code of XawTextSearch */ + (void)LispSetVariable(ATOM2("XAW-TEXT-SEARCH-ERROR"), + INTEGER(XawTextSearchError), fname, 0); + + /* enum XawTextScanDirection */ + (void)LispSetVariable(ATOM2("XAWSD-LEFT"), + INTEGER(XawsdLeft), fname, 0); + (void)LispSetVariable(ATOM2("XAWSD-RIGHT"), + INTEGER(XawsdRight), fname, 0); + GCEnable(); + + for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++) + LispAddBuiltinFunction(&lispbuiltins[i]); + + return (1); +} + +void +LispXawCleanupCallback(Widget w, XtPointer user_data, XtPointer call_data) +{ + WidgetData *data = (WidgetData*)user_data; + + UPROTECT(CAR(data->object), data->object); + XtFree((XtPointer)data->data); + XtFree((XtPointer)data); +} + +LispObj * +Lisp_XawCoerceToListReturnStruct(LispBuiltin *builtin) +/* + xaw-coerce-to-list-return-struct opaque + */ +{ + LispObj *result, *code, *ocod = COD; + XawListReturnStruct *retlist; + + LispObj *opaque; + + opaque = ARGUMENT(0); + + if (!CHECKO(opaque, xawListReturnStruct_t)) + LispDestroy("%s: cannot convert %s to XawListReturnStruct", + STRFUN(builtin), STROBJ(opaque)); + + retlist = (XawListReturnStruct*)(opaque->data.opaque.data); + + GCDisable(); + code = CONS(ATOM("MAKE-XAW-LIST-RETURN-STRUCT"), + CONS(KEYWORD("STRING"), + CONS(STRING(retlist->string), + CONS(KEYWORD("INDEX"), + CONS(INTEGER(retlist->list_index), NIL))))); + COD = CONS(code, COD); + GCEnable(); + + result = EVAL(code); + COD = ocod; + + return (result); +} + +LispObj * +Lisp_XawScrollbarCoerceToReal(LispBuiltin *builtin) +/* + xaw-scrollbar-coerce-to-real opaque + */ +{ + LispObj *result; + float *floatp; + double real; + + LispObj *opaque; + + opaque = ARGUMENT(0); + + if (!CHECKO(opaque, xawFloatp_t)) + LispDestroy("%s: cannot convert %s to float*", + STRFUN(builtin), STROBJ(opaque)); + + floatp = (float*)(opaque->data.opaque.data); + real = *floatp; + + return (DFLOAT(real)); +} + +LispObj * +Lisp_XawFormDoLayout(LispBuiltin *builtin) +/* + xaw-form-do-layout widget force + */ +{ + int force; + + LispObj *owidget, *oforce; + + oforce = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + force = oforce != NIL; + XawFormDoLayout((Widget)(owidget->data.opaque.data), force); + + return (oforce); +} + +LispObj * +Lisp_XawTextGetSource(LispBuiltin *builtin) +/* + xaw-text-get-source widget + */ +{ + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + return (OPAQUE(XawTextGetSource((Widget)(owidget->data.opaque.data)), + xawWidget_t)); +} + +LispObj * +Lisp_XawTextLastPosition(LispBuiltin *builtin) +/* + xaw-text-last-position widget + */ +{ + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + return (FIXNUM(XawTextLastPosition((Widget)(owidget->data.opaque.data)))); +} + +LispObj * +Lisp_XawTextGetInsertionPoint(LispBuiltin *builtin) +/* + xaw-text-get-insertion-point widget + */ +{ + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + return (FIXNUM(XawTextGetInsertionPoint((Widget)(owidget->data.opaque.data)))); +} + +LispObj * +Lisp_XawTextSetInsertionPoint(LispBuiltin *builtin) +/* + xaw-text-set-insertion-point widget position + */ +{ + Widget widget; + XawTextPosition position; + + LispObj *owidget, *oposition; + + oposition = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_INDEX(oposition); + position = (XawTextPosition)FIXNUM_VALUE(oposition); + + XawTextSetInsertionPoint(widget, position); + + return (oposition); +} + +LispObj * +Lisp_XawTextReplace(LispBuiltin *builtin) +/* + xaw-text-replace widget left right text + */ +{ + Widget widget; + XawTextPosition left, right; + XawTextBlock block; + + LispObj *owidget, *oleft, *oright, *otext; + + otext = ARGUMENT(3); + oright = ARGUMENT(2); + oleft = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_INDEX(oleft); + left = (XawTextPosition)FIXNUM_VALUE(oleft); + + CHECK_INDEX(oright); + right = (XawTextPosition)FIXNUM_VALUE(oright); + + CHECK_STRING(otext); + block.firstPos = 0; + block.ptr = THESTR(otext); + block.length = strlen(block.ptr); + block.format = FMT8BIT; + + return (FIXNUM(XawTextReplace(widget, left, right, &block))); +} + +LispObj * +Lisp_XawTextSearch(LispBuiltin *builtin) +/* + xaw-text-search widget direction text + */ +{ + Widget widget; + XawTextScanDirection direction; + XawTextBlock block; + + LispObj *owidget, *odirection, *otext; + + otext = ARGUMENT(2); + odirection = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_INDEX(odirection); + direction = (XawTextPosition)FIXNUM_VALUE(odirection); + if (direction != XawsdLeft && direction != XawsdRight) + LispDestroy("%s: %d does not fit in XawTextScanDirection", + STRFUN(builtin), direction); + + CHECK_STRING(otext); + block.firstPos = 0; + block.ptr = THESTR(otext); + block.length = strlen(block.ptr); + block.format = FMT8BIT; + + return (FIXNUM(XawTextSearch(widget, direction, &block))); +} + +LispObj * +Lisp_XawListChange(LispBuiltin *builtin) +/* + xaw-list-change widget list &optional longest resize + */ +{ + Widget widget; + String *list; + int i, nitems; + int longest; + Boolean resize; + LispObj *object; + WidgetData *data; + + LispObj *owidget, *olist, *olongest, *oresize; + + oresize = ARGUMENT(3); + olongest = ARGUMENT(2); + olist = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_LIST(olist); + for (nitems = 0, object = olist; CONSP(object); + ++nitems, object = CDR(object)) + CHECK_STRING(CAR(object)); + + if (olongest != UNSPEC) { + CHECK_INDEX(olongest); + longest = FIXNUM_VALUE(olongest); + } + else + XtVaGetValues(widget, XtNlongest, &longest, NULL, 0); + resize = oresize != UNSPEC && oresize != NIL; + + /* No errors in arguments, build string list */ + list = (String*)XtMalloc(sizeof(String) * nitems); + for (i = 0, object = olist; CONSP(object); i++, object = CDR(object)) + list[i] = THESTR(CAR(object)); + + /* Check if xaw-list-change was already called + * for this widget and free previous data */ + for (i = 0; i < num_list_data; i++) + if ((Widget)CAR(list_data[i]->object)->data.opaque.data == widget) { + XtRemoveCallback(widget, XtNdestroyCallback, + LispXawCleanupCallback, list_data[i]); + LispXawCleanupCallback(widget, list_data[i], NULL); + break; + } + + if (i >= num_list_data) { + ++num_list_data; + list_data = (WidgetData**)XtRealloc((XtPointer)list_data, + sizeof(WidgetData*) * num_list_data); + } + + data = (WidgetData*)XtMalloc(sizeof(WidgetData)); + data->data = list; + list_data[i] = data; + data->object = CONS(owidget, olist); + PROTECT(owidget, data->object); + XtAddCallback(widget, XtNdestroyCallback, LispXawCleanupCallback, data); + + XawListChange(widget, list, nitems, longest, resize); + + return (olist); +} + +LispObj * +Lisp_XawListHighlight(LispBuiltin *builtin) +/* + xaw-list-highlight widget index + */ +{ + Widget widget; + int position; + + LispObj *owidget, *oindex; + + oindex = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_INDEX(oindex); + position = FIXNUM_VALUE(oindex); + + XawListHighlight(widget, position); + + return (oindex); +} + +LispObj * +Lisp_XawListUnhighlight(LispBuiltin *builtin) +/* + xaw-list-unhighlight widget + */ +{ + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + XawListUnhighlight((Widget)(owidget->data.opaque.data)); + + return (NIL); +} + +LispObj * +Lisp_XawScrollbarSetThumb(LispBuiltin *builtin) +/* + xaw-scrollbar-set-thumb widget top &optional shown + */ +{ + Widget widget; + double top, shown; + + LispObj *owidget, *otop, *oshown; + + oshown = ARGUMENT(2); + otop = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_DFLOAT(otop); + top = DFLOAT_VALUE(otop); + + if (oshown == UNSPEC) + shown = 1.0; + else { + CHECK_DFLOAT(oshown); + shown = DFLOAT_VALUE(oshown); + } + + XawScrollbarSetThumb(widget, top, shown); + + return (oshown == UNSPEC ? DFLOAT(shown) : oshown); +} diff --git a/lisp/modules/xedit.lsp b/lisp/modules/xedit.lsp new file mode 100644 index 0000000..87a85c7 --- /dev/null +++ b/lisp/modules/xedit.lsp @@ -0,0 +1,560 @@ +;; +;; Copyright (c) 2002 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/modules/xedit.lsp,v 1.10 2003/01/16 06:25:50 paulo Exp $ +;; + +(provide "xedit") + +#+debug (make-package "XEDIT" :use '("LISP" "EXT")) +(in-package "XEDIT") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; TODO The user should be able to define *auto-modes* prior to the +;; initialization here in a configuration file, since defvar only binds +;; the variable if it is unbound or doesn't have a value defined. +;; *auto-modes* is a list of conses where every car is compiled +;; to a regexp to match the name of the file being loaded. The caddr is +;; either a string, a pathname, or a syntax-p. +;; When loading a file, if the regexp in the car matches, it will check +;; the caddr value, and if it is a: +;; string: executes (load "progmodes/<the-string>.lsp") +;; pathname: executes (load <the-pathhame>) +;; syntax-p: does nothing, already loaded +;; +;; If it fails to load the file, or the returned value is not a +;; syntax-p, the entry is removed. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar *auto-modes* '( + ("\\.(c|cc|C|cxx|h|bm|xbm|xpm|l|y)$" + "C/C++" "c" . *c-mode*) + ("\\.(li?sp|scm)$" + "Lisp/Scheme" "lisp" . *lisp-mode*) + ("Imakefile|(\\.(cf|rules|tmpl|def|cpp)$)" + "X imake" "imake" . *imake-mode*) + ("[Mm]akefile.*|\\.mk$" + "Makefile" "make" . *make-mode*) + ("\\.sh$" + "Unix shell" "sh" . *sh-mode*) + ("\\.sgml?$" + "SGML" "sgml" . *sgml-mode*) + ("\\.html?$" + "HTML" "html" . *html-mode*) + ("\\.(man|\\d)$" + "Man page" "man" . *man-mode*) + ("app-defaults/\\w+|\\u[A-Za-z0-9_-]+\\.ad" + "X resource" "xrdb" . *xrdb-mode*) + ("\\<XF86Config[^/]*" + "XF86Config" "xconf" . *xconf-mode*) + ("\\.spec$" + "RPM spec" "rpm" . *rpm-mode*) + ("\\<XFree86\\.\\d+\\.log$" + "XFree86 log" "xlog" . *xlog-mode*) +)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Compile the regexps in the *auto-modes* list. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(dolist (mode *auto-modes*) + (rplaca mode (re-comp (car mode) :nosub t)) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Find the progmode associated with the given filename. +;; Returns nil if nothing matches. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun auto-mode (filename &optional symbol &aux syntax) + (if (and symbol (symbolp symbol)) + (if (boundp symbol) + (return-from auto-mode (symbol-value symbol)) + (setq syntax (cddr (find symbol *auto-modes* :key #'cdddr))) + ) + ;; symbol optional argument is not a symbol + (do* + ( + (mode *auto-modes* (cdr mode)) + (regex (caar mode) (caar mode)) + ) + ((endp mode)) + + ;; only wants to know if the regex match. + (when (listp (re-exec regex filename :count 0)) + (setq syntax (cddar mode) symbol (cdr syntax)) + (return) + ) + ) + ) + + ;; if file was already loaded + (if (and symbol (boundp symbol)) + (return-from auto-mode (symbol-value symbol)) + ) + + (when (consp syntax) + ;; point to the syntax file specification + (setq syntax (car syntax)) + + ;; try to load the syntax definition file + (if (stringp syntax) + (load + (string-concat + (namestring *default-pathname-defaults*) + "progmodes/" + syntax + ".lsp" + ) + ) + (load syntax) + ) + + (and symbol (boundp symbol) (symbol-value symbol)) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Data types. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The main syntax structure, normally, only one should exist per +;; syntax highlight module. +;; The structure is defined here so it is not required to load all +;; the extra data associated with syntax-highlight at initialization +;; time, and will never be loaded if no syntax-highlight mode is +;; defined to the files being edited. +(defstruct syntax + name ;; A unique string to identify the syntax mode. + ;; Should be the name of the language/file type. + options ;; A hash table of options specified for the + ;; language. + + ;; Field(s) defined at "compile time" + labels ;; Not exactly a list of labels, but all syntax + ;; tables for the module. + quark ;; A XrmQuark associated with the XawTextPropertyList + ;; used by this syntax mode. + token-count ;; Number of distinct syntoken structures in + ;; the syntax table. +) + +;; Xlfd description, used when combining properties. +;; Field names are self descriptive. +;; XXX Fields should be initialized as strings, but fields +;; that have an integer value should be allowed to +;; be initialized as such. +;; Combining properties in supported in Xaw, but not yet in the +;; syntax highlight code interface. Combining properties allow easier +;; implementation for markup languages, for example: +;; <b>bold<i>italic</i></b> +;; would render "bold" using a bold version of the default font, +;; and "italic" using a bold and italic version of the default font +(defstruct xlfd + foundry + family + weight + slant + setwidth + addstyle + pixel-size + point-size + res-x + res-y + spacing + avgwidth + registry + encoding +) + + +;; At some time this structure should also hold information for at least: +;; o fontset +;; o foreground pixmap +;; o background pixmap +;; XXX This is also a TODO in Xaw. +(defstruct synprop + quark ;; XrmQuark identifier of the XawTextProperty + ;; structure. This field is filled when "compiling" + ;; the syntax-table. + + name ;; String name of property, must be unique per + ;; property list. + font ;; Optional font string name of property. + foreground ;; Optional string representation of foreground color. + background ;; Optional string representation of background color. + xlfd ;; Optional xlfd structure, when combining properties. + ;; Currently combining properties logic not implemented, + ;; but fonts may be specified using the xlfd definition. + + ;; Boolean properties. + underline ;; Draw a line below the text. + overstrike ;; Draw a line over the text. + + ;; XXX Are these working in Xaw? + subscript ;; Align text to the bottom of the line. + superscript ;; Align text to the top of the line. + ;; Note: subscript and superscript only have effect when the text + ;; line has different height fonts displayed. +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utility macro, to create a "special" variable holding +;; a synprop structure. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro defsynprop (variable name + &key font foreground background xlfd underline + overstrike subscript superscript) + `(progn + (proclaim '(special ,variable)) + (setq ,variable + (make-synprop + :name ,name + :font ,font + :foreground ,foreground + :background ,background + :xlfd ,xlfd + :underline ,underline + :overstrike ,overstrike + :subscript ,subscript + :superscript ,superscript + ) + ) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Convert a synprop structure to a string in the format +;; expected by Xaw. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun synprop-to-string (synprop &aux values booleans xlfd) + (if (setq xlfd (synprop-xlfd synprop)) + (dolist + (element + `( + ("foundry" ,(xlfd-foundry xlfd)) + ("family" ,(xlfd-family xlfd)) + ("weight" ,(xlfd-weight xlfd)) + ("slant" ,(xlfd-slant xlfd)) + ("setwidth" ,(xlfd-setwidth xlfd)) + ("addstyle" ,(xlfd-addstyle xlfd)) + ("pixelsize" ,(xlfd-pixel-size xlfd)) + ("pointsize" ,(xlfd-point-size xlfd)) + ("resx" ,(xlfd-res-x xlfd)) + ("resy" ,(xlfd-res-y xlfd)) + ("spacing" ,(xlfd-spacing xlfd)) + ("avgwidth" ,(xlfd-avgwidth xlfd)) + ("registry" ,(xlfd-registry xlfd)) + ("encoding" ,(xlfd-encoding xlfd)) + ) + ) + (if (cadr element) + (setq values (append values element)) + ) + ) + ) + (dolist + (element + `( + ("font" ,(synprop-font synprop)) + ("foreground" ,(synprop-foreground synprop)) + ("background" ,(synprop-background synprop)) + ) + ) + (if (cadr element) + (setq values (append values element)) + ) + ) + + ;; Boolean attributes. These can be specified in the format + ;; <name>=<anything>, but do a nicer output as the format + ;; <name> is accepted. + (dolist + (element + `( + ("underline" ,(synprop-underline synprop)) + ("overstrike" ,(synprop-overstrike synprop)) + ("subscript" ,(synprop-subscript synprop)) + ("superscript" ,(synprop-superscript synprop)) + ) + ) + (if (cadr element) + (setq booleans (append booleans element)) + ) + ) + + ;; Play with format conditionals, list iteration, and goto, to + ;; make resulting string. + (format + nil + "~A~:[~;?~]~:[~3*~;~A=~A~{&~A=~A~}~]~:[~;&~]~:[~2*~;~A~{&~A~*~}~]" + + (synprop-name synprop) ;; ~A + (or values booleans) ;; ~:[~;?~] + values ;; ~:[ + (car values) (cadr values) (cddr values) ;; ~A=~A~{&~A=~A~} + (and values booleans) ;; ~:[~;&~] + booleans ;; ~:[ + (car booleans) (cddr booleans) ;; ~A~{&~A~*~} + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Use xedit protocol to create a XawTextPropertyList with the +;; given arguments. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-syntax-property-list (name properties + &aux string-properties quark) + + ;; Create a string representation of the properties. + (dolist (property properties) + (setq + string-properties + (append + string-properties + (list (synprop-to-string property)) + ) + ) + ) + + (setq + string-properties + (case (length string-properties) + (0 "") + (1 (car string-properties)) + (t (format nil "~A~{,~A~}" + (car string-properties) + (cdr string-properties) + ) + ) + ) + ) + +#+debug + (format *output* "~Cconvert-property-list ~S ~S~%" + *escape* + name + string-properties + ) + (setq quark #-debug (convert-property-list name string-properties) + #+debug 0) + + ;; Store the quark for properties not yet "initialized". + ;; XXX This is just a call to Xrm{Perm,}StringToQuark, and should + ;; be made available if there were a wrapper/interface to + ;; that Xlib function. + (dolist (property properties) + (unless (integerp (synprop-quark property)) +#+debug + (format *output* "~Cxrm-string-to-quark ~S~%" + *escape* + (synprop-name property) + ) + (setf + (synprop-quark property) +#-debug (xrm-string-to-quark (synprop-name property)) +#+debug 0 + ) + ) + ) + + quark +) + + + + +#+debug +(progn + (defconstant *escape* #\$) + + (defconstant *output* *standard-output*) + + ;; Recognized identifiers for wrap mode. + (defconstant *wrap-modes* '(:never :line :word)) + + ;; Recognized identifiers for justification. + (defconstant *justifications* '(:left :right :center :full)) + + ;; XawTextScanType + (defconstant *scan-type* + '(:positions :white-space :eol :paragraph :all :alpha-numeric)) + + ;; XawTextScanDirection + (defconstant *scan-direction* '(:left :right)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Debugging version of xedit functions. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defun clear-entities (left right) + (format *output* "~Cclear-entities ~D ~D~%" + *escape* left right)) + + (defun add-entity (offset length identifier) + (format *output* "~Cadd-entity ~D ~D ~D~%" + *escape* offset length identifier)) + + (defun background (&optional (value nil specified)) + (if specified + (format *output* "~Cset-background ~S~%" *escape* value) + (format *output* "~Cget-background~%" *escape*))) + + (defun foreground (&optional (value nil specified)) + (if specified + (format *output* "~Cset-foreground ~S~%" *escape* value) + (format *output* "~Cget-foreground~%" *escape*))) + + (defun font (&optional (value nil specified)) + (if specified + (format *output* "~Cset-font ~S~%" *escape* value) + (format *output* "~Cget-font~%" *escape*))) + + (defun point (&optional (value nil specified)) + (if specified + (format *output* "~Cset-point ~D~%" *escape* value) + (format *output* "~Cget-point~%" *escape*))) + + (defun point-min () + (format *output* "~Cpoint-min~%" *escape*)) + + (defun point-max () + (format *output* "~Cpoint-max~%" *escape*)) + + (defun property-list (&optional (quark nil specified)) + (format *output* "~property-list ~D~%" *escape* quark)) + + (defun insert (string) + (format *output* "~Cinsert ~S~%" *escape* string)) + + (defun read-text (offset length) + (format *output* "~Cread-text ~D ~D~%" + *escape* offset length)) + + (defun replace-text (left right string) + (format *output* "~Creplace-text ~D ~D ~S~%" + *escape* left right string)) + + (defun scan (offset type direction &key (count 1) include) + (unless (setq type (position type *scan-type*)) + (error "SCAN: type must be one of ~A, not ~A" + *scan-type* type)) + (unless (setq direction (position direction *scan-direction*)) + (error "SCAN: direction must be one of ~A, not ~A" + *scan-direction* direction)) + (format *output* "~Cscan ~D ~D ~D ~D ~D~%" + *escape* offset type direction count (if include 1 0))) + + (defun search-forward (string &optional case-sensitive) + (format *output* "~Csearch-forward ~S ~D~%" + *escape* string (if case-sensitive 1 0))) + + (defun search-backward (string &optional case-sensitive) + (format *output* "~Csearch-backward ~S ~D~%" + *escape* string (if case-sensitive 1 0))) + + (defun wrap-mode (&optional (value nil specified)) + (if specified + (progn + (unless (member value *wrap-modes*) + (error "WRAP-MODE: argument must be one of ~A, not ~A" + *wrap-modes* value)) + (format *output* "~Cset-wrap-mode ~S~%" + *escape* (string value))) + (format *output* "~Cget-wrap-mode~%" *escape*))) + + (defun auto-fill (&optional (value nil specified)) + (if specified + (format *output* "~Cset-auto-fill ~S~%" + *escape* (if value "true" "false")) + (format *output* "~Cget-auto-fill~%" *escape*))) + + (defun justification (&optional (value nil specified)) + (if specified + (progn + (unless (member value *justifications*) + (error "JUSTIFICATION: argument must be one of ~A, not ~A" + *justifications* value)) + (format *output* "~Cset-justification ~S~%" + *escape* (string value))) + (format *output* "~Cget-justification~%" *escape*))) + + (defun left-column (&optional (value nil specified)) + (if specified + (format *output* "~Cset-left-column ~D~%" *escape* value) + (format *output* "~Cget-left-column~%" *escape*))) + + (defun right-column (&optional (value nil specified)) + (if specified + (format *output* "~Cset-right-column ~D~%" *escape* value) + (format *output* "~Cget-right-column~%" *escape*))) + + (defun vertical-scrollbar (&optional (value nil specified)) + (if specified + (format *output* "~Cset-vert-scrollbar ~S~%" + *escape* (if value "always" "never")) + (format *output* "~Cget-vert-scrollbar~%" *escape*))) + + (defun horizontal-scrollbar (&optional (value nil specified)) + (if specified + (format *output* "~Cset-horiz-scrollbar ~S~%" + *escape* (if value "always" "never")) + (format *output* "~Cget-horiz-scrollbar~%" *escape*))) + + #||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + (defun create-buffer (name) + (format *output* "~Ccreate-buffer ~S~%" *escape* name)) + + (defun remove-buffer (name) + (format *output* "~Cremove-buffer ~S~%" *escape* name)) + + (defun buffer-name (&optional (value nil specified)) + (if specified + (format *output* "~Cset-buffer-name ~S~%" *escape* value) + (format *output* "~Cget-buffer-name~%" *escape*))) + + (defun buffer-filename (&optional (value nil specified)) + (if specified + (format *output* "~Cset-buffer-filename ~S~%" + *escape* (namestring value)) + (format *output* "~Cget-buffer-filename~%" *escape*))) + + (defun current-buffer (&optional (value nil specified)) + (if specified + (format *output* "~Cset-current-buffer ~S~%" *escape* value) + (format *output* "~Cget-current-buffer~%" *escape*))) + + (defun other-buffer (&optional (value nil specified)) + (if specified + (format *output* "~Cset-other-buffer ~S~%" *escape* value) + (format *output* "~Cget-other-buffer~%" *escape*))) + |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||# +) diff --git a/lisp/modules/xt.c b/lisp/modules/xt.c new file mode 100644 index 0000000..13c7ae7 --- /dev/null +++ b/lisp/modules/xt.c @@ -0,0 +1,1797 @@ +/* + * 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/modules/xt.c,v 1.19 2002/11/23 08:26:52 paulo Exp $ */ + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include <X11/Intrinsic.h> +#include <X11/StringDefs.h> +#include <X11/Shell.h> +#include "internal.h" +#include "private.h" + +/* + * Types + */ +typedef struct { + XrmQuark qname; + XrmQuark qtype; + Cardinal size; +} ResourceInfo; + +typedef struct { + WidgetClass widget_class; + ResourceInfo **resources; + Cardinal num_resources; + Cardinal num_cons_resources; +} ResourceList; + +typedef struct { + Arg *args; + Cardinal num_args; +} Resources; + +typedef struct { + LispObj *data; + /* data is => (list* widget callback argument) */ +} CallbackArgs; + +/* + * Prototypes + */ +int xtLoadModule(LispMac*); +void LispXtCleanupCallback(Widget, XtPointer, XtPointer); + +void LispXtCallback(Widget, XtPointer, XtPointer); +void LispXtInputCallback(XtPointer, int*, XtInputId*); + +/* a hack... */ +LispObj *Lisp_XtCoerceToWidgetList(LispBuiltin*); + +LispObj *Lisp_XtAddCallback(LispBuiltin*); +LispObj *Lisp_XtAppInitialize(LispBuiltin*); +LispObj *Lisp_XtAppMainLoop(LispBuiltin*); +LispObj *Lisp_XtAppAddInput(LispBuiltin*); +LispObj *Lisp_XtAppPending(LispBuiltin*); +LispObj *Lisp_XtAppProcessEvent(LispBuiltin*); +LispObj *Lisp_XtCreateWidget(LispBuiltin*); +LispObj *Lisp_XtCreateManagedWidget(LispBuiltin*); +LispObj *Lisp_XtCreatePopupShell(LispBuiltin*); +LispObj *Lisp_XtDestroyWidget(LispBuiltin*); +LispObj *Lisp_XtGetKeyboardFocusWidget(LispBuiltin*); +LispObj *Lisp_XtGetValues(LispBuiltin*); +LispObj *Lisp_XtManageChild(LispBuiltin*); +LispObj *Lisp_XtUnmanageChild(LispBuiltin*); +LispObj *Lisp_XtSetMappedWhenManaged(LispBuiltin*); +LispObj *Lisp_XtMapWidget(LispBuiltin*); +LispObj *Lisp_XtName(LispBuiltin*); +LispObj *Lisp_XtParent(LispBuiltin*); +LispObj *Lisp_XtUnmapWidget(LispBuiltin*); +LispObj *Lisp_XtPopup(LispBuiltin*); +LispObj *Lisp_XtPopdown(LispBuiltin*); +LispObj *Lisp_XtIsRealized(LispBuiltin*); +LispObj *Lisp_XtRealizeWidget(LispBuiltin*); +LispObj *Lisp_XtUnrealizeWidget(LispBuiltin*); +LispObj *Lisp_XtRemoveInput(LispBuiltin*); +LispObj *Lisp_XtSetSensitive(LispBuiltin*); +LispObj *Lisp_XtSetValues(LispBuiltin*); +LispObj *Lisp_XtWidgetToApplicationContext(LispBuiltin*); +LispObj *Lisp_XtDisplay(LispBuiltin*); +LispObj *Lisp_XtDisplayOfObject(LispBuiltin*); +LispObj *Lisp_XtScreen(LispBuiltin*); +LispObj *Lisp_XtScreenOfObject(LispBuiltin*); +LispObj *Lisp_XtSetKeyboardFocus(LispBuiltin*); +LispObj *Lisp_XtWindow(LispBuiltin*); +LispObj *Lisp_XtWindowOfObject(LispBuiltin*); +LispObj *Lisp_XtAddGrab(LispBuiltin*); +LispObj *Lisp_XtRemoveGrab(LispBuiltin*); +LispObj *Lisp_XtAppGetExitFlag(LispBuiltin*); +LispObj *Lisp_XtAppSetExitFlag(LispBuiltin*); + +LispObj *LispXtCreateWidget(LispBuiltin*, int); + +static Resources *LispConvertResources(LispObj*, Widget, + ResourceList*, ResourceList*); +static void LispFreeResources(Resources*); + +static int bcmp_action_resource(_Xconst void*, _Xconst void*); +static ResourceInfo *GetResourceInfo(char*, ResourceList*, ResourceList*); +static ResourceList *GetResourceList(WidgetClass); +static int bcmp_action_resource_list(_Xconst void*, _Xconst void*); +static ResourceList *FindResourceList(WidgetClass); +static int qcmp_action_resource_list(_Xconst void*, _Xconst void*); +static ResourceList *CreateResourceList(WidgetClass); +static int qcmp_action_resource(_Xconst void*, _Xconst void*); +static void BindResourceList(ResourceList*); + +static void PopdownAction(Widget, XEvent*, String*, Cardinal*); +static void QuitAction(Widget, XEvent*, String*, Cardinal*); + +/* + * Initialization + */ +static LispBuiltin lispbuiltins[] = { + {LispFunction, Lisp_XtCoerceToWidgetList, "xt-coerce-to-widget-list number opaque"}, + + {LispFunction, Lisp_XtAddGrab, "xt-add-grab widget exclusive spring-loaded"}, + {LispFunction, Lisp_XtAddCallback, "xt-add-callback widget callback-name callback &optional client-data"}, + {LispFunction, Lisp_XtAppAddInput, "xt-app-add-input app-context fileno condition function &optional client-data"}, + {LispFunction, Lisp_XtAppInitialize, "xt-app-initialize app-context-return application-class &optional options fallback-resources"}, + {LispFunction, Lisp_XtAppPending, "xt-app-pending app-context"}, + {LispFunction, Lisp_XtAppMainLoop, "xt-app-main-loop app-context"}, + {LispFunction, Lisp_XtAppProcessEvent, "xt-app-process-event app-context &optional mask"}, + {LispFunction, Lisp_XtAppGetExitFlag, "xt-app-get-exit-flag app-context"}, + {LispFunction, Lisp_XtAppSetExitFlag, "xt-app-set-exit-flag app-context"}, + {LispFunction, Lisp_XtCreateManagedWidget, "xt-create-managed-widget name widget-class parent &optional arguments"}, + {LispFunction, Lisp_XtCreateWidget, "xt-create-widget name widget-class parent &optional arguments"}, + {LispFunction, Lisp_XtCreatePopupShell, "xt-create-popup-shell name widget-class parent &optional arguments"}, + {LispFunction, Lisp_XtDestroyWidget, "xt-destroy-widget widget"}, + {LispFunction, Lisp_XtGetKeyboardFocusWidget, "xt-get-keyboard-focus-widget widget"}, + {LispFunction, Lisp_XtGetValues, "xt-get-values widget arguments"}, + {LispFunction, Lisp_XtManageChild, "xt-manage-child widget"}, + {LispFunction, Lisp_XtName, "xt-name widget"}, + {LispFunction, Lisp_XtUnmanageChild, "xt-unmanage-child widget"}, + {LispFunction, Lisp_XtMapWidget, "xt-map-widget widget"}, + {LispFunction, Lisp_XtUnmapWidget, "xt-unmap-widget widget"}, + {LispFunction, Lisp_XtSetMappedWhenManaged, "xt-set-mapped-when-managed widget map-when-managed"}, + {LispFunction, Lisp_XtParent, "xt-parent widget"}, + {LispFunction, Lisp_XtPopup, "xt-popup widget grab-kind"}, + {LispFunction, Lisp_XtPopdown, "xt-popdown widget"}, + {LispFunction, Lisp_XtIsRealized, "xt-is-realized widget"}, + {LispFunction, Lisp_XtRealizeWidget, "xt-realize-widget widget"}, + {LispFunction, Lisp_XtUnrealizeWidget, "xt-unrealize-widget widget"}, + {LispFunction, Lisp_XtRemoveInput, "xt-remove-input input"}, + {LispFunction, Lisp_XtRemoveGrab, "xt-remove-grab widget"}, + {LispFunction, Lisp_XtSetKeyboardFocus, "xt-set-keyboard-focus widget descendant"}, + {LispFunction, Lisp_XtSetSensitive, "xt-set-sensitive widget sensitive"}, + {LispFunction, Lisp_XtSetValues, "xt-set-values widget arguments"}, + {LispFunction, Lisp_XtWidgetToApplicationContext, "xt-widget-to-application-context widget"}, + {LispFunction, Lisp_XtDisplay, "xt-display widget"}, + {LispFunction, Lisp_XtDisplayOfObject, "xt-display-of-object object"}, + {LispFunction, Lisp_XtScreen, "xt-screen widget"}, + {LispFunction, Lisp_XtScreenOfObject, "xt-screen-of-object object"}, + {LispFunction, Lisp_XtWindow, "xt-window widget"}, + {LispFunction, Lisp_XtWindowOfObject, "xt-window-of-object object"}, +}; + +LispModuleData xtLispModuleData = { + LISP_MODULE_VERSION, + xtLoadModule, +}; + +static ResourceList **resource_list; +static Cardinal num_resource_list; + +static Atom delete_window; +static int xtAppContext_t, xtWidget_t, xtWidgetClass_t, xtWidgetList_t, + xtInputId_t, xtDisplay_t, xtScreen_t, xtWindow_t; + +static XtActionsRec actions[] = { + {"xt-popdown", PopdownAction}, + {"xt-quit", QuitAction}, +}; + +static XrmQuark qCardinal, qInt, qString, qWidget, qFloat; + +static CallbackArgs **input_list; +static Cardinal num_input_list, size_input_list; + +/* + * Implementation + */ +int +xtLoadModule(void) +{ + int i; + char *fname = "XT-LOAD-MODULE"; + + xtAppContext_t = LispRegisterOpaqueType("XtAppContext"); + xtWidget_t = LispRegisterOpaqueType("Widget"); + xtWidgetClass_t = LispRegisterOpaqueType("WidgetClass"); + xtWidgetList_t = LispRegisterOpaqueType("WidgetList"); + xtInputId_t = LispRegisterOpaqueType("XtInputId"); + xtDisplay_t = LispRegisterOpaqueType("Display*"); + xtScreen_t = LispRegisterOpaqueType("Screen*"); + xtWindow_t = LispRegisterOpaqueType("Window"); + + LispExecute("(DEFSTRUCT XT-WIDGET-LIST NUM-CHILDREN CHILDREN)\n"); + + GCDisable(); + (void)LispSetVariable(ATOM2("CORE-WIDGET-CLASS"), + OPAQUE(coreWidgetClass, xtWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("COMPOSITE-WIDGET-CLASS"), + OPAQUE(compositeWidgetClass, xtWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("CONSTRAINT-WIDGET-CLASS"), + OPAQUE(constraintWidgetClass, xtWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TRANSIENT-SHELL-WIDGET-CLASS"), + OPAQUE(transientShellWidgetClass, xtWidgetClass_t), + fname, 0); + + /* parameters for XtPopup */ + (void)LispSetVariable(ATOM2("XT-GRAB-EXCLUSIVE"), + INTEGER(XtGrabExclusive), fname, 0); + (void)LispSetVariable(ATOM2("XT-GRAB-NONE"), + INTEGER(XtGrabNone), fname, 0); + (void)LispSetVariable(ATOM2("XT-GRAB-NONE-EXCLUSIVE"), + INTEGER(XtGrabNonexclusive), fname, 0); + + /* parameters for XtAppProcessEvent */ + (void)LispSetVariable(ATOM2("XT-IM-XEVENT"), + INTEGER(XtIMXEvent), fname, 0); + (void)LispSetVariable(ATOM2("XT-IM-TIMER"), + INTEGER(XtIMTimer), fname, 0); + (void)LispSetVariable(ATOM2("XT-IM-ALTERNATE-INPUT"), + INTEGER(XtIMAlternateInput), fname, 0); + (void)LispSetVariable(ATOM2("XT-IM-SIGNAL"), + INTEGER(XtIMSignal), fname, 0); + (void)LispSetVariable(ATOM2("XT-IM-ALL"), + INTEGER(XtIMAll), fname, 0); + + /* parameters for XtAppAddInput */ + (void)LispSetVariable(ATOM2("XT-INPUT-READ-MASK"), + INTEGER(XtInputReadMask), fname, 0); + (void)LispSetVariable(ATOM2("XT-INPUT-WRITE-MASK"), + INTEGER(XtInputWriteMask), fname, 0); + (void)LispSetVariable(ATOM2("XT-INPUT-EXCEPT-MASK"), + INTEGER(XtInputExceptMask), fname, 0); + GCEnable(); + + qCardinal = XrmPermStringToQuark(XtRCardinal); + qInt = XrmPermStringToQuark(XtRInt); + qString = XrmPermStringToQuark(XtRString); + qWidget = XrmPermStringToQuark(XtRWidget); + qFloat = XrmPermStringToQuark(XtRFloat); + + for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++) + LispAddBuiltinFunction(&lispbuiltins[i]); + + return (1); +} + +void +LispXtCallback(Widget w, XtPointer user_data, XtPointer call_data) +{ + CallbackArgs *args = (CallbackArgs*)user_data; + LispObj *code, *ocod = COD; + + GCDisable(); + /* callback name */ /* reall caller */ + code = CONS(CDR(CDR(args->data)), CONS(OPAQUE(w, xtWidget_t), + CONS(CAR(CDR(args->data)), CONS(OPAQUE(call_data, 0), NIL)))); + /* user arguments */ + COD = CONS(code, COD); + GCEnable(); + + (void)EVAL(code); + COD = ocod; +} + + +void +LispXtCleanupCallback(Widget w, XtPointer user_data, XtPointer call_data) +{ + CallbackArgs *args = (CallbackArgs*)user_data; + + UPROTECT(CAR(args->data), args->data); + XtFree((XtPointer)args); +} + +void +LispXtInputCallback(XtPointer closure, int *source, XtInputId *id) +{ + CallbackArgs *args = (CallbackArgs*)closure; + LispObj *code, *ocod = COD; + + GCDisable(); + /* callback name */ /* user arguments */ + code = CONS(CDR(CDR(args->data)), CONS(CAR(CDR(args->data)), + CONS(INTEGER(*source), CONS(CAR(args->data), NIL)))); + /* input source */ /* input id */ + COD = CONS(code, COD); + GCEnable(); + + (void)EVAL(code); + COD = ocod; +} + +LispObj * +Lisp_XtCoerceToWidgetList(LispBuiltin *builtin) +/* + xt-coerce-to-widget-list number opaque + */ +{ + int i; + WidgetList children; + Cardinal num_children; + LispObj *cons, *widget_list, *result; + + LispObj *onumber, *opaque; + + opaque = ARGUMENT(1); + onumber = ARGUMENT(0); + + CHECK_INDEX(onumber); + num_children = FIXNUM_VALUE(onumber); + + if (!CHECKO(opaque, xtWidgetList_t)) + LispDestroy("%s: cannot convert %s to WidgetList", + STRFUN(builtin), STROBJ(opaque)); + children = (WidgetList)(opaque->data.opaque.data); + + GCDisable(); + widget_list = cons = NIL; + for (i = 0; i < num_children; i++) { + result = CONS(OPAQUE(children[i], xtWidget_t), NIL); + if (widget_list == NIL) + widget_list = cons = result; + else { + RPLACD(cons, result); + cons = CDR(cons); + } + } + + result = APPLY(ATOM("MAKE-XT-WIDGET-LIST"), + CONS(KEYWORD("NUM-CHILDREN"), + CONS(INTEGER(num_children), + CONS(KEYWORD("CHILDREN"), + CONS(widget_list, NIL))))); + GCEnable(); + + return (result); +} + +LispObj * +Lisp_XtAddCallback(LispBuiltin *builtin) +/* + xt-add-callback widget callback-name callback &optional client-data + */ +{ + CallbackArgs *arguments; + LispObj *data; + + LispObj *widget, *callback_name, *callback, *client_data; + + client_data = ARGUMENT(3); + callback = ARGUMENT(2); + callback_name = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + CHECK_STRING(callback_name); + if (!SYMBOLP(callback) && callback->type != LispLambda_t) + LispDestroy("%s: %s cannot be used as a callback", + STRFUN(builtin), STROBJ(callback)); + + if (client_data == UNSPEC) + client_data = NIL; + + data = CONS(widget, CONS(client_data, callback)); + PROTECT(widget, data); + + arguments = XtNew(CallbackArgs); + arguments->data = data; + + XtAddCallback((Widget)(widget->data.opaque.data), THESTR(callback_name), + LispXtCallback, (XtPointer)arguments); + XtAddCallback((Widget)(widget->data.opaque.data), XtNdestroyCallback, + LispXtCleanupCallback, (XtPointer)arguments); + + return (client_data); +} + +LispObj * +Lisp_XtAppAddInput(LispBuiltin *builtin) +/* + xt-app-add-input app-context fileno condition function &optional client-data + */ +{ + LispObj *data, *input; + XtAppContext appcon; + int source, condition; + CallbackArgs *arguments; + XtInputId id; + + LispObj *app_context, *fileno, *ocondition, *function, *client_data; + + client_data = ARGUMENT(4); + function = ARGUMENT(3); + ocondition = ARGUMENT(2); + fileno = ARGUMENT(1); + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + appcon = (XtAppContext)(app_context->data.opaque.data); + + CHECK_LONGINT(fileno); + source = LONGINT_VALUE(fileno); + + CHECK_FIXNUM(ocondition); + condition = FIXNUM_VALUE(ocondition); + + if (!SYMBOLP(function) && function->type != LispLambda_t) + LispDestroy("%s: %s cannot be used as a callback", + STRFUN(builtin), STROBJ(function)); + + /* client data optional */ + if (client_data == UNSPEC) + client_data = NIL; + + data = CONS(NIL, CONS(client_data, function)); + + arguments = XtNew(CallbackArgs); + arguments->data = data; + + id = XtAppAddInput(appcon, source, (XtPointer)condition, + LispXtInputCallback, (XtPointer)arguments); + GCDisable(); + input = OPAQUE(id, xtInputId_t); + GCEnable(); + RPLACA(data, input); + PROTECT(input, data); + + if (num_input_list + 1 >= size_input_list) { + ++size_input_list; + input_list = (CallbackArgs**) + XtRealloc((XtPointer)input_list, + sizeof(CallbackArgs*) * size_input_list); + } + input_list[num_input_list++] = arguments; + + return (input); +} + +LispObj * +Lisp_XtRemoveInput(LispBuiltin *builtin) +/* + xt-remove-input input + */ +{ + int i; + XtInputId id; + CallbackArgs *args; + + LispObj *input; + + input = ARGUMENT(0); + + if (!CHECKO(input, xtInputId_t)) + LispDestroy("%s: cannot convert %s to XtInputId", + STRFUN(builtin), STROBJ(input)); + + id = (XtInputId)(input->data.opaque.data); + for (i = 0; i < num_input_list; i++) { + args = input_list[i]; + if (id == (XtInputId)(CAR(args->data)->data.opaque.data)) { + UPROTECT(CAR(args->data), args->data); + XtFree((XtPointer)args); + + if (i + 1 < num_input_list) + memmove(input_list + i, input_list + i + 1, + sizeof(CallbackArgs*) * (num_input_list - i - 1)); + --num_input_list; + + XtRemoveInput(id); + + return (T); + } + } + + return (NIL); +} + +LispObj * +Lisp_XtAppInitialize(LispBuiltin *builtin) +/* + xt-app-initialize app-context-return application-class &optional options fallback-resources + */ +{ + XtAppContext appcon; + Widget shell; + int zero = 0; + Resources *resources = NULL; + String *fallback = NULL; + + LispObj *app_context_return, *application_class, + *options, *fallback_resources; + + fallback_resources = ARGUMENT(3); + options = ARGUMENT(2); + application_class = ARGUMENT(1); + app_context_return = ARGUMENT(0); + + CHECK_SYMBOL(app_context_return); + CHECK_STRING(application_class); + CHECK_LIST(options); + + /* check fallback resources, if given */ + if (fallback_resources != UNSPEC) { + LispObj *string; + int count; + + CHECK_CONS(fallback_resources); + for (string = fallback_resources, count = 0; CONS_P(string); + string = CDR(string), count++) + CHECK_STRING(CAR(string)); + + /* fallback resources was correctly specified */ + fallback = LispMalloc(sizeof(String) * (count + 1)); + for (string = fallback_resources, count = 0; CONS_P(string); + string = CDR(string), count++) + fallback[count] = THESTR(CAR(string)); + fallback[count] = NULL; + } + + shell = XtAppInitialize(&appcon, THESTR(application_class), NULL, + 0, &zero, NULL, fallback, NULL, 0); + if (fallback) + LispFree(fallback); + (void)LispSetVariable(app_context_return, + OPAQUE(appcon, xtAppContext_t), + STRFUN(builtin), 0); + + XtAppAddActions(appcon, actions, XtNumber(actions)); + + if (options != UNSPEC) { + resources = LispConvertResources(options, shell, + GetResourceList(XtClass(shell)), + NULL); + if (resources) { + XtSetValues(shell, resources->args, resources->num_args); + LispFreeResources(resources); + } + } + + return (OPAQUE(shell, xtWidget_t)); +} + +LispObj * +Lisp_XtAppMainLoop(LispBuiltin *builtin) +/* + xt-app-main-loop app-context + */ +{ + LispObj *app_context; + + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + XtAppMainLoop((XtAppContext)(app_context->data.opaque.data)); + + return (NIL); +} + +LispObj * +Lisp_XtAppPending(LispBuiltin *builtin) +/* + xt-app-pending app-context + */ +{ + LispObj *app_context; + + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + return (INTEGER( + XtAppPending((XtAppContext)(app_context->data.opaque.data)))); +} + +LispObj * +Lisp_XtAppProcessEvent(LispBuiltin *builtin) +/* + xt-app-process-event app-context &optional mask + */ +{ + XtInputMask mask; + XtAppContext appcon; + + LispObj *app_context, *omask; + + omask = ARGUMENT(1); + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + appcon = (XtAppContext)(app_context->data.opaque.data); + if (omask == UNSPEC) + mask = XtIMAll; + else { + CHECK_FIXNUM(omask); + mask = FIXNUM_VALUE(omask); + } + + if (mask != (mask & XtIMAll)) + LispDestroy("%s: %d does not fit in XtInputMask %d", + STRFUN(builtin), mask); + + if (mask) + XtAppProcessEvent(appcon, mask); + + return (omask == NIL ? FIXNUM(mask) : omask); +} + +LispObj * +Lisp_XtRealizeWidget(LispBuiltin *builtin) +/* + xt-realize-widget widget + */ +{ + Widget widget; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + XtRealizeWidget(widget); + + if (XtIsSubclass(widget, shellWidgetClass)) { + if (!delete_window) + delete_window = XInternAtom(XtDisplay(widget), + "WM_DELETE_WINDOW", False); + (void)XSetWMProtocols(XtDisplay(widget), XtWindow(widget), + &delete_window, 1); + } + + return (owidget); +} + +LispObj * +Lisp_XtUnrealizeWidget(LispBuiltin *builtin) +/* + xt-unrealize-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + XtUnrealizeWidget((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtIsRealized(LispBuiltin *builtin) +/* + xt-is-realized widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + return (XtIsRealized((Widget)(widget->data.opaque.data)) ? T : NIL); +} + +LispObj * +Lisp_XtDestroyWidget(LispBuiltin *builtin) +/* + xt-destroy-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + XtDestroyWidget((Widget)(widget->data.opaque.data)); + + return (NIL); +} + +#define UNMANAGED 0 +#define MANAGED 1 +#define SHELL 2 +LispObj * +Lisp_XtCreateWidget(LispBuiltin *builtin) +/* + xt-create-widget name widget-class parent &optional arguments + */ +{ + return (LispXtCreateWidget(builtin, UNMANAGED)); +} + +LispObj * +Lisp_XtCreateManagedWidget(LispBuiltin *builtin) +/* + xt-create-managed-widget name widget-class parent &optional arguments + */ +{ + return (LispXtCreateWidget(builtin, MANAGED)); +} + +LispObj * +Lisp_XtCreatePopupShell(LispBuiltin *builtin) +/* + xt-create-popup-shell name widget-class parent &optional arguments + */ +{ + return (LispXtCreateWidget(builtin, SHELL)); +} + +LispObj * +LispXtCreateWidget(LispBuiltin *builtin, int options) +/* + xt-create-widget name widget-class parent &optional arguments + xt-create-managed-widget name widget-class parent &optional arguments + xt-create-popup-shell name widget-class parent &optional arguments + */ +{ + char *name; + WidgetClass widget_class; + Widget widget, parent; + Resources *resources = NULL; + + LispObj *oname, *owidget_class, *oparent, *arguments; + + arguments = ARGUMENT(3); + oparent = ARGUMENT(2); + owidget_class = ARGUMENT(1); + oname = ARGUMENT(0); + + CHECK_STRING(oname); + name = THESTR(oname); + + if (!CHECKO(owidget_class, xtWidgetClass_t)) + LispDestroy("%s: cannot convert %s to WidgetClass", + STRFUN(builtin), STROBJ(owidget_class)); + widget_class = (WidgetClass)(owidget_class->data.opaque.data); + + if (!CHECKO(oparent, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(oparent)); + parent = (Widget)(oparent->data.opaque.data); + + CHECK_LIST(arguments); + + if (options == SHELL) + widget = XtCreatePopupShell(name, widget_class, parent, NULL, 0); + else + widget = XtCreateWidget(name, widget_class, parent, NULL, 0); + + if (arguments == UNSPEC || arguments == NIL) + resources = NULL; + else { + resources = LispConvertResources(arguments, widget, + GetResourceList(widget_class), + GetResourceList(XtClass(parent))); + XtSetValues(widget, resources->args, resources->num_args); + } + if (options == MANAGED) + XtManageChild(widget); + if (resources) + LispFreeResources(resources); + + return (OPAQUE(widget, xtWidget_t)); +} + +LispObj * +Lisp_XtGetKeyboardFocusWidget(LispBuiltin *builtin) +/* + xt-get-keyboard-focus-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + return (OPAQUE(XtGetKeyboardFocusWidget((Widget)(widget->data.opaque.data)), + xtWidget_t)); +} + +LispObj * +Lisp_XtGetValues(LispBuiltin *builtin) +/* + xt-get-values widget arguments + */ +{ + Arg args[1]; + Widget widget; + ResourceList *rlist, *plist; + ResourceInfo *resource; + LispObj *list, *object = NIL, *result, *cons = NIL; + char c1; + short c2; + int c4; +#ifdef LONG64 + long c8; +#endif + + LispObj *owidget, *arguments; + + arguments = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (arguments == NIL) + return (NIL); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + CHECK_CONS(arguments); + + rlist = GetResourceList(XtClass(widget)); + plist = XtParent(widget) ? + GetResourceList(XtClass(XtParent(widget))) : NULL; + + GCDisable(); + result = NIL; + for (list = arguments; CONS_P(list); list = CDR(list)) { + CHECK_STRING(CAR(list)); + if ((resource = GetResourceInfo(THESTR(CAR(list)), rlist, plist)) + == NULL) { + int i; + Widget child; + + for (i = 0; i < rlist->num_resources; i++) { + if (rlist->resources[i]->qtype == qWidget) { + XtSetArg(args[0], + XrmQuarkToString(rlist->resources[i]->qname), + &child); + XtGetValues(widget, args, 1); + if (child && XtParent(child) == widget) { + resource = + GetResourceInfo(THESTR(CAR(list)), + GetResourceList(XtClass(child)), + NULL); + if (resource) + break; + } + } + } + if (resource == NULL) { + LispMessage("%s: resource %s not available", + STRFUN(builtin), THESTR(CAR(list))); + continue; + } + } + switch (resource->size) { + case 1: + XtSetArg(args[0], THESTR(CAR(list)), &c1); + break; + case 2: + XtSetArg(args[0], THESTR(CAR(list)), &c2); + break; + case 4: + XtSetArg(args[0], THESTR(CAR(list)), &c4); + break; +#ifdef LONG64 + case 1: + XtSetArg(args[0], THESTR(CAR(list)), &c8); + break; +#endif + } + XtGetValues(widget, args, 1); + + /* special resources */ + if (resource->qtype == qString) { +#ifdef LONG64 + object = CONS(CAR(list), STRING(c8)); +#else + object = CONS(CAR(list), STRING(c4)); +#endif + } + else if (resource->qtype == qCardinal || resource->qtype == qInt) { +#ifdef LONG64 + if (sizeof(int) == 8) + object = CONS(CAR(list), INTEGER(c8)); + else +#endif + object = CONS(CAR(list), INTEGER(c4)); + } + else { + switch (resource->size) { + case 1: + object = CONS(CAR(list), OPAQUE(c1, 0)); + break; + case 2: + object = CONS(CAR(list), OPAQUE(c2, 0)); + break; + case 4: + object = CONS(CAR(list), OPAQUE(c4, 0)); + break; +#ifdef LONG64 + case 8: + object = CONS(CAR(list), OPAQUE(c8, 0)); + break; +#endif + } + } + + if (result == NIL) + result = cons = CONS(object, NIL); + else { + RPLACD(cons, CONS(object, NIL)); + cons = CDR(cons); + } + } + GCEnable(); + + return (result); +} + +LispObj * +Lisp_XtManageChild(LispBuiltin *builtin) +/* + xt-manage-child widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtManageChild((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtUnmanageChild(LispBuiltin *builtin) +/* + xt-unmanage-child widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtUnmanageChild((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtMapWidget(LispBuiltin *builtin) +/* + xt-map-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtMapWidget((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtUnmapWidget(LispBuiltin *builtin) +/* + xt-unmap-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtUnmapWidget((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtSetMappedWhenManaged(LispBuiltin *builtin) +/* + xt-set-mapped-when-managed widget map-when-managed + */ +{ + LispObj *widget, *map_when_managed; + + map_when_managed = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + XtSetMappedWhenManaged((Widget)(widget->data.opaque.data), + map_when_managed != NIL); + + return (map_when_managed); +} + +LispObj * +Lisp_XtPopup(LispBuiltin *builtin) +/* + xt-popup widget grab-kind + */ +{ + XtGrabKind kind; + + LispObj *widget, *grab_kind; + + grab_kind = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + CHECK_INDEX(grab_kind); + kind = (XtGrabKind)FIXNUM_VALUE(grab_kind); + if (kind != XtGrabExclusive && kind != XtGrabNone && + kind != XtGrabNonexclusive) + LispDestroy("%s: %d does not fit in XtGrabKind", + STRFUN(builtin), kind); + XtPopup((Widget)(widget->data.opaque.data), kind); + + return (grab_kind); +} + +LispObj * +Lisp_XtPopdown(LispBuiltin *builtin) +/* + xt-popdown widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtPopdown((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtSetKeyboardFocus(LispBuiltin *builtin) +/* + xt-set-keyboard-focus widget descendant + */ +{ + LispObj *widget, *descendant; + + descendant = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + if (!CHECKO(descendant, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(descendant)); + XtSetKeyboardFocus((Widget)(widget->data.opaque.data), + (Widget)(descendant->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtSetSensitive(LispBuiltin *builtin) +/* + xt-set-sensitive widget sensitive + */ +{ + LispObj *widget, *sensitive; + + sensitive = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtSetSensitive((Widget)(widget->data.opaque.data), sensitive != NIL); + + return (sensitive); +} + +LispObj * +Lisp_XtSetValues(LispBuiltin *builtin) +/* + xt-set-values widget arguments + */ +{ + Widget widget; + Resources *resources; + + LispObj *owidget, *arguments; + + arguments = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (arguments == NIL) + return (owidget); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + CHECK_CONS(arguments); + resources = LispConvertResources(arguments, widget, + GetResourceList(XtClass(widget)), + XtParent(widget) ? + GetResourceList(XtClass(XtParent(widget))) : + NULL); + XtSetValues(widget, resources->args, resources->num_args); + LispFreeResources(resources); + + return (owidget); +} + +LispObj * +Lisp_XtWidgetToApplicationContext(LispBuiltin *builtin) +/* + xt-widget-to-application-context widget + */ +{ + Widget widget; + XtAppContext appcon; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + appcon = XtWidgetToApplicationContext(widget); + + return (OPAQUE(appcon, xtAppContext_t)); +} + +LispObj * +Lisp_XtDisplay(LispBuiltin *builtin) +/* + xt-display widget + */ +{ + Widget widget; + Display *display; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + display = XtDisplay(widget); + + return (OPAQUE(display, xtDisplay_t)); +} + +LispObj * +Lisp_XtDisplayOfObject(LispBuiltin *builtin) +/* + xt-display-of-object object + */ +{ + Widget widget; + Display *display; + + LispObj *object; + + object = ARGUMENT(0); + + if (!CHECKO(object, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(object)); + widget = (Widget)(object->data.opaque.data); + display = XtDisplayOfObject(widget); + + return (OPAQUE(display, xtDisplay_t)); +} + +LispObj * +Lisp_XtScreen(LispBuiltin *builtin) +/* + xt-screen widget + */ +{ + Widget widget; + Screen *screen; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + screen = XtScreen(widget); + + return (OPAQUE(screen, xtScreen_t)); +} + +LispObj * +Lisp_XtScreenOfObject(LispBuiltin *builtin) +/* + xt-screen-of-object object + */ +{ + Widget widget; + Screen *screen; + + LispObj *object; + + object = ARGUMENT(0); + + if (!CHECKO(object, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(object)); + widget = (Widget)(object->data.opaque.data); + screen = XtScreenOfObject(widget); + + return (OPAQUE(screen, xtScreen_t)); +} + +LispObj * +Lisp_XtWindow(LispBuiltin *builtin) +/* + xt-window widget + */ +{ + Widget widget; + Window window; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + window = XtWindow(widget); + + return (OPAQUE(window, xtWindow_t)); +} + +LispObj * +Lisp_XtWindowOfObject(LispBuiltin *builtin) +/* + xt-window-of-object widget + */ +{ + Widget widget; + Window window; + + LispObj *object; + + object = ARGUMENT(0); + + if (!CHECKO(object, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(object)); + widget = (Widget)(object->data.opaque.data); + window = XtWindowOfObject(widget); + + return (OPAQUE(window, xtWindow_t)); +} + +LispObj * +Lisp_XtAddGrab(LispBuiltin *builtin) +/* + xt-add-grab widget exclusive spring-loaded + */ +{ + Widget widget; + Bool exclusive, spring_loaded; + + LispObj *owidget, *oexclusive, *ospring_loaded; + + ospring_loaded = ARGUMENT(2); + oexclusive = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + exclusive = oexclusive != NIL; + spring_loaded = ospring_loaded != NIL; + + XtAddGrab(widget, exclusive, spring_loaded); + + return (T); +} + +LispObj * +Lisp_XtRemoveGrab(LispBuiltin *builtin) +/* + xt-remove-grab widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + XtRemoveGrab((Widget)(widget->data.opaque.data)); + + return (NIL); +} + +LispObj * +Lisp_XtName(LispBuiltin *builtin) +/* + xt-name widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + return (STRING(XtName((Widget)(widget->data.opaque.data)))); +} + +LispObj * +Lisp_XtParent(LispBuiltin *builtin) +/* + xt-parent widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + return (OPAQUE(XtParent((Widget)widget->data.opaque.data), xtWidget_t)); +} + +LispObj * +Lisp_XtAppGetExitFlag(LispBuiltin *builtin) +/* + xt-app-get-exit-flag app-context + */ +{ + LispObj *app_context; + + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + return (XtAppGetExitFlag((XtAppContext)(app_context->data.opaque.data)) ? + T : NIL); +} + +LispObj * +Lisp_XtAppSetExitFlag(LispBuiltin *builtin) +/* + xt-app-get-exit-flag app-context + */ +{ + LispObj *app_context; + + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + XtAppSetExitFlag((XtAppContext)(app_context->data.opaque.data)); + + return (T); +} + +static Resources * +LispConvertResources(LispObj *list, Widget widget, + ResourceList *rlist, ResourceList *plist) +{ + char c1; + short c2; + int c4; +#ifdef LONG64 + long c8; +#endif + XrmValue from, to; + LispObj *arg, *val; + ResourceInfo *resource; + char *fname = "XT-CONVERT-RESOURCES"; + Resources *resources = (Resources*)XtCalloc(1, sizeof(Resources)); + + for (; CONSP(list); list = CDR(list)) { + if (!CONSP(CAR(list))) { + XtFree((XtPointer)resources); + LispDestroy("%s: %s is not a cons", fname, STROBJ(CAR(list))); + } + arg = CAR(CAR(list)); + val = CDR(CAR(list)); + + if (!STRINGP(arg)) { + XtFree((XtPointer)resources); + LispDestroy("%s: %s is not a string", fname, STROBJ(arg)); + } + + if ((resource = GetResourceInfo(THESTR(arg), rlist, plist)) == NULL) { + int i; + Arg args[1]; + Widget child; + + for (i = 0; i < rlist->num_resources; i++) { + if (rlist->resources[i]->qtype == qWidget) { + XtSetArg(args[0], + XrmQuarkToString(rlist->resources[i]->qname), + &child); + XtGetValues(widget, args, 1); + if (child && XtParent(child) == widget) { + resource = + GetResourceInfo(THESTR(arg), + GetResourceList(XtClass(child)), + NULL); + if (resource) + break; + } + } + } + if (resource == NULL) { + LispMessage("%s: resource %s not available", + fname, THESTR(arg)); + continue; + } + } + + if (LONGINTP(val) || DFLOATP(val) || OPAQUEP(val)) { + resources->args = (Arg*) + XtRealloc((XtPointer)resources->args, + sizeof(Arg) * (resources->num_args + 1)); + if (!OPAQUEP(val)) { + float fvalue; + + if (DFLOATP(val)) + fvalue = DFLOAT_VALUE(val); + else + fvalue = LONGINT_VALUE(val); + if (resource->qtype == qFloat) { + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), fvalue); + } + else + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), + (int)fvalue); + } + else + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), val->data.opaque.data); + ++resources->num_args; + continue; + } + else if (val == NIL) { + /* XXX assume it is a pointer or a boolean */ +#ifdef DEBUG + LispWarning("%s: assuming %s is a pointer or boolean", + fname, XrmQuarkToString(resource->qname)); +#endif + resources->args = (Arg*) + XtRealloc((XtPointer)resources->args, + sizeof(Arg) * (resources->num_args + 1)); + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), NULL); + ++resources->num_args; + continue; + } + else if (val == T) { + /* XXX assume it is a boolean */ +#ifdef DEBUG + LispWarning("%s: assuming %s is a boolean", + fname, XrmQuarkToString(resource->qname)); +#endif + resources->args = (Arg*) + XtRealloc((XtPointer)resources->args, + sizeof(Arg) * (resources->num_args + 1)); + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), True); + ++resources->num_args; + continue; + } + else if (!STRINGP(val)) { + XtFree((XtPointer)resources); + LispDestroy("%s: resource value must be string, number or opaque, not %s", + fname, STROBJ(val)); + } + + from.size = val == NIL ? 1 : strlen(THESTR(val)) + 1; + from.addr = val == NIL ? "" : THESTR(val); + switch (to.size = resource->size) { + case 1: + to.addr = (XtPointer)&c1; + break; + case 2: + to.addr = (XtPointer)&c2; + break; + case 4: + to.addr = (XtPointer)&c4; + break; +#ifdef LONG64 + case 8: + to.addr = (XtPointer)&c8; + break; +#endif + default: + LispWarning("%s: bad resource size %d for %s", + fname, to.size, THESTR(arg)); + continue; + } + + if (qString == resource->qtype) +#ifdef LONG64 + c8 = (long)from.addr; +#else + c4 = (long)from.addr; +#endif + else if (!XtConvertAndStore(widget, XtRString, &from, + XrmQuarkToString(resource->qtype), &to)) + /* The type converter already have printed an error message */ + continue; + + resources->args = (Arg*) + XtRealloc((XtPointer)resources->args, + sizeof(Arg) * (resources->num_args + 1)); + switch (to.size) { + case 1: + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), c1); + break; + case 2: + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), c2); + break; + case 4: + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), c4); + break; +#ifdef LONG64 + case 8: + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), c8); + break; +#endif + } + ++resources->num_args; + } + + return (resources); +} + +static void +LispFreeResources(Resources *resources) +{ + if (resources) { + XtFree((XtPointer)resources->args); + XtFree((XtPointer)resources); + } +} + +static int +bcmp_action_resource(_Xconst void *string, _Xconst void *resource) +{ + return (strcmp((String)string, + XrmQuarkToString((*(ResourceInfo**)resource)->qname))); +} + +static ResourceInfo * +GetResourceInfo(char *name, ResourceList *rlist, ResourceList *plist) +{ + ResourceInfo **resource = NULL; + + if (rlist->resources) + resource = (ResourceInfo**) + bsearch(name, rlist->resources, rlist->num_resources, + sizeof(ResourceInfo*), bcmp_action_resource); + + if (resource == NULL && plist) { + resource = (ResourceInfo**) + bsearch(name, &plist->resources[plist->num_resources], + plist->num_cons_resources, sizeof(ResourceInfo*), + bcmp_action_resource); + } + + return (resource ? *resource : NULL); +} + +static ResourceList * +GetResourceList(WidgetClass wc) +{ + ResourceList *list; + + if ((list = FindResourceList(wc)) == NULL) + list = CreateResourceList(wc); + + return (list); +} + +static int +bcmp_action_resource_list(_Xconst void *wc, _Xconst void *list) +{ + return ((char*)wc - (char*)((*(ResourceList**)list)->widget_class)); +} + +static ResourceList * +FindResourceList(WidgetClass wc) +{ + ResourceList **list; + + if (!resource_list) + return (NULL); + + list = (ResourceList**) + bsearch(wc, resource_list, num_resource_list, + sizeof(ResourceList*), bcmp_action_resource_list); + + return (list ? *list : NULL); +} + +static int +qcmp_action_resource_list(_Xconst void *left, _Xconst void *right) +{ + return ((char*)((*(ResourceList**)left)->widget_class) - + (char*)((*(ResourceList**)right)->widget_class)); +} + +static ResourceList * +CreateResourceList(WidgetClass wc) +{ + ResourceList *list; + + list = (ResourceList*)XtMalloc(sizeof(ResourceList)); + list->widget_class = wc; + list->num_resources = list->num_cons_resources = 0; + list->resources = NULL; + + resource_list = (ResourceList**) + XtRealloc((XtPointer)resource_list, sizeof(ResourceList*) * + (num_resource_list + 1)); + resource_list[num_resource_list++] = list; + qsort(resource_list, num_resource_list, sizeof(ResourceList*), + qcmp_action_resource_list); + BindResourceList(list); + + return (list); +} + +static int +qcmp_action_resource(_Xconst void *left, _Xconst void *right) +{ + return (strcmp(XrmQuarkToString((*(ResourceInfo**)left)->qname), + XrmQuarkToString((*(ResourceInfo**)right)->qname))); +} + +static void +BindResourceList(ResourceList *list) +{ + XtResourceList xt_list, cons_list; + Cardinal i, num_xt, num_cons; + + XtGetResourceList(list->widget_class, &xt_list, &num_xt); + XtGetConstraintResourceList(list->widget_class, &cons_list, &num_cons); + list->num_resources = num_xt; + list->num_cons_resources = num_cons; + + list->resources = (ResourceInfo**) + XtMalloc(sizeof(ResourceInfo*) * (num_xt + num_cons)); + + for (i = 0; i < num_xt; i++) { + list->resources[i] = (ResourceInfo*)XtMalloc(sizeof(ResourceInfo)); + list->resources[i]->qname = + XrmPermStringToQuark(xt_list[i].resource_name); + list->resources[i]->qtype = + XrmPermStringToQuark(xt_list[i].resource_type); + list->resources[i]->size = xt_list[i].resource_size; + } + + for (; i < num_xt + num_cons; i++) { + list->resources[i] = (ResourceInfo*)XtMalloc(sizeof(ResourceInfo)); + list->resources[i]->qname = + XrmPermStringToQuark(cons_list[i - num_xt].resource_name); + list->resources[i]->qtype = + XrmPermStringToQuark(cons_list[i - num_xt].resource_type); + list->resources[i]->size = cons_list[i - num_xt].resource_size; + } + + XtFree((XtPointer)xt_list); + if (cons_list) + XtFree((XtPointer)cons_list); + + qsort(list->resources, list->num_resources, sizeof(ResourceInfo*), + qcmp_action_resource); + if (num_cons) + qsort(&list->resources[num_xt], list->num_cons_resources, + sizeof(ResourceInfo*), qcmp_action_resource); +} + +/*ARGSUSED*/ +static void +PopdownAction(Widget w, XEvent *event, String *params, Cardinal *num_params) +{ + XtPopdown(w); +} + +/*ARGSUSED*/ +static void +QuitAction(Widget w, XEvent *event, String *params, Cardinal *num_params) +{ + XtAppSetExitFlag(XtWidgetToApplicationContext(w)); +} diff --git a/lisp/mp/mp.c b/lisp/mp/mp.c new file mode 100644 index 0000000..78b7a0e --- /dev/null +++ b/lisp/mp/mp.c @@ -0,0 +1,822 @@ +/* + * Copyright (c) 2002 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/mp/mp.c,v 1.3 2002/11/20 07:44:43 paulo Exp $ */ + +#include "mp.h" + +/* + * TODO: + * o Optimize squaring + * o Write better division code and move from mpi.c to here + * o Make multiplication code don't required memory to be zeroed + * + The first step is easy, just multiply the low word, + * then the high word, that may overlap with the result + * of the first multiply (in case of carry), and then + * just make sure carry is properly propagated in the + * subsequent multiplications. + * + Some code needs also to be rewritten because some + * intermediate addition code in mp_mul, mp_karatsuba_mul, + * and mp_toom_mul is assuming the memory is zeroed. + */ + +/* + * Prototypes + */ + /* out of memory handler */ +static void mp_outmem(void); + + /* memory allocation fallback functions */ +static void *_mp_malloc(size_t); +static void *_mp_calloc(size_t, size_t); +static void *_mp_realloc(void*, size_t); +static void _mp_free(void*); + +/* + * Initialization + */ +static mp_malloc_fun __mp_malloc = _mp_malloc; +static mp_calloc_fun __mp_calloc = _mp_calloc; +static mp_realloc_fun __mp_realloc = _mp_realloc; +static mp_free_fun __mp_free = _mp_free; + +/* + * Implementation + */ +static void +mp_outmem(void) +{ + fprintf(stderr, "out of memory in MP library.\n"); + exit(1); +} + +static void * +_mp_malloc(size_t size) +{ + return (malloc(size)); +} + +void * +mp_malloc(size_t size) +{ + void *pointer = (*__mp_malloc)(size); + + if (pointer == NULL) + mp_outmem(); + + return (pointer); +} + +mp_malloc_fun +mp_set_malloc(mp_malloc_fun fun) +{ + mp_malloc_fun old = __mp_malloc; + + __mp_malloc = fun; + + return (old); +} + +static void * +_mp_calloc(size_t nmemb, size_t size) +{ + return (calloc(nmemb, size)); +} + +void * +mp_calloc(size_t nmemb, size_t size) +{ + void *pointer = (*__mp_calloc)(nmemb, size); + + if (pointer == NULL) + mp_outmem(); + + return (pointer); +} + +mp_calloc_fun +mp_set_calloc(mp_calloc_fun fun) +{ + mp_calloc_fun old = __mp_calloc; + + __mp_calloc = fun; + + return (old); +} + +static void * +_mp_realloc(void *old, size_t size) +{ + return (realloc(old, size)); +} + +void * +mp_realloc(void *old, size_t size) +{ + void *pointer = (*__mp_realloc)(old, size); + + if (pointer == NULL) + mp_outmem(); + + return (pointer); +} + +mp_realloc_fun +mp_set_realloc(mp_realloc_fun fun) +{ + mp_realloc_fun old = __mp_realloc; + + __mp_realloc = fun; + + return (old); +} + +static void +_mp_free(void *pointer) +{ + free(pointer); +} + +void +mp_free(void *pointer) +{ + (*__mp_free)(pointer); +} + +mp_free_fun +mp_set_free(mp_free_fun fun) +{ + mp_free_fun old = __mp_free; + + __mp_free = fun; + + return (old); +} + +long +mp_add(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2) +{ + BNI value; /* intermediate result */ + BNS carry; /* carry flag */ + long size; /* result size */ + + if (len1 < len2) + MP_SWAP(op1, op2, len1, len2); + + /* unroll start of loop */ + value = op1[0] + op2[0]; + rop[0] = value; + carry = value >> BNSBITS; + + /* add op1 and op2 */ + for (size = 1; size < len2; size++) { + value = op1[size] + op2[size] + carry; + rop[size] = value; + carry = value >> BNSBITS; + } + if (rop != op1) { + for (; size < len1; size++) { + value = op1[size] + carry; + rop[size] = value; + carry = value >> BNSBITS; + } + } + else { + /* if rop == op1, than just adjust carry */ + for (; carry && size < len1; size++) { + value = op1[size] + carry; + rop[size] = value; + carry = value >> BNSBITS; + } + size = len1; + } + if (carry) + rop[size++] = carry; + + return (size); +} + +long +mp_sub(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2) +{ + long svalue; /* intermediate result */ + BNS carry; /* carry flag */ + long size; /* result size */ + + /* special case */ + if (op1 == op2) { + rop[0] = 0; + + return (1); + } + + /* unroll start of loop */ + svalue = op1[0] - op2[0]; + rop[0] = svalue; + carry = svalue < 0; + + /* subtracts op2 from op1 */ + for (size = 1; size < len2; size++) { + svalue = (long)(op1[size]) - op2[size] - carry; + rop[size] = svalue; + carry = svalue < 0; + } + if (rop != op1) { + for (; size < len1; size++) { + svalue = op1[size] - carry; + rop[size] = svalue; + carry = svalue < 0; + } + } + else { + /* if rop == op1, than just adjust carry */ + for (; carry && size < len1; size++) { + svalue = op1[size] - carry; + rop[size] = svalue; + carry = svalue < 0; + } + size = len1; + } + + /* calculate result size */ + while (size > 1 && rop[size - 1] == 0) + --size; + + return (size); +} + +long +mp_lshift(BNS *rop, BNS *op, BNI len, long shift) +{ + long i, size; + BNI words, bits; /* how many word and bit shifts */ + + words = shift / BNSBITS; + bits = shift % BNSBITS; + size = len + words; + + if (bits) { + BNS hi, lo; + BNI carry; + int adj; + + for (i = 1, carry = CARRY >> 1; carry; i++, carry >>= 1) + if (op[len - 1] & carry) + break; + adj = (bits + (BNSBITS - i)) / BNSBITS; + size += adj; + + lo = hi = op[0]; + rop[words] = lo << bits; + for (i = 1; i < len; i++) { + hi = op[i]; + rop[words + i] = hi << bits | (lo >> (BNSBITS - bits)); + lo = hi; + } + if (adj) + rop[size - 1] = hi >> (BNSBITS - bits); + } + else + memmove(rop + size - len, op, sizeof(BNS) * len); + + if (words) + memset(rop, '\0', sizeof(BNS) * words); + + return (size); +} + +long +mp_rshift(BNS *rop, BNS *op, BNI len, long shift) +{ + int adj = 0; + long i, size; + BNI words, bits; /* how many word and bit shifts */ + + words = shift / BNSBITS; + bits = shift % BNSBITS; + size = len - words; + + if (bits) { + BNS hi, lo; + BNI carry; + + for (i = 0, carry = CARRY >> 1; carry; i++, carry >>= 1) + if (op[len - 1] & carry) + break; + adj = (bits + i) / BNSBITS; + if (size - adj == 0) { + rop[0] = 0; + + return (1); + } + + hi = lo = op[words + size - 1]; + rop[size - 1] = hi >> bits; + for (i = size - 2; i >= 0; i--) { + lo = op[words + i]; + rop[i] = (lo >> bits) | (hi << (BNSBITS - bits)); + hi = lo; + } + if (adj) + rop[0] |= lo << (BNSBITS - bits); + } + else + memmove(rop, op + len - size, size * sizeof(BNS)); + + return (size - adj); +} + + /* rop must be a pointer to len1 + len2 elements + * rop cannot be either op1 or op2 + * rop must be all zeros */ +long +mp_base_mul(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2) +{ + long i, j; /* counters */ + BNI value; /* intermediate result */ + BNS carry; /* carry value */ + long size = len1 + len2; + + /* simple optimization: first pass does not need to deference rop[i+j] */ + if (op1[0]) { + value = (BNI)(op1[0]) * op2[0]; + rop[0] = value; + carry = (BNS)(value >> BNSBITS); + for (j = 1; j < len2; j++) { + value = (BNI)(op1[0]) * op2[j] + carry; + rop[j] = value; + carry = (BNS)(value >> BNSBITS); + } + rop[j] = carry; + } + + /* do the multiplication */ + for (i = 1; i < len1; i++) { + if (op1[i]) { + /* unrool loop initialization */ + value = (BNI)(op1[i]) * op2[0] + rop[i]; + rop[i] = value; + carry = (BNS)(value >> BNSBITS); + /* multiply */ + for (j = 1; j < len2; j++) { + value = (BNI)(op1[i]) * op2[j] + rop[i + j] + carry; + rop[i + j] = value; + carry = (BNS)(value >> BNSBITS); + } + rop[i + j] = carry; + } + } + + if (size > 1 && rop[size - 1] == 0) + --size; + + return (size); +} + + /* Karatsuba method + * t + ((a0 + a1) (b0 + b1) - t - u) x + ux² + * where t = a0b0 and u = a1b1 + * + * Karatsuba method reduces the number of multiplications. Example: + * Square a 40 length number + * instead of a plain 40*40 = 1600 multiplies/adds, it does: + * 20*20+20*20+20*20 = 1200 + * but since it is recursive, every 20*20=400 is reduced to + * 10*10+10*10+10*10=300 + * and so on. + * The multiplication by x and x² is a just a shift, as it is a + * power of two, and is implemented below by just writting at the + * correct offset */ +long +mp_karatsuba_mul(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2) +{ + BNI x; /* shift count */ + BNI la0, la1, lb0, lb1; /* length of a0, a1, b0, and b1 */ + BNS *t; /* temporary memory for t product */ + BNS *u; /* temporary memory for u product */ + BNS *r; /* pointer to rop */ + long xlen, tlen, ulen; + + /* calculate value of x, that is 2^(BNSBITS*x) */ + if (len1 >= len2) + x = (len1 + 1) >> 1; + else + x = (len2 + 1) >> 1; + + /* calculate length of operands */ + la0 = x; + la1 = len1 - x; + lb0 = x; + lb1 = len2 - x; + + /* allocate buffer for t and (a0 + a1) */ + tlen = la0 + lb0; + t = mp_malloc(sizeof(BNS) * tlen); + + /* allocate buffer for u and (b0 + b1) */ + if (la1 + lb1 < lb0 + lb1 + 1) + ulen = lb0 + lb1 + 1; + else + ulen = la1 + lb1; + u = mp_malloc(sizeof(BNS) * ulen); + + /* calculate a0 + a1, store result in t */ + tlen = mp_add(t, op1, op1 + x, la0, la1); + + /* calculate b0 + b1, store result in u */ + ulen = mp_add(u, op2, op2 + x, lb0, lb1); + + /* store (a0 + a1) * (b0 + b1) in rop */ + + r = rop + x; /* multiplied by 2^(BNSBITS*x) */ + xlen = mp_mul(r, t, u, tlen, ulen); + + /* must zero t and u memory, this is required for mp_mul */ + + /* calculate t = a0 * b0 */ + tlen = la0 + lb0; + memset(t, '\0', sizeof(BNS) * tlen); + tlen = mp_mul(t, op1, op2, la0, lb0); + + /* calculate u = a1 * b1 */ + ulen = la1 + lb1; + memset(u, '\0', sizeof(BNS) * ulen); + ulen = mp_mul(u, op1 + x, op2 + x, la1, lb1); + + /* subtract t from partial result */ + xlen = mp_sub(r, r, t, xlen, tlen); + + /* subtract u form partial result */ + xlen = mp_sub(r, r, u, xlen, ulen); + + /* add ux^2 to partial result */ + + r = rop + (x << 1); /* multiplied by x^2 = 2^(BNSBITS*x*2) */ + xlen = len1 + len2; + xlen = mp_add(r, r, u, xlen, ulen); + + /* now add t to final result */ + xlen = mp_add(rop, rop, t, xlen, tlen); + + mp_free(t); + mp_free(u); + + if (xlen > 1 && rop[xlen - 1] == 0) + --xlen; + + return (xlen); +} + + /* Toom method (partially based on GMP documentation) + * Evaluation at k = [ 0 1/2 1 2 oo ] + * U(x) = (U2k + U1)k + U0 + * V(x) = (V2k + V1)k + V0 + * W(x) = U(x)V(x) + * + * Sample: + * 123 * 456 + * + * EVALUATION: + * U(0) = (1*0+2)*0+3 => 3 + * U(1) = 1+(2+3*2)*2 => 17 + * U(2) = 1+2+3 => 6 + * U(3) = (1*2+2)*2+3 => 11 + * U(4) = 1+(2+3*0)*0 => 1 + * + * V(0) = (4*0+5)*0+6 => 6 + * V(1) = 4+(5+6*2)*2 => 38 + * V(2) = 4+5+6 => 15 + * V(3) = (4*2+5)*2+6 => 32 + * V(4) = 4+(5+6*0)*0 => 4 + * + * U = [ 3 17 6 11 1 ] + * V = [ 6 38 15 32 4 ] + * W = [ 18 646 90 352 4 ] + * + * After that, we have: + * a = 18 (w0 already known) + * b = 16w0 + 8w1 + 4w2 + 2w3 + w4 + * c = w0 + w1 + w2 + w3 + w4 + * d = w0 + 2w1 + 4w2 + 8w3 + 16w4 + * e = 4 (w4 already known) + * + * INTERPOLATION: + * b = b -16a - e (354) + * c = c - a - e (68) + * d = d - a - 16e (270) + * + * w = (b + d) - 8c = (10w1+8w2+10w3) - (8w1+8w2+8w3) = 2w1+2w3 + * w = 2c - w (56) + * b = b/2 = 4w1+w+w3 + * b = b-c = 4w1+w+w3 - w1+w2+w3 = 3w1+w2 + * c = w/2 (w2 = 28) + * b = b-c = 3w1+c - c = 3w1 + * b = b/3 (w1 = 27) + * d = d/2 + * d = d-b-w = b+w+4w3 - b-w = 4w3 + * d = d/4 (w3 = 13) + * + * RESULT: + * w4*10^4 + w3*10³ + w2*10² + w1*10 + w0 + * 40000 + 13000 + 2800 + 270 + 18 + * 10 is the base where the calculation was done + * + * This sample uses small numbers, so it does not show the + * advantage of the method. But for example (in base 10), when squaring + * 123456789012345678901234567890 + * The normal method would do 30*30=900 multiplications + * Karatsuba method would do 15*15*3=675 multiplications + * Toom method would do 10*10*5=500 multiplications + * Toom method has a larger overhead if compared with Karatsuba method, + * due to evaluation and interpolation, so it should be used for larger + * numbers, so that the computation time of evaluation/interpolation + * would be smaller than the time spent using other methods. + * + * Note that Karatsuba method can be seen as a special case of + * Toom method, i.e: + * U1U0 * V1V0 + * with k = [ 0 1 oo ] + * U = [ U0 U1+U0 U1 ] + * V = [ V0 V1+V0 V1 ] + * W = [ U0*V0 (U1+U0)*(V1+V0) (U1+V1) ] + * + * w0 = U0*V0 + * w = (U1+U0)*(V1+V0) + * w2 = (U1*V1) + * + * w1 = w - w0 - w2 + * w2x² + w1x + w0 + * + * See Knuth's Seminumerical Algorithms for a sample implemention + * using 4 stacks and k = [ 0 1 2 3 ... ], based on the size of the + * input. + */ +long +mp_toom_mul(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2) +{ + long size, xsize, i; + BNI value; /* used in division */ + BNS carry; + BNI x; /* shift count */ + BNI l1, l2; + BNI al, bl, cl, dl, el, Ul[3], Vl[3]; + BNS *a, *b, *c, *d, *e, *U[3], *V[3]; + + /* x is the base i.e. 2^(BNSBITS*x) */ + x = (len1 + len2 + 4) / 6; + l1 = len1 - (x << 1); /* length of remaining piece of op1 */ + l2 = len2 - (x << 1); /* length of remaining piece of op2 */ + + /* allocate memory for storing U and V */ + U[0] = mp_malloc(sizeof(BNS) * (x + 2)); + V[0] = mp_malloc(sizeof(BNS) * (x + 2)); + U[1] = mp_malloc(sizeof(BNS) * (x + 1)); + V[1] = mp_malloc(sizeof(BNS) * (x + 1)); + U[2] = mp_malloc(sizeof(BNS) * (x + 2)); + V[2] = mp_malloc(sizeof(BNS) * (x + 2)); + + /* EVALUATE U AND V */ + + /* Numbers are in the format U2x²+U1x+U0 and V2x²+V1x+V0 */ + + /* U[0] = U2+U1*2+U0*4 */ + + /* store U1*2 in U[1], this value is used twice */ + Ul[1] = mp_lshift(U[1], op1 + x, x, 1); + + /* store U0*4 in U[0] */ + Ul[0] = mp_lshift(U[0], op1, x, 2); + /* add U1*2 to U[0] */ + Ul[0] = mp_add(U[0], U[0], U[1], Ul[0], Ul[1]); + /* add U2 to U[0] */ + Ul[0] = mp_add(U[0], U[0], op1 + x + x, Ul[0], l1); + + /* U[2] = U2*4+U1*2+U0 */ + + /* store U2*4 in U[2] */ + Ul[2] = mp_lshift(U[2], op1 + x + x, l1, 2); + /* add U1*2 to U[2] */ + Ul[2] = mp_add(U[2], U[2], U[1], Ul[2], Ul[1]); + /* add U0 to U[2] */ + Ul[2] = mp_add(U[2], U[2], op1, Ul[2], x); + + /* U[1] = U2+U1+U0 */ + + Ul[1] = mp_add(U[1], op1, op1 + x, x, x); + Ul[1] = mp_add(U[1], U[1], op1 + x + x, Ul[1], l1); + + + /* Evaluate V[x], same code as U[x] */ + Vl[1] = mp_lshift(V[1], op2 + x, x, 1); + Vl[0] = mp_lshift(V[0], op2, x, 2); + Vl[0] = mp_add(V[0], V[0], V[1], Vl[0], Vl[1]); + Vl[0] = mp_add(V[0], V[0], op2 + x + x, Vl[0], l2); + Vl[2] = mp_lshift(V[2], op2 + x + x, l2, 2); + Vl[2] = mp_add(V[2], V[2], V[1], Vl[2], Vl[1]); + Vl[2] = mp_add(V[2], V[2], op2, Vl[2], x); + Vl[1] = mp_add(V[1], op2, op2 + x, x, x); + Vl[1] = mp_add(V[1], V[1], op2 + x + x, Vl[1], l2); + + + /* MULTIPLY U[] AND V[] */ + + /* calculate (U2+U1*2+U0*4) * (V2+V1*2+V0*4) */ + b = mp_calloc(1, sizeof(BNS) * (Ul[0] * Vl[0])); + bl = mp_mul(b, U[0], V[0], Ul[0], Vl[0]); + mp_free(U[0]); + mp_free(V[0]); + + /* calculate (U2+U1+U0) * (V2+V1+V0) */ + c = mp_calloc(1, sizeof(BNS) * (Ul[1] * Vl[1])); + cl = mp_mul(c, U[1], V[1], Ul[1], Vl[1]); + mp_free(U[1]); + mp_free(V[1]); + + /* calculate (U2*4+U1*2+U0) * (V2*4+V1*2+V0) */ + d = mp_calloc(1, sizeof(BNS) * (Ul[2] * Vl[2])); + dl = mp_mul(d, U[2], V[2], Ul[2], Vl[2]); + mp_free(U[2]); + mp_free(V[2]); + + /* calculate U0 * V0 */ + a = mp_calloc(1, sizeof(BNS) * (x + x)); + al = mp_mul(a, op1, op2, x, x); + + /* calculate U2 * V2 */ + e = mp_calloc(1, sizeof(BNS) * (l1 + l2)); + el = mp_mul(e, op1 + x + x, op2 + x + x, l1, l2); + + + /* INTERPOLATE COEFFICIENTS */ + + /* b = b - 16a - e */ + size = mp_lshift(rop, a, al, 4); + bl = mp_sub(b, b, rop, bl, size); + bl = mp_sub(b, b, e, bl, el); + + /* c = c - a - e*/ + cl = mp_sub(c, c, a, cl, al); + cl = mp_sub(c, c, e, cl, el); + + /* d = d - a - 16e */ + dl = mp_sub(d, d, a, dl, al); + size = mp_lshift(rop, e, el, 4); + dl = mp_sub(d, d, rop, dl, size); + + /* w = (b + d) - 8c */ + size = mp_add(rop, b, d, bl, dl); + xsize = mp_lshift(rop + size, c, cl, 3); /* rop has enough storage */ + size = mp_sub(rop, rop, rop + size, size, xsize); + + /* w = 2c - w*/ + xsize = mp_lshift(rop + size, c, cl, 1); + size = mp_sub(rop, rop + size, rop, xsize, size); + + /* b = b/2 */ + bl = mp_rshift(b, b, bl, 1); + + /* b = b - c */ + bl = mp_sub(b, b, c, bl, cl); + + /* c = w / 2 */ + cl = mp_rshift(c, rop, size, 1); + + /* b = b - c */ + bl = mp_sub(b, b, c, bl, cl); + + /* b = b/3 */ + /* maybe the most expensive calculation */ + i = bl - 1; + value = b[i]; + b[i] = value / 3; + for (--i; i >= 0; i--) { + carry = value % 3; + value = ((BNI)carry << BNSBITS) + b[i]; + b[i] = (BNS)(value / 3); + } + + /* d = d/2 */ + dl = mp_rshift(d, d, dl, 1); + + /* d = d - b - w */ + dl = mp_sub(d, d, b, dl, bl); + dl = mp_sub(d, d, rop, dl, size); + + /* d = d/4 */ + dl = mp_rshift(d, d, dl, 2); + + + /* STORE RESULT IN ROP */ + /* first clear memory used as temporary variable w and 8c */ + memset(rop, '\0', sizeof(BNS) * (len1 + len2)); + + i = x * 4; + xsize = (len1 + len2) - i; + size = mp_add(rop + i, rop + i, e, xsize, el) + i; + i = x * 3; + xsize = size - i; + size = mp_add(rop + i, rop + i, d, xsize, dl) + i; + i = x * 2; + xsize = size - i; + size = mp_add(rop + i, rop + i, c, xsize, cl) + i; + i = x; + xsize = size - i; + size = mp_add(rop + i, rop + i, b, xsize, bl) + i; + size = mp_add(rop, rop, a, size, al); + + mp_free(e); + mp_free(d); + mp_free(c); + mp_free(b); + mp_free(a); + + if (size > 1 && rop[size - 1] == 0) + --size; + + return (size); +} + +long +mp_mul(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2) +{ + if (len1 < len2) + MP_SWAP(op1, op2, len1, len2); + + if (len1 < KARATSUBA || len2 < KARATSUBA) + return (mp_base_mul(rop, op1, op2, len1, len2)); + else if (len1 < TOOM && len2 < TOOM && len2 > ((len1 + 1) >> 1)) + return (mp_karatsuba_mul(rop, op1, op2, len1, len2)); + else if (len1 >= TOOM && len2 >= TOOM && (len2 + 2) / 3 == (len1 + 2) / 3) + return (mp_toom_mul(rop, op1, op2, len1, len2)); + else { + long xsize, psize, isize; + BNS *ptr; + + /* adjust index pointer and estimated size of result */ + isize = 0; + xsize = len1 + len2; + mp_mul(rop, op1, op2, len2, len2); + /* adjust pointers */ + len1 -= len2; + op1 += len2; + + /* allocate buffer for intermediate multiplications */ + if (len1 > len2) + ptr = mp_calloc(1, sizeof(BNS) * (len2 + len2)); + else + ptr = mp_calloc(1, sizeof(BNS) * (len1 + len2)); + + /* loop multiplying len2 size operands at a time */ + while (len1 >= len2) { + isize += len2; + psize = mp_mul(ptr, op1, op2, len2, len2); + mp_add(rop + isize, rop + isize, ptr, xsize - isize, psize); + len1 -= len2; + op1 += len2; + + /* multiplication routines require zeroed memory */ + memset(ptr, '\0', sizeof(BNS) * (MIN(len1, len2) + len2)); + } + + /* len1 was not a multiple of len2 */ + if (len1) { + isize += len2; + psize = mp_mul(ptr, op2, op1, len2, len1); + mp_add(rop + isize, rop + isize, ptr, xsize, psize); + } + + /* adjust result size */ + if (rop[xsize - 1] == 0) + --xsize; + + mp_free(ptr); + + return (xsize); + } +} diff --git a/lisp/mp/mp.h b/lisp/mp/mp.h new file mode 100644 index 0000000..88f1b24 --- /dev/null +++ b/lisp/mp/mp.h @@ -0,0 +1,435 @@ +/* + * Copyright (c) 2002 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/mp/mp.h,v 1.6 2003/01/12 03:55:51 tsi Exp $ */ + +#include <stdio.h> +#include <math.h> +#ifdef sun +#include <ieeefp.h> +#endif +#include <float.h> +#include <stdlib.h> +#include <limits.h> +#include <ctype.h> +#include <string.h> + +#ifndef __mp_h_ +#define __mp_h_ + +#ifdef __GNUC__ +#define INLINE __inline__ +#else +#define INLINE /**/ +#endif + +/* this normally is better for multiplication and also + * simplify addition loops putting the larger value first */ +#define MP_SWAP(op1, op2, len1, len2) { \ + BNS *top = op1; \ + BNI tlen = len1; \ + \ + op1 = op2; \ + len1 = len2; \ + op2 = top; \ + len2 = tlen; \ +} + +/* + * At least this length to use Karatsuba multiplication method + */ +#define KARATSUBA 32 + +/* + * At least this length to use Toom multiplication method + */ +#define TOOM 128 + +#if ULONG_MAX > 4294967295UL + /* sizeof(long) == 8 and sizeof(int) == 4 */ +# define BNI unsigned long +# define BNS unsigned int +# define MINSLONG 0x8000000000000000UL +# define CARRY 0x100000000 +# define LMASK 0xffffffff00000000UL +# define SMASK 0x00000000ffffffffUL +# define BNIBITS 64 +# define BNSBITS 32 +# ifndef LONG64 +# define LONG64 +# endif +#else + /* sizeof(long) == 4 and sizeof(short) == 2 */ +# define BNI unsigned long +# define BNS unsigned short +# define MINSLONG 0x80000000UL +# define CARRY 0x10000 +# define LMASK 0xffff0000UL +# define SMASK 0x0000ffffUL +# define BNIBITS 32 +# define BNSBITS 16 +#endif + +#ifdef MAX +#undef MAX +#endif +#define MAX(a, b) ((a) > (b) ? (a) : (b)) + +#ifdef MIN +#undef MIN +#endif +#define MIN(a, b) ((a) < (b) ? (a) : (b)) + +/* + * Types + */ +typedef struct _mpi { + unsigned int size : 31; + unsigned int sign : 1; + BNI alloc; + BNS *digs; /* LSF format */ +} mpi; + +typedef struct _mpr { + mpi num; + mpi den; +} mpr; + +typedef void *(*mp_malloc_fun)(size_t); +typedef void *(*mp_calloc_fun)(size_t, size_t); +typedef void *(*mp_realloc_fun)(void*, size_t); +typedef void (*mp_free_fun)(void*); + +/* + * Prototypes + */ +/* GENERIC FUNCTIONS */ + /* memory allocation wrappers */ +void *mp_malloc(size_t size); +void *mp_calloc(size_t nmemb, size_t size); +void *mp_realloc(void *pointer, size_t size); +void mp_free(void *pointer); +mp_malloc_fun mp_set_malloc(mp_malloc_fun); +mp_calloc_fun mp_set_calloc(mp_calloc_fun); +mp_realloc_fun mp_set_realloc(mp_realloc_fun); +mp_free_fun mp_set_free(mp_free_fun); + + /* adds op1 and op2, stores result in rop + * rop must pointer to at least len1 + len2 + 1 elements + * rop can be either op1 or op2 */ +long mp_add(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2); + + /* subtracts op2 from op1, stores result in rop + * rop must pointer to at least len1 + len2 elements + * op1 must be >= op2 + * rop can be either op1 or op2 */ +long mp_sub(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2); + + /* shift op to the left shift bits + * rop must have enough storage for result + * rop can be op */ +long mp_lshift(BNS *rop, BNS *op, BNI len, long shift); + + /* shift op to the right shift bits + * shift must be positive + * rop can be op */ +long mp_rshift(BNS *rop, BNS *op, BNI len, long shift); + + /* use simple generic multiplication method + * rop cannot be the same as op1 or op2 + * rop must be zeroed + * op1 can be op2 */ +long mp_base_mul(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2); + + /* use Karatsuba method + * MIN(len1, len2) must be larger than (MAX(len1, len2) + 1) >> 1 + * MAX(len1, len2) should be at least 2 + * rop cannot be the same as op1 or op2 + * rop must be zeroed + * op1 can be op2 */ +long mp_karatsuba_mul(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2); + + /* use Toom method + * len1 / 3 should be equal to len2 / 3 + * len1 / 3 should be at least 1 + * rop cannot be the same as op1 or op2 + * rop must be zeroed + * op1 can be op2 */ +long mp_toom_mul(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2); + + /* chooses the available multiplication methods based on it's input + * rop must be a pointer to len1 + len2 elements + * rop cannot be the same as op1 or op2 + * rop must be zeroed + * op1 can be op2 */ +long mp_mul(BNS *rop, BNS *op1, BNS *op2, BNI len1, BNI len2); + +/* INTEGER FUNCTIONS */ + /* initialize op and set it to 0 */ +void mpi_init(mpi *op); + + /* clear memory associated to op */ +void mpi_clear(mpi *op); + + /* set rop to the value of op */ +void mpi_set(mpi *rop, mpi *op); + + /* set rop to the value of si */ +void mpi_seti(mpi *rop, long si); + + /* set rop to the floor(fabs(d)) */ +void mpi_setd(mpi *rop, double d); + + /* initialize rop to number representation in str in the given base. + * leading zeros are skipped. + * if sign present, it is processed. + * base must be in the range 2 to 36. */ +void mpi_setstr(mpi *rop, char *str, int base); + + /* adds two mp integers */ +void mpi_add(mpi *rop, mpi *op1, mpi *op2); + + /* adds op1 and op2 */ +void mpi_addi(mpi *rop, mpi *op1, long op2); + + /* subtracts two mp integers */ +void mpi_sub(mpi *rop, mpi *op1, mpi *op2); + + /* subtracts op2 from op1 */ +void mpi_subi(mpi *rop, mpi *op1, long op2); + + /* multiply two mp integers */ +void mpi_mul(mpi *rop, mpi *op1, mpi *op2); + + /* multiply op1 by op2 */ +void mpi_muli(mpi *rop, mpi *op1, long op2); + + /* divides num by den and sets rop to result */ +void mpi_div(mpi *rop, mpi *num, mpi *den); + + /* divides num by den and sets rop to the remainder */ +void mpi_rem(mpi *rop, mpi *num, mpi *den); + + /* divides num by den, sets quotient to qrop and remainder to rrop + * qrop is truncated towards zero. + * qrop and rrop are optional + * qrop and rrop cannot be the same variable */ +void mpi_divqr(mpi *qrop, mpi *rrop, mpi *num, mpi *den); + + /* divides num by then and stores result in rop */ +void mpi_divi(mpi *rop, mpi *num, long den); + + /* divides num by den and returns remainder */ +long mpi_remi(mpi *num, long den); + + /* divides num by den + * stores quotient in qrop and returns remainder */ +long mpi_divqri(mpi *qrop, mpi *num, long den); + + /* sets rop to num modulo den */ +void mpi_mod(mpi *rop, mpi *num, mpi *den); + + /* returns num modulo den */ +long mpi_modi(mpi *num, long den); + + /* sets rop to the greatest common divisor of num and den + * result is always positive */ +void mpi_gcd(mpi *rop, mpi *num, mpi *den); + + /* sets rop to the least common multiple of num and den + * result is always positive */ +void mpi_lcm(mpi *rop, mpi *num, mpi *den); + + /* sets rop to op raised to exp */ +void mpi_pow(mpi *rop, mpi *op, unsigned long exp); + + /* sets rop to the integer part of the nth root of op. + * returns 1 if result is exact, 0 otherwise */ +int mpi_root(mpi *rop, mpi *op, unsigned long nth); + + /* sets rop to the integer part of the square root of op. + * returns 1 if result is exact, 0 otherwise */ +int mpi_sqrt(mpi *rop, mpi *op); + + /* bit shift, left if shift positive, right if negative + * a fast way to multiply and divide by powers of two */ +void mpi_ash(mpi *rop, mpi *op, long shift); + + /* sets rop to op1 logand op2 */ +void mpi_and(mpi *rop, mpi *op1, mpi *op2); + + /* sets rop to op1 logior op2 */ +void mpi_ior(mpi *rop, mpi *op1, mpi *op2); + + /* sets rop to op1 logxor op2 */ +void mpi_xor(mpi *rop, mpi *op1, mpi *op2); + + /* sets rop to one's complement of op */ +void mpi_com(mpi *rop, mpi *op); + + /* sets rop to -op */ +void mpi_neg(mpi *rop, mpi *op); + + /* sets rop to the absolute value of op */ +void mpi_abs(mpi *rop, mpi *op); + + /* compares op1 and op2 + * returns >0 if op1 > op2, 0 if op1 = op2, and <0 if op1 < op2 */ +int mpi_cmp(mpi *op1, mpi *op2); + + /* mpi_cmp with a long integer operand */ +int mpi_cmpi(mpi *op1, long op2); + + /* compares absolute value of op1 and op2 + * returns >0 if abs(op1) > abs(op2), 0 if abs(op1) = abs(op2), + * and <0 if abs(op1) < abs(op2) */ +int mpi_cmpabs(mpi *op1, mpi *op2); + + /* mpi_cmpabs with a long integer operand */ +int mpi_cmpabsi(mpi *op1, long op2); + + /* returns 1 if op1 > 0, 0 if op1 = 0, and -1 if op1 < 0 */ +int mpi_sgn(mpi *op); + + /* fastly swaps contents of op1 and op2 */ +void mpi_swap(mpi *op1, mpi *op2); + + /* returns 1 if op fits in a signed long int, 0 otherwise */ +int mpi_fiti(mpi *op); + + /* converts mp integer to long int + * to know if the value will fit, call mpi_fiti */ +long mpi_geti(mpi *op); + + /* convert mp integer to double */ +double mpi_getd(mpi *op); + + /* returns exact number of characters to represent mp integer + * in given base, excluding sign and ending null character. + * base must be in the range 2 to 36 */ +unsigned long mpi_getsize(mpi *op, int base); + + /* returns pointer to string with representation of mp integer + * if str is not NULL, it must have enough space to store integer + * representation, if NULL a newly allocated string is returned. + * base must be in the range 2 to 36 */ +char *mpi_getstr(char *str, mpi *op, int base); + +/* RATIO FUNCTIONS */ +#define mpr_num(op) (&((op)->num)) +#define mpr_den(op) (&((op)->den)) + + /* initialize op and set it to 0/1 */ +void mpr_init(mpr *op); + + /* clear memory associated to op */ +void mpr_clear(mpr *op); + + /* set rop to the value of op */ +void mpr_set(mpr *rop, mpr *op); + + /* set rop to num/den */ +void mpr_seti(mpr *rop, long num, long den); + + /* set rop to the value of d */ +void mpr_setd(mpr *rop, double d); + + /* initialize rop to number representation in str in the given base. + * leading zeros are skipped. + * if sign present, it is processed. + * base must be in the range 2 to 36. */ +void mpr_setstr(mpr *rop, char *str, int base); + + /* remove common factors of op */ +void mpr_canonicalize(mpr *op); + + /* adds two mp rationals */ +void mpr_add(mpr *rop, mpr *op1, mpr *op2); + + /* adds op1 and op2 */ +void mpr_addi(mpr *rop, mpr *op1, long op2); + + /* subtracts two mp rationals */ +void mpr_sub(mpr *rop, mpr *op1, mpr *op2); + + /* subtracts op2 from op1 */ +void mpr_subi(mpr *rop, mpr *op1, long op2); + + /* multiply two mp rationals */ +void mpr_mul(mpr *rop, mpr *op1, mpr *op2); + + /* multiply op1 by op2 */ +void mpr_muli(mpr *rop, mpr *op1, long op2); + + /* divide two mp rationals */ +void mpr_div(mpr *rop, mpr *op1, mpr *op2); + + /* divides op1 by op2 */ +void mpr_divi(mpr *rop, mpr *op1, long op2); + + /* sets rop to 1/op */ +void mpr_inv(mpr *rop, mpr *op); + + /* sets rop to -op */ +void mpr_neg(mpr *rop, mpr *op); + + /* sets rop to the absolute value of op */ +void mpr_abs(mpr *rop, mpr *op); + + /* compares op1 and op2 + * returns >0 if op1 > op2, 0 if op1 = op2, and <0 if op1 < op2 */ +int mpr_cmp(mpr *op1, mpr *op2); + + /* mpr_cmp with a long integer operand */ +int mpr_cmpi(mpr *op1, long op2); + + /* compares absolute value of op1 and op2 + * returns >0 if abs(op1) > abs(op2), 0 if abs(op1) = abs(op2), + * and <0 if abs(op1) < abs(op2) */ +int mpr_cmpabs(mpr *op1, mpr *op2); + + /* mpr_cmpabs with a long integer operand */ +int mpr_cmpabsi(mpr *op1, long op2); + + /* fastly swaps contents of op1 and op2 */ +void mpr_swap(mpr *op1, mpr *op2); + + /* returns 1 if op fits in a signed long int, 0 otherwise */ +int mpr_fiti(mpr *op); + + /* convert mp rational to double */ +double mpr_getd(mpr *op); + + /* returns pointer to string with representation of mp rational + * if str is not NULL, it must have enough space to store rational + * representation, if NULL a newly allocated string is returned. + * base must be in the range 2 to 36 */ +char *mpr_getstr(char *str, mpr *op, int base); + +#endif /* __mp_h_ */ diff --git a/lisp/mp/mpi.c b/lisp/mp/mpi.c new file mode 100644 index 0000000..506dc7e --- /dev/null +++ b/lisp/mp/mpi.c @@ -0,0 +1,1656 @@ +/* + * Copyright (c) 2002 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/mp/mpi.c,v 1.12 2002/11/20 07:44:43 paulo Exp $ */ + +#include "mp.h" + +/* + * Prototypes + */ + /* do the hard work of mpi_add and mpi_sub */ +static void mpi_addsub(mpi *rop, mpi *op1, mpi *op2, int sub); + + /* logical functions implementation */ +static INLINE BNS mpi_logic(BNS op1, BNS op2, BNS op); +static void mpi_log(mpi *rop, mpi *op1, mpi *op2, BNS op); + + /* internal mpi_seti, whithout memory allocation */ +static void _mpi_seti(mpi *rop, long si); + +/* + * Initialization + */ +static BNS onedig[1] = { 1 }; +static mpi mpone = { 1, 1, 0, (BNS*)&onedig }; + +/* + * Implementation + */ +void +mpi_init(mpi *op) +{ + op->sign = 0; + op->size = op->alloc = 1; + op->digs = mp_malloc(sizeof(BNS)); + op->digs[0] = 0; +} + +void +mpi_clear(mpi *op) +{ + op->sign = 0; + op->size = op->alloc = 0; + mp_free(op->digs); +} + +void +mpi_set(mpi *rop, mpi *op) +{ + if (rop != op) { + if (rop->alloc < op->size) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * op->size); + rop->alloc = op->size; + } + rop->size = op->size; + memcpy(rop->digs, op->digs, sizeof(BNS) * op->size); + rop->sign = op->sign; + } +} + +void +mpi_seti(mpi *rop, long si) +{ + unsigned long ui; + int sign = si < 0; + int size; + + if (si == MINSLONG) { + ui = MINSLONG; + size = 2; + } + else { + if (sign) + ui = -si; + else + ui = si; + if (ui < CARRY) + size = 1; + else + size = 2; + } + + if (rop->alloc < size) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * size); + rop->alloc = size; + } + rop->size = size; + + /* store data in small mp integer */ + rop->digs[0] = (BNS)ui; + if (size > 1) + rop->digs[1] = (BNS)(ui >> BNSBITS); + rop->size = size; + + /* adjust result sign */ + rop->sign = sign; +} + +static void +_mpi_seti(mpi *rop, long si) +{ + unsigned long ui; + int sign = si < 0; + int size; + + if (si == MINSLONG) { + ui = MINSLONG; + size = 2; + } + else { + if (sign) + ui = -si; + else + ui = si; + if (ui < CARRY) + size = 1; + else + size = 2; + } + + rop->digs[0] = (BNS)ui; + if (size > 1) + rop->digs[1] = (BNS)(ui >> BNSBITS); + rop->size = size; + + rop->sign = sign; +} + +void +mpi_setd(mpi *rop, double d) +{ + long i; + double mantissa; + int shift, exponent; + BNI size; + + if (isnan(d)) + d = 0.0; + else if (!finite(d)) + d = copysign(1.0, d) * DBL_MAX; + + /* check if number is larger than 1 */ + if (fabs(d) < 1.0) { + rop->digs[0] = 0; + rop->size = 1; + rop->sign = d < 0.0; + + return; + } + + mantissa = frexp(d, &exponent); + if (mantissa < 0) + mantissa = -mantissa; + + size = (exponent + (BNSBITS - 1)) / BNSBITS; + shift = BNSBITS - (exponent & (BNSBITS - 1)); + + /* adjust amount of memory */ + if (rop->alloc < size) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * size); + rop->alloc = size; + } + rop->size = size; + + /* adjust the exponent */ + if (shift < BNSBITS) + mantissa = ldexp(mantissa, -shift); + + /* convert double */ + for (i = size - 1; i >= 0 && mantissa != 0.0; i--) { + mantissa = ldexp(mantissa, BNSBITS); + rop->digs[i] = (BNS)mantissa; + mantissa -= rop->digs[i]; + } + for (; i >= 0; i--) + rop->digs[i] = 0; + + /* normalize */ + if (size > 1 && rop->digs[size - 1] == 0) + --rop->size; + + rop->sign = d < 0.0; +} + +/* how many BNS in the given base, log(base) / log(CARRY) */ +#ifdef LONG64 +static double str_bases[37] = { + 0.0000000000000000, 0.0000000000000000, 0.0312500000000000, + 0.0495300781475362, 0.0625000000000000, 0.0725602529652301, + 0.0807800781475362, 0.0877298413143002, 0.0937500000000000, + 0.0990601562950723, 0.1038102529652301, 0.1081072380824156, + 0.1120300781475362, 0.1156387411919092, 0.1189798413143002, + 0.1220903311127662, 0.1250000000000000, 0.1277332137890731, + 0.1303101562950723, 0.1327477347951120, 0.1350602529652300, + 0.1372599194618363, 0.1393572380824156, 0.1413613111267817, + 0.1432800781475362, 0.1451205059304602, 0.1468887411919092, + 0.1485902344426084, 0.1502298413143002, 0.1518119060977367, + 0.1533403311127662, 0.1548186346995899, 0.1562500000000000, + 0.1576373162299517, 0.1589832137890731, 0.1602900942795302, + 0.1615601562950723, +}; +#else +static double str_bases[37] = { + 0.0000000000000000, 0.0000000000000000, 0.0625000000000000, + 0.0990601562950723, 0.1250000000000000, 0.1451205059304602, + 0.1615601562950723, 0.1754596826286003, 0.1875000000000000, + 0.1981203125901446, 0.2076205059304602, 0.2162144761648311, + 0.2240601562950723, 0.2312774823838183, 0.2379596826286003, + 0.2441806622255325, 0.2500000000000000, 0.2554664275781462, + 0.2606203125901445, 0.2654954695902241, 0.2701205059304602, + 0.2745198389236725, 0.2787144761648311, 0.2827226222535633, + 0.2865601562950723, 0.2902410118609203, 0.2937774823838183, + 0.2971804688852168, 0.3004596826286003, 0.3036238121954733, + 0.3066806622255324, 0.3096372693991797, 0.3125000000000000, + 0.3152746324599034, 0.3179664275781462, 0.3205801885590604, + 0.3231203125901446, +}; +#endif + +void +mpi_setstr(mpi *rop, char *str, int base) +{ + long i; /* counter */ + int sign; /* result sign */ + BNI carry; /* carry value */ + BNI value; /* temporary value */ + BNI size; /* size of result */ + char *ptr; /* end of valid input */ + + /* initialization */ + sign = 0; + carry = 0; + + /* skip leading spaces */ + while (isspace(*str)) + ++str; + + /* check if sign supplied */ + if (*str == '-') { + sign = 1; + ++str; + } + else if (*str == '+') + ++str; + + /* skip leading zeros */ + while (*str == '0') + ++str; + + ptr = str; + while (*ptr) { + if (*ptr >= '0' && *ptr <= '9') { + if (*ptr - '0' >= base) + break; + } + else if (*ptr >= 'A' && *ptr <= 'Z') { + if (*ptr - 'A' + 10 >= base) + break; + } + else if (*ptr >= 'a' && *ptr <= 'z') { + if (*ptr - 'a' + 10 >= base) + break; + } + else + break; + ++ptr; + } + + /* resulting size */ + size = (ptr - str) * str_bases[base] + 1; + + /* make sure rop has enough storage */ + if (rop->alloc < size) { + rop->digs = mp_realloc(rop->digs, size * sizeof(BNS)); + rop->alloc = size; + } + rop->size = size; + + /* initialize rop to zero */ + memset(rop->digs, '\0', size * sizeof(BNS)); + + /* set result sign */ + rop->sign = sign; + + /* convert string */ + for (; str < ptr; str++) { + value = *str; + if (islower(value)) + value = toupper(value); + value = value > '9' ? value - 'A' + 10 : value - '0'; + value += rop->digs[0] * base; + carry = value >> BNSBITS; + rop->digs[0] = (BNS)value; + for (i = 1; i < size; i++) { + value = (BNI)rop->digs[i] * base + carry; + carry = value >> BNSBITS; + rop->digs[i] = (BNS)value; + } + } + + /* normalize */ + if (rop->size > 1 && rop->digs[rop->size - 1] == 0) + --rop->size; +} + +void +mpi_add(mpi *rop, mpi *op1, mpi *op2) +{ + mpi_addsub(rop, op1, op2, 0); +} + +void +mpi_addi(mpi *rop, mpi *op1, long op2) +{ + BNS digs[2]; + mpi op; + + op.digs = (BNS*)digs; + _mpi_seti(&op, op2); + + mpi_addsub(rop, op1, &op, 0); +} + +void +mpi_sub(mpi *rop, mpi *op1, mpi *op2) +{ + mpi_addsub(rop, op1, op2, 1); +} + +void +mpi_subi(mpi *rop, mpi *op1, long op2) +{ + BNS digs[2]; + mpi op; + + op.digs = (BNS*)digs; + _mpi_seti(&op, op2); + + mpi_addsub(rop, op1, &op, 1); +} + +static void +mpi_addsub(mpi *rop, mpi *op1, mpi *op2, int sub) +{ + long xlen; /* maximum result size */ + + if (sub ^ (op1->sign == op2->sign)) { + /* plus one for possible carry */ + xlen = MAX(op1->size, op2->size) + 1; + if (rop->alloc < xlen) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * xlen); + rop->alloc = xlen; + } + rop->size = mp_add(rop->digs, op1->digs, op2->digs, + op1->size, op2->size); + rop->sign = op1->sign; + } + else { + long cmp; /* check for larger operator */ + + cmp = mpi_cmpabs(op1, op2); + if (cmp == 0) { + rop->digs[0] = 0; + rop->size = 1; + rop->sign = 0; + } + else { + xlen = MAX(op1->size, op2->size); + if (rop->alloc < xlen) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * xlen); + rop->alloc = xlen; + } + if (cmp > 0) { + rop->size = mp_sub(rop->digs, op1->digs, op2->digs, + op1->size, op2->size); + rop->sign = op1->sign; + } + else { + rop->size = mp_sub(rop->digs, op2->digs, op1->digs, + op2->size, op1->size); + rop->sign = sub ^ op2->sign; + } + } + } +} + +void +mpi_mul(mpi *rop, mpi *op1, mpi *op2) +{ + int sign; /* sign flag */ + BNS *digs; /* result data */ + long xsize; /* result size */ + + /* get result sign */ + sign = op1->sign ^ op2->sign; + + /* check for special cases */ + if (op1->size == 1) { + if (*op1->digs == 0) { + /* multiply by 0 */ + mpi_seti(rop, 0); + return; + } + else if (*op1->digs == 1) { + /* multiply by +-1 */ + if (rop->alloc < op2->size) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * op2->size); + rop->alloc = op2->size; + } + rop->size = op2->size; + memmove(rop->digs, op2->digs, sizeof(BNS) * op2->size); + rop->sign = op2->size > 1 || *op2->digs ? sign : 0; + + return; + } + } + else if (op2->size == 1) { + if (*op2->digs == 0) { + /* multiply by 0 */ + mpi_seti(rop, 0); + return; + } + else if (*op2->digs == 1) { + /* multiply by +-1 */ + if (rop->alloc < op1->size) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * op1->size); + rop->alloc = op1->size; + } + rop->size = op1->size; + memmove(rop->digs, op1->digs, sizeof(BNS) * op1->size); + rop->sign = op1->size > 1 || *op1->digs ? sign : 0; + + return; + } + } + + /* allocate result data and set it to zero */ + xsize = op1->size + op2->size; + if (rop->digs == op1->digs || rop->digs == op2->digs) + /* rop is also an operand */ + digs = mp_calloc(1, sizeof(BNS) * xsize); + else { + if (rop->alloc < xsize) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * xsize); + rop->alloc = xsize; + } + digs = rop->digs; + memset(digs, '\0', sizeof(BNS) * xsize); + } + + /* multiply operands */ + xsize = mp_mul(digs, op1->digs, op2->digs, op1->size, op2->size); + + /* store result in rop */ + if (digs != rop->digs) { + /* if rop was an operand, free old data */ + mp_free(rop->digs); + rop->digs = digs; + } + rop->size = xsize; + + /* set result sign */ + rop->sign = sign; +} + +void +mpi_muli(mpi *rop, mpi *op1, long op2) +{ + BNS digs[2]; + mpi op; + + op.digs = (BNS*)digs; + _mpi_seti(&op, op2); + + mpi_mul(rop, op1, &op); +} + +void +mpi_div(mpi *rop, mpi *num, mpi *den) +{ + mpi_divqr(rop, NULL, num, den); +} + +void +mpi_rem(mpi *rop, mpi *num, mpi *den) +{ + mpi_divqr(NULL, rop, num, den); +} + +/* + * Could/should be changed to not allocate qdigs if qrop is NULL + * Performance wouldn't suffer too much with a test on every loop iteration. + */ +void +mpi_divqr(mpi *qrop, mpi *rrop, mpi *num, mpi *den) +{ + long i, j; /* counters */ + int qsign; /* sign of quotient */ + int rsign; /* sign of remainder */ + BNI qsize; /* size of quotient */ + BNI rsize; /* size of remainder */ + BNS qest; /* estimative of quotient value */ + BNS *qdigs, *rdigs; /* work copy or result */ + BNS *ndigs, *ddigs; /* work copy or divisor and dividend */ + BNI value; /* temporary result */ + long svalue; /* signed temporary result (2's complement) */ + BNS carry, scarry, denorm; /* carry and normalization */ + BNI dpos, npos; /* offsets in data */ + + /* get signs */ + rsign = num->sign; + qsign = rsign ^ den->sign; + + /* check for special case */ + if (num->size < den->size) { + /* quotient is zero and remainder is numerator */ + if (rrop && rrop->digs != num->digs) { + if (rrop->alloc < num->size) { + rrop->digs = mp_realloc(rrop->digs, sizeof(BNS) * num->size); + rrop->alloc = num->size; + } + rrop->size = num->size; + memcpy(rrop->digs, num->digs, sizeof(BNS) * num->size); + rrop->sign = rsign; + } + if (qrop) + mpi_seti(qrop, 0); + + return; + } + + /* estimate result sizes */ + rsize = den->size; + qsize = num->size - den->size + 1; + + /* offsets */ + npos = num->size - 1; + dpos = den->size - 1; + + /* allocate space for quotient and remainder */ + if (qrop == NULL || qrop->digs == num->digs || qrop->digs == den->digs) + qdigs = mp_calloc(1, sizeof(BNS) * qsize); + else { + if (qrop->alloc < qsize) { + qrop->digs = mp_realloc(qrop->digs, sizeof(BNS) * qsize); + qrop->alloc = qsize; + } + memset(qrop->digs, '\0', sizeof(BNS) * qsize); + qdigs = qrop->digs; + } + if (rrop) { + if (rrop->digs == num->digs || rrop->digs == den->digs) + rdigs = mp_calloc(1, sizeof(BNS) * rsize); + else { + if (rrop->alloc < rsize) { + rrop->digs = mp_realloc(rrop->digs, sizeof(BNS) * rsize); + rrop->alloc = rsize; + } + memset(rrop->digs, '\0', sizeof(BNS) * rsize); + rdigs = rrop->digs; + } + } + else + rdigs = NULL; /* fix gcc warning */ + + /* special case, only one word in divisor */ + if (dpos == 0) { + for (carry = 0, i = npos; i >= 0; i--) { + value = ((BNI)carry << BNSBITS) + num->digs[i]; + qdigs[i] = (BNS)(value / den->digs[0]); + carry = (BNS)(value % den->digs[0]); + } + if (rrop) + rdigs[0] = carry; + + goto mpi_divqr_done; + } + + /* make work copy of numerator */ + ndigs = mp_malloc(sizeof(BNS) * (num->size + 1)); + /* allocate one extra word an update offset */ + memcpy(ndigs, num->digs, sizeof(BNS) * num->size); + ndigs[num->size] = 0; + ++npos; + + /* normalize */ + denorm = (BNS)((BNI)CARRY / ((BNI)(den->digs[dpos]) + 1)); + + if (denorm > 1) { + /* i <= num->size because ndigs has an extra word */ + for (carry = 0, i = 0; i <= num->size; i++) { + value = ndigs[i] * (BNI)denorm + carry; + ndigs[i] = (BNS)value; + carry = (BNS)(value >> BNSBITS); + } + /* make work copy of denominator */ + ddigs = mp_malloc(sizeof(BNS) * den->size); + memcpy(ddigs, den->digs, sizeof(BNS) * den->size); + for (carry = 0, i = 0; i < den->size; i++) { + value = ddigs[i] * (BNI)denorm + carry; + ddigs[i] = (BNS)value; + carry = (BNS)(value >> BNSBITS); + } + } + else + /* only allocate copy of denominator if going to change it */ + ddigs = den->digs; + + /* divide mp integers */ + for (j = qsize - 1; j >= 0; j--, npos--) { + /* estimate quotient */ + if (ndigs[npos] == ddigs[dpos]) + qest = (BNS)SMASK; + else + qest = (BNS)((((BNI)(ndigs[npos]) << 16) + ndigs[npos - 1]) / + ddigs[dpos]); + + while ((value = ((BNI)(ndigs[npos]) << 16) + ndigs[npos - 1] - + qest * (BNI)(ddigs[dpos])) < CARRY && + ddigs[dpos - 1] * (BNI)qest > + (value << BNSBITS) + ndigs[npos - 2]) + --qest; + + /* multiply and subtract */ + carry = scarry = 0; + for (i = 0; i < den->size; i++) { + value = qest * (BNI)ddigs[i] + carry; + carry = (BNS)(value >> BNSBITS); + svalue = (long)ndigs[npos - dpos + i - 1] - (long)(value & SMASK) - + (long)scarry; + ndigs[npos - dpos + i - 1] = (BNS)svalue; + scarry = svalue < 0; + } + + svalue = (long)ndigs[npos] - (long)(carry & SMASK) - (long)scarry; + ndigs[npos] = (BNS)svalue; + + if (svalue & LMASK) { + /* quotient too big */ + --qest; + carry = 0; + for (i = 0; i < den->size; i++) { + value = ndigs[npos - dpos + i - 1] + (BNI)carry + (BNI)ddigs[i]; + ndigs[npos - dpos + i - 1] = (BNS)value; + carry = (BNS)(value >> BNSBITS); + } + ndigs[npos] += carry; + } + + qdigs[j] = qest; + } + + /* calculate remainder */ + if (rrop) { + for (carry = 0, j = dpos; j >= 0; j--) { + value = ((BNI)carry << BNSBITS) + ndigs[j]; + rdigs[j] = (BNS)(value / denorm); + carry = (BNS)(value % denorm); + } + } + + mp_free(ndigs); + if (ddigs != den->digs) + mp_free(ddigs); + +mpi_divqr_done: + if (rrop) { + if (rrop->digs != rdigs) + mp_free(rrop->digs); + /* normalize remainder */ + for (i = rsize - 1; i >= 0; i--) + if (rdigs[i] != 0) + break; + if (i != rsize - 1) { + if (i < 0) { + rsign = 0; + rsize = 1; + } + else + rsize = i + 1; + } + rrop->digs = rdigs; + rrop->sign = rsign; + rrop->size = rsize; + } + + /* normalize quotient */ + if (qrop) { + if (qrop->digs != qdigs) + mp_free(qrop->digs); + for (i = qsize - 1; i >= 0; i--) + if (qdigs[i] != 0) + break; + if (i != qsize - 1) { + if (i < 0) { + qsign = 0; + qsize = 1; + } + else + qsize = i + 1; + } + qrop->digs = qdigs; + qrop->sign = qsign; + qrop->size = qsize; + } + else + mp_free(qdigs); +} + +long +mpi_divqri(mpi *qrop, mpi *num, long den) +{ + BNS ddigs[2]; + mpi dop, rrop; + long remainder; + + dop.digs = (BNS*)ddigs; + _mpi_seti(&dop, den); + + memset(&rrop, '\0', sizeof(mpi)); + mpi_init(&rrop); + mpi_divqr(qrop, &rrop, num, &dop); + remainder = rrop.digs[0]; + if (rrop.size > 1) + remainder |= (BNI)(rrop.digs[1]) << BNSBITS; + if (rrop.sign) + remainder = -remainder; + mpi_clear(&rrop); + + return (remainder); +} + +void +mpi_divi(mpi *rop, mpi *num, long den) +{ + BNS ddigs[2]; + mpi dop; + + dop.digs = (BNS*)ddigs; + _mpi_seti(&dop, den); + + mpi_divqr(rop, NULL, num, &dop); +} + +long +mpi_remi(mpi *num, long den) +{ + return (mpi_divqri(NULL, num, den)); +} + +void +mpi_mod(mpi *rop, mpi *num, mpi *den) +{ + mpi_rem(rop, num, den); + if (num->sign ^ den->sign) + mpi_add(rop, rop, den); +} + +long +mpi_modi(mpi *num, long den) +{ + long remainder; + + remainder = mpi_remi(num, den); + if (num->sign ^ (den < 0)) + remainder += den; + + return (remainder); +} + +void +mpi_gcd(mpi *rop, mpi *num, mpi *den) +{ + long cmp; + mpi rem; + + /* check if result already given */ + cmp = mpi_cmpabs(num, den); + + /* check if num is equal to den or if num is zero */ + if (cmp == 0 || (num->size == 1 && num->digs[0] == 0)) { + mpi_set(rop, den); + rop->sign = 0; + return; + } + /* check if den is not zero */ + if (den->size == 1 && den->digs[0] == 0) { + mpi_set(rop, num); + rop->sign = 0; + return; + } + + /* don't call mpi_init, relies on realloc(0, size) == malloc(size) */ + memset(&rem, '\0', sizeof(mpi)); + + /* if num larger than den */ + if (cmp > 0) { + mpi_rem(&rem, num, den); + if (rem.size == 1 && rem.digs[0] == 0) { + /* exact division */ + mpi_set(rop, den); + rop->sign = 0; + mpi_clear(&rem); + return; + } + mpi_set(rop, den); + } + else { + mpi_rem(&rem, den, num); + if (rem.size == 1 && rem.digs[0] == 0) { + /* exact division */ + mpi_set(rop, num); + rop->sign = 0; + mpi_clear(&rem); + return; + } + mpi_set(rop, num); + } + + /* loop using positive values */ + rop->sign = rem.sign = 0; + + /* cannot optimize this inverting rem/rop assignment earlier + * because rop mais be an operand */ + mpi_swap(rop, &rem); + + /* Euclides algorithm */ + for (;;) { + mpi_rem(&rem, &rem, rop); + if (rem.size == 1 && rem.digs[0] == 0) + break; + mpi_swap(rop, &rem); + } + mpi_clear(&rem); +} + +void +mpi_lcm(mpi *rop, mpi *num, mpi *den) +{ + mpi gcd; + + /* check for zero operand */ + if ((num->size == 1 && num->digs[0] == 0) || + (den->size == 1 && den->digs[0] == 0)) { + rop->digs[0] = 0; + rop->sign = 0; + return; + } + + /* don't call mpi_init, relies on realloc(0, size) == malloc(size) */ + memset(&gcd, '\0', sizeof(mpi)); + + mpi_gcd(&gcd, num, den); + mpi_div(&gcd, den, &gcd); + mpi_mul(rop, &gcd, num); + rop->sign = 0; + + mpi_clear(&gcd); +} + +void +mpi_pow(mpi *rop, mpi *op, unsigned long exp) +{ + mpi zop, top; + + if (exp == 2) { + mpi_mul(rop, op, op); + return; + } + /* check for op**0 */ + else if (exp == 0) { + rop->digs[0] = 1; + rop->size = 1; + rop->sign = 0; + return; + } + else if (exp == 1) { + mpi_set(rop, op); + return; + } + else if (op->size == 1) { + if (op->digs[0] == 0) { + mpi_seti(rop, 0); + return; + } + else if (op->digs[0] == 1) { + mpi_seti(rop, op->sign && (exp & 1) ? -1 : 1); + return; + } + } + + memset(&zop, '\0', sizeof(mpi)); + memset(&top, '\0', sizeof(mpi)); + mpi_set(&zop, op); + mpi_set(&top, op); + for (--exp; exp; exp >>= 1) { + if (exp & 1) + mpi_mul(&zop, &top, &zop); + mpi_mul(&top, &top, &top); + } + + mpi_clear(&top); + rop->sign = zop.sign; + mp_free(rop->digs); + rop->digs = zop.digs; + rop->size = zop.size; +} + +/* Find integer root of given number using the iteration + * x{n+1} = ((K-1) * x{n} + N / x{n}^(K-1)) / K + */ +int +mpi_root(mpi *rop, mpi *op, unsigned long nth) +{ + long bits, cmp; + int exact; + int sign; + mpi *r, t, temp, quot, old, rem; + + sign = op->sign; + + /* divide by zero op**1/0 */ + if (nth == 0) { + int one = 1, zero = 0; + one = one / zero; + } + /* result is complex */ + if (sign && !(nth & 1)) { + int one = 1, zero = 0; + one = one / zero; + } + + /* special case op**1/1 = op */ + if (nth == 1) { + mpi_set(rop, op); + return (1); + } + + bits = mpi_getsize(op, 2) - 2; + + if (bits < 0 || bits / nth == 0) { + /* integral root is surely less than 2 */ + exact = op->size == 1 && (op->digs[0] == 1 || op->digs[0] == 0); + mpi_seti(rop, sign ? -1 : op->digs[0] == 0 ? 0 : 1); + + return (exact == 1); + } + + /* initialize */ + if (rop != op) + r = rop; + else { + r = &t; + memset(r, '\0', sizeof(mpi)); + } + memset(&temp, '\0', sizeof(mpi)); + memset(", '\0', sizeof(mpi)); + memset(&old, '\0', sizeof(mpi)); + memset(&rem, '\0', sizeof(mpi)); + + if (sign) + r->sign = 0; + + /* root aproximation */ + mpi_ash(r, op, -(bits - (bits / nth))); + + for (;;) { + mpi_pow(&temp, r, nth - 1); + mpi_divqr(", &rem, op, &temp); + cmp = mpi_cmpabs(r, "); + if (cmp == 0) { + exact = mpi_cmpi(&rem, 0) == 0; + break; + } + else if (cmp < 0) { + if (mpi_cmpabs(r, &old) == 0) { + exact = 0; + break; + } + mpi_set(&old, r); + } + mpi_muli(&temp, r, nth - 1); + mpi_add(", ", &temp); + mpi_divi(r, ", nth); + } + + mpi_clear(&temp); + mpi_clear("); + mpi_clear(&old); + mpi_clear(&rem); + if (r != rop) { + mpi_set(rop, r); + mpi_clear(r); + } + rop->sign = sign; + + return (exact); +} + +/* + * Find square root using the iteration: + * x{n+1} = (x{n}+N/x{n})/2 + */ +int +mpi_sqrt(mpi *rop, mpi *op) +{ + long bits, cmp; + int exact; + mpi *r, t, quot, rem, old; + + /* result is complex */ + if (op->sign) { + int one = 1, zero = 0; + one = one / zero; + } + + bits = mpi_getsize(op, 2) - 2; + + if (bits < 2) { + /* integral root is surely less than 2 */ + exact = op->size == 1 && (op->digs[0] == 1 || op->digs[0] == 0); + mpi_seti(rop, op->digs[0] == 0 ? 0 : 1); + + return (exact == 1); + } + + /* initialize */ + if (rop != op) + r = rop; + else { + r = &t; + memset(r, '\0', sizeof(mpi)); + } + memset(", '\0', sizeof(mpi)); + memset(&rem, '\0', sizeof(mpi)); + memset(&old, '\0', sizeof(mpi)); + + /* root aproximation */ + mpi_ash(r, op, -(bits - (bits / 2))); + + for (;;) { + if (mpi_cmpabs(r, &old) == 0) { + exact = 0; + break; + } + mpi_divqr(", &rem, op, r); + cmp = mpi_cmpabs(", r); + if (cmp == 0) { + exact = mpi_cmpi(&rem, 0) == 0; + break; + } + else if (cmp > 0 && rem.size == 1 && rem.digs[0] == 0) + mpi_subi(", ", 1); + mpi_set(&old, r); + mpi_add(r, r, "); + mpi_ash(r, r, -1); + } + mpi_clear("); + mpi_clear(&rem); + mpi_clear(&old); + if (r != rop) { + mpi_set(rop, r); + mpi_clear(r); + } + + return (exact); +} + +void +mpi_ash(mpi *rop, mpi *op, long shift) +{ + long i; /* counter */ + long xsize; /* maximum result size */ + BNS *digs; + + /* check for 0 shift, multiply/divide by 1 */ + if (shift == 0) { + if (rop != op) { + if (rop->alloc < op->size) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * op->size); + rop->alloc = op->size; + } + rop->size = op->size; + memcpy(rop->digs, op->digs, sizeof(BNS) * op->size); + } + + return; + } + else if (op->size == 1 && op->digs[0] == 0) { + rop->sign = 0; + rop->size = 1; + rop->digs[0] = 0; + + return; + } + + /* check shift and initialize */ + if (shift > 0) + xsize = op->size + (shift / BNSBITS) + 1; + else { + xsize = op->size - ((-shift) / BNSBITS); + if (xsize <= 0) { + rop->size = 1; + rop->sign = op->sign; + rop->digs[0] = op->sign ? 1 : 0; + + return; + } + } + + /* allocate/adjust memory for result */ + if (rop == op) + digs = mp_malloc(sizeof(BNS) * xsize); + else { + if (rop->alloc < xsize) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * xsize); + rop->alloc = xsize; + } + digs = rop->digs; + } + + /* left shift, multiply by power of two */ + if (shift > 0) + rop->size = mp_lshift(digs, op->digs, op->size, shift); + /* right shift, divide by power of two */ + else { + long carry = 0; + + if (op->sign) { + BNI words, bits; + + words = -shift / BNSBITS; + bits = -shift % BNSBITS; + for (i = 0; i < words; i++) + carry |= op->digs[xsize + i]; + if (!carry) { + for (i = 0; i < bits; i++) + if (op->digs[op->size - xsize] & (1 << i)) { + carry = 1; + break; + } + } + } + rop->size = mp_rshift(digs, op->digs, op->size, -shift); + + if (carry) + /* emulates two's complement subtracting 1 from the result */ + rop->size = mp_add(digs, digs, mpone.digs, rop->size, 1); + } + + if (rop->digs != digs) { + mp_free(rop->digs); + rop->alloc = rop->size; + rop->digs = digs; + } + rop->sign = op->sign; +} + +static INLINE BNS +mpi_logic(BNS op1, BNS op2, BNS op) +{ + switch (op) { + case '&': + return (op1 & op2); + case '|': + return (op1 | op2); + case '^': + return (op1 ^ op2); + } + + return (SMASK); +} + +static void +mpi_log(mpi *rop, mpi *op1, mpi *op2, BNS op) +{ + long i; /* counter */ + long c, c1, c2; /* carry */ + BNS *digs, *digs1, *digs2; /* pointers to mp data */ + BNI size, size1, size2; + BNS sign, sign1, sign2; + BNS n, n1, n2; /* logical operands */ + BNI sum; + + /* initialize */ + size1 = op1->size; + size2 = op2->size; + + sign1 = op1->sign ? SMASK : 0; + sign2 = op2->sign ? SMASK : 0; + + sign = mpi_logic(sign1, sign2, op); + + size = MAX(size1, size2); + if (sign) + ++size; + if (rop->alloc < size) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * size); + rop->alloc = size; + } + + digs = rop->digs; + digs1 = op1->digs; + digs2 = op2->digs; + + c = c1 = c2 = 1; + + /* apply logical operation */ + for (i = 0; i < size; i++) { + if (i >= size1) + n1 = sign1; + else if (sign1) { + sum = (BNI)(BNS)(~digs1[i]) + c1; + c1 = (long)(sum >> BNSBITS); + n1 = (BNS)sum; + } + else + n1 = digs1[i]; + + if (i >= size2) + n2 = sign2; + else if (sign2) { + sum = (BNI)(BNS)(~digs2[i]) + c2; + c2 = (long)(sum >> BNSBITS); + n2 = (BNS)sum; + } + else + n2 = digs2[i]; + + n = mpi_logic(n1, n2, op); + if (sign) { + sum = (BNI)(BNS)(~n) + c; + c = (long)(sum >> BNSBITS); + digs[i] = (BNS)sum; + } + else + digs[i] = n; + } + + /* normalize */ + for (i = size - 1; i >= 0; i--) + if (digs[i] != 0) + break; + if (i != size - 1) { + if (i < 0) { + sign = 0; + size = 1; + } + else + size = i + 1; + } + + rop->sign = sign != 0; + rop->size = size; +} + +void +mpi_and(mpi *rop, mpi *op1, mpi *op2) +{ + mpi_log(rop, op1, op2, '&'); +} + +void +mpi_ior(mpi *rop, mpi *op1, mpi *op2) +{ + mpi_log(rop, op1, op2, '|'); +} + +void +mpi_xor(mpi *rop, mpi *op1, mpi *op2) +{ + mpi_log(rop, op1, op2, '^'); +} + +void +mpi_com(mpi *rop, mpi *op) +{ + static BNS digs[1] = { 1 }; + static mpi one = { 0, 1, 1, (BNS*)&digs }; + + mpi_log(rop, rop, &one, '^'); +} + +void +mpi_neg(mpi *rop, mpi *op) +{ + int sign = op->sign ^ 1; + + if (rop->digs != op->digs) { + if (rop->alloc < op->size) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * rop->size); + rop->alloc = op->size; + } + rop->size = op->size; + memcpy(rop->digs, op->digs, sizeof(BNS) * rop->size); + } + + rop->sign = sign; +} + +void +mpi_abs(mpi *rop, mpi *op) +{ + if (rop->digs != op->digs) { + if (rop->alloc < op->size) { + rop->digs = mp_realloc(rop->digs, sizeof(BNS) * rop->size); + rop->alloc = op->size; + } + rop->size = op->size; + memcpy(rop->digs, op->digs, sizeof(BNS) * rop->size); + } + + rop->sign = 0; +} + +int +mpi_cmp(mpi *op1, mpi *op2) +{ + if (op1->sign ^ op2->sign) + return (op1->sign ? -1 : 1); + + if (op1->size == op2->size) { + long i, cmp = 0; + + for (i = op1->size - 1; i >= 0; i--) + if ((cmp = (long)op1->digs[i] - (long)op2->digs[i]) != 0) + break; + + return (cmp == 0 ? 0 : (cmp < 0) ^ op1->sign ? -1 : 1); + } + + return ((op1->size < op2->size) ^ op1->sign ? -1 : 1); +} + +int +mpi_cmpi(mpi *op1, long op2) +{ + long cmp; + + if (op1->size > 2) + return (op1->sign ? -1 : 1); + + cmp = op1->digs[0]; + if (op1->size == 2) { + cmp |= (long)op1->digs[1] << BNSBITS; + if (cmp == MINSLONG) + return (op2 == cmp && op1->sign ? 0 : op1->sign ? -1 : 1); + } + if (op1->sign) + cmp = -cmp; + + return (cmp - op2); +} + +int +mpi_cmpabs(mpi *op1, mpi *op2) +{ + if (op1->size == op2->size) { + long i, cmp = 0; + + for (i = op1->size - 1; i >= 0; i--) + if ((cmp = (long)op1->digs[i] - (long)op2->digs[i]) != 0) + break; + + return (cmp); + } + + return ((op1->size < op2->size) ? -1 : 1); +} + +int +mpi_cmpabsi(mpi *op1, long op2) +{ + unsigned long cmp; + + if (op1->size > 2) + return (1); + + cmp = op1->digs[0]; + if (op1->size == 2) + cmp |= (unsigned long)op1->digs[1] << BNSBITS; + + return (cmp > op2 ? 1 : cmp == op2 ? 0 : -1); +} + +int +mpi_sgn(mpi *op) +{ + return (op->sign ? -1 : op->size > 1 || op->digs[0] ? 1 : 0); +} + +void +mpi_swap(mpi *op1, mpi *op2) +{ + if (op1 != op2) { + mpi swap; + + memcpy(&swap, op1, sizeof(mpi)); + memcpy(op1, op2, sizeof(mpi)); + memcpy(op2, &swap, sizeof(mpi)); + } +} + +int +mpi_fiti(mpi *op) +{ + if (op->size == 1) + return (1); + else if (op->size == 2) { + unsigned long value = ((BNI)(op->digs[1]) << BNSBITS) | op->digs[0]; + + if (value & MINSLONG) + return (op->sign && value == MINSLONG) ? 1 : 0; + + return (1); + } + + return (0); +} + +long +mpi_geti(mpi *op) +{ + long value; + + value = op->digs[0]; + if (op->size > 1) + value |= (BNI)(op->digs[1]) << BNSBITS; + + return (op->sign && value != MINSLONG ? -value : value); +} + +double +mpi_getd(mpi *op) +{ + long i, len; + double d = 0.0; + int exponent; + +#define FLOATDIGS sizeof(double) / sizeof(BNS) + + switch (op->size) { + case 2: + d = (BNI)(op->digs[1]) << BNSBITS; + case 1: + d += op->digs[0]; + return (op->sign ? -d : d); + default: + break; + } + + for (i = 0, len = op->size; len > 0 && i < FLOATDIGS; i++) + d = ldexp(d, BNSBITS) + op->digs[--len]; + d = frexp(d, &exponent); + if (len > 0) + exponent += len * BNSBITS; + + if (d == 0.0) + return (d); + + d = ldexp(d, exponent); + + return (op->sign ? -d : d); +} + +/* how many digits in a given base, floor(log(CARRY) / log(base)) */ +#ifdef LONG64 +static char dig_bases[37] = { + 0, 0, 32, 20, 16, 13, 12, 11, 10, 10, 9, 9, 8, 8, 8, 8, + 8, 7, 7, 7, 7, 7, 7, 7, 6, 6, 6, 6, 6, 6, 6, 6, + 6, 6, 6, 6, 6, +}; +#else +static char dig_bases[37] = { + 0, 0, 16, 10, 8, 6, 6, 5, 5, 5, 4, 4, 4, 4, 4, 4, + 4, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, +}; +#endif + +/* how many digits per bit in a given base, log(2) / log(base) */ +static double bit_bases[37] = { + 0.0000000000000000, 0.0000000000000000, 1.0000000000000000, + 0.6309297535714575, 0.5000000000000000, 0.4306765580733931, + 0.3868528072345416, 0.3562071871080222, 0.3333333333333334, + 0.3154648767857287, 0.3010299956639811, 0.2890648263178878, + 0.2789429456511298, 0.2702381544273197, 0.2626495350371936, + 0.2559580248098155, 0.2500000000000000, 0.2446505421182260, + 0.2398124665681315, 0.2354089133666382, 0.2313782131597592, + 0.2276702486969530, 0.2242438242175754, 0.2210647294575037, + 0.2181042919855316, 0.2153382790366965, 0.2127460535533632, + 0.2103099178571525, 0.2080145976765095, 0.2058468324604344, + 0.2037950470905062, 0.2018490865820999, 0.2000000000000000, + 0.1982398631705605, 0.1965616322328226, 0.1949590218937863, + 0.1934264036172708, +}; + +/* normalization base for string conversion, pow(base, dig_bases[base]) & ~CARRY */ +#ifdef LONG64 +static BNS big_bases[37] = { + 0x00000001, 0x00000001, 0x00000000, 0xCFD41B91, 0x00000000, 0x48C27395, + 0x81BF1000, 0x75DB9C97, 0x40000000, 0xCFD41B91, 0x3B9ACA00, 0x8C8B6D2B, + 0x19A10000, 0x309F1021, 0x57F6C100, 0x98C29B81, 0x00000000, 0x18754571, + 0x247DBC80, 0x3547667B, 0x4C4B4000, 0x6B5A6E1D, 0x94ACE180, 0xCAF18367, + 0x0B640000, 0x0E8D4A51, 0x1269AE40, 0x17179149, 0x1CB91000, 0x23744899, + 0x2B73A840, 0x34E63B41, 0x40000000, 0x4CFA3CC1, 0x5C13D840, 0x6D91B519, + 0x81BF1000, +}; +#else +static BNS big_bases[37] = { + 0x0001, 0x0001, 0x0000, 0xE6A9, 0x0000, 0x3D09, 0xB640, 0x41A7, 0x8000, + 0xE6A9, 0x2710, 0x3931, 0x5100, 0x6F91, 0x9610, 0xC5C1, 0x0000, 0x1331, + 0x16C8, 0x1ACB, 0x1F40, 0x242D, 0x2998, 0x2F87, 0x3600, 0x3D09, 0x44A8, + 0x4CE3, 0x55C0, 0x5F45, 0x6978, 0x745F, 0x8000, 0x8C61, 0x9988, 0xA77B, + 0xb640, +}; +#endif + +unsigned long +mpi_getsize(mpi *op, int base) +{ + unsigned long value, bits; + + value = op->digs[op->size - 1]; + + /* count leading bits */ + if (value) { + unsigned long count, carry; + + for (count = 0, carry = CARRY >> 1; carry; count++, carry >>= 1) + if (value & carry) + break; + + bits = BNSBITS - count; + } + else + bits = 0; + + return ((bits + (op->size - 1) * BNSBITS) * bit_bases[base] + 1); +} + +char * +mpi_getstr(char *str, mpi *op, int base) +{ + long i; /* counter */ + BNS *digs, *xdigs; /* copy of op data */ + BNI size; /* size of op */ + BNI digits; /* digits per word in given base */ + BNI bigbase; /* big base of given base */ + BNI strsize; /* size of resulting string */ + char *cp; /* pointer in str for conversion */ + + /* initialize */ + size = op->size; + strsize = mpi_getsize(op, base) + op->sign + 1; + + if (str == NULL) + str = mp_malloc(strsize); + + /* check for zero */ + if (size == 1 && op->digs[0] == 0) { + str[0] = '0'; + str[1] = '\0'; + + return (str); + } + + digits = dig_bases[base]; + bigbase = big_bases[base]; + + cp = str + strsize; + *--cp = '\0'; + + /* make copy of op data and adjust digs */ + xdigs = mp_malloc(size * sizeof(BNS)); + memcpy(xdigs, op->digs, size * sizeof(unsigned short)); + digs = xdigs + size - 1; + + /* convert to string */ + for (;;) { + long count = -1; + BNI value; + BNS quotient, remainder = 0; + + /* if power of two base */ + if ((base & (base - 1)) == 0) { + for (i = 0; i < size; i++) { + quotient = remainder; + remainder = digs[-i]; + digs[-i] = quotient; + if (count < 0 && quotient) + count = i; + } + } + else { + for (i = 0; i < size; i++) { + value = digs[-i] + ((BNI)remainder << BNSBITS); + quotient = (BNS)(value / bigbase); + remainder = (BNS)(value % bigbase); + digs[-i] = quotient; + if (count < 0 && quotient) + count = i; + } + } + quotient = remainder; + for (i = 0; i < digits; i++) { + if (quotient == 0 && count < 0) + break; + remainder = quotient % base; + quotient /= base; + *--cp = remainder < 10 ? remainder + '0' : remainder - 10 + 'A'; + } + if (count < 0) + break; + digs -= count; + size -= count; + } + + /* adjust sign */ + if (op->sign) + *--cp = '-'; + + /* remove any extra characters */ + if (cp > str) + strcpy(str, cp); + + mp_free(xdigs); + + return (str); +} diff --git a/lisp/mp/mpr.c b/lisp/mp/mpr.c new file mode 100644 index 0000000..8b26fe0 --- /dev/null +++ b/lisp/mp/mpr.c @@ -0,0 +1,436 @@ +/* + * Copyright (c) 2002 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/mp/mpr.c,v 1.2 2002/11/08 08:01:00 paulo Exp $ */ + +#include "mp.h" + +/* + * TODO: + * Implement a fast gcd and divexact for integers, so that this code + * could be changed to do intermediary calculations faster using smaller + * numbers. + */ + +/* + * Prototypes + */ + /* do the hard work of mpr_add and mpr_sub */ +static void mpr_addsub(mpr *rop, mpr *op1, mpr *op2, int sub); + + /* do the hard work of mpr_cmp and mpr_cmpabs */ +static int mpr_docmp(mpr *op1, mpr *op2, int sign); + +/* + * Implementation + */ +void +mpr_init(mpr *op) +{ + op->num.digs = mp_malloc(sizeof(BNS)); + op->num.sign = 0; + op->num.size = op->num.alloc = 1; + op->num.digs[0] = 0; + + op->den.digs = mp_malloc(sizeof(BNS)); + op->den.sign = 0; + op->den.size = op->den.alloc = 1; + op->den.digs[0] = 1; +} + +void +mpr_clear(mpr *op) +{ + op->num.sign = 0; + op->num.size = op->num.alloc = 0; + mp_free(op->num.digs); + + op->den.sign = 0; + op->den.size = op->den.alloc = 0; + mp_free(op->den.digs); +} + +void +mpr_set(mpr *rop, mpr *op) +{ + if (rop != op) { + mpi_set(mpr_num(rop), mpr_num(op)); + mpi_set(mpr_den(rop), mpr_den(op)); + } +} + +void +mpr_seti(mpr *rop, long num, long den) +{ + mpi_seti(mpr_num(rop), num); + mpi_seti(mpr_den(rop), den); +} + +void +mpr_setd(mpr *rop, double d) +{ + double val, num; + int e, sign; + + /* initialize */ + if (d < 0) { + sign = 1; + val = -d; + } + else { + sign = 0; + val = d; + } + + val = frexp(val, &e); + while (modf(val, &num) != 0.0 && val <= DBL_MAX / 2.0) { + --e; + val *= 2.0; + } + if (e >= 0) { + mpi_setd(mpr_num(rop), d); + mpi_seti(mpr_den(rop), 1); + } + else { + mpi_setd(mpr_num(rop), sign ? -num : num); + mpi_setd(mpr_den(rop), ldexp(1.0, -e)); + } +} + +void +mpr_setstr(mpr *rop, char *str, int base) +{ + char *slash = strchr(str, '/'); + + mpi_setstr(mpr_num(rop), str, base); + if (slash != NULL) + mpi_setstr(mpr_den(rop), slash + 1, base); + else + mpi_seti(mpr_den(rop), 1); +} + +void +mpr_canonicalize(mpr *op) +{ + mpi gcd; + + memset(&gcd, '\0', sizeof(mpi)); + + mpi_gcd(&gcd, mpr_num(op), mpr_den(op)); + if (mpi_cmpabsi(&gcd, 1)) { + mpi_div(mpr_num(op), mpr_num(op), &gcd); + mpi_div(mpr_den(op), mpr_den(op), &gcd); + } + + if (op->den.sign) { + op->num.sign = !op->num.sign; + op->den.sign = 0; + } + + mpi_clear(&gcd); +} + +void +mpr_add(mpr *rop, mpr *op1, mpr *op2) +{ + mpr_addsub(rop, op1, op2, 0); +} + +void +mpr_addi(mpr *rop, mpr *op1, long op2) +{ + mpi prod; + + memset(&prod, '\0', sizeof(mpi)); + + mpi_muli(&prod, mpr_den(op1), op2); + mpi_add(mpr_num(rop), mpr_num(op1), &prod); + mpi_clear(&prod); +} + +void +mpr_sub(mpr *rop, mpr *op1, mpr *op2) +{ + mpr_addsub(rop, op1, op2, 1); +} + +void +mpr_subi(mpr *rop, mpr *op1, long op2) +{ + mpi prod; + + memset(&prod, '\0', sizeof(mpi)); + + mpi_muli(&prod, mpr_den(op1), op2); + mpi_sub(mpr_num(rop), mpr_num(op1), &prod); + mpi_clear(&prod); +} + +static void +mpr_addsub(mpr *rop, mpr *op1, mpr *op2, int sub) +{ + mpi prod1, prod2; + + memset(&prod1, '\0', sizeof(mpi)); + memset(&prod2, '\0', sizeof(mpi)); + + mpi_mul(&prod1, mpr_num(op1), mpr_den(op2)); + mpi_mul(&prod2, mpr_num(op2), mpr_den(op1)); + + if (sub) + mpi_sub(mpr_num(rop), &prod1, &prod2); + else + mpi_add(mpr_num(rop), &prod1, &prod2); + + mpi_clear(&prod1); + mpi_clear(&prod2); + + mpi_mul(mpr_den(rop), mpr_den(op1), mpr_den(op2)); +} + +void +mpr_mul(mpr *rop, mpr *op1, mpr *op2) +{ + /* check if temporary storage is required */ + if (op1 == op2 && rop == op1) { + mpi prod; + + memset(&prod, '\0', sizeof(mpi)); + + mpi_mul(&prod, mpr_num(op1), mpr_num(op2)); + mpi_mul(mpr_den(rop), mpr_den(op1), mpr_den(op2)); + mpi_set(mpr_num(rop), &prod); + + mpi_clear(&prod); + } + else { + mpi_mul(mpr_num(rop), mpr_num(op1), mpr_num(op2)); + mpi_mul(mpr_den(rop), mpr_den(op1), mpr_den(op2)); + } +} + +void +mpr_muli(mpr *rop, mpr *op1, long op2) +{ + mpi_muli(mpr_num(rop), mpr_num(op1), op2); +} + +void +mpr_div(mpr *rop, mpr *op1, mpr *op2) +{ + /* check if temporary storage is required */ + if (op1 == op2 && rop == op1) { + mpi prod; + + memset(&prod, '\0', sizeof(mpi)); + + mpi_mul(&prod, mpr_num(op1), mpr_den(op2)); + mpi_mul(mpr_den(rop), mpr_num(op2), mpr_den(op1)); + mpi_set(mpr_num(rop), &prod); + + mpi_clear(&prod); + } + else { + mpi_mul(mpr_num(rop), mpr_num(op1), mpr_den(op2)); + mpi_mul(mpr_den(rop), mpr_num(op2), mpr_den(op1)); + } +} + +void +mpr_divi(mpr *rop, mpr *op1, long op2) +{ + mpi_muli(mpr_den(rop), mpr_den(op1), op2); +} + +void +mpr_inv(mpr *rop, mpr *op) +{ + if (rop == op) + mpi_swap(mpr_num(op), mpr_den(op)); + else { + mpi_set(mpr_num(rop), mpr_den(op)); + mpi_set(mpr_den(rop), mpr_num(op)); + } +} + +void +mpr_neg(mpr *rop, mpr *op) +{ + mpi_neg(mpr_num(rop), mpr_num(op)); + mpi_set(mpr_den(rop), mpr_den(op)); +} + +void +mpr_abs(mpr *rop, mpr *op) +{ + if (mpr_num(op)->sign) + mpi_neg(mpr_num(rop), mpr_num(op)); + else + mpi_set(mpr_num(rop), mpr_num(op)); + + /* op may not be canonicalized */ + if (mpr_den(op)->sign) + mpi_neg(mpr_den(rop), mpr_den(op)); + else + mpi_set(mpr_den(rop), mpr_den(op)); +} + +int +mpr_cmp(mpr *op1, mpr *op2) +{ + return (mpr_docmp(op1, op2, 1)); +} + +int +mpr_cmpi(mpr *op1, long op2) +{ + int cmp; + mpr rat; + + mpr_init(&rat); + mpi_seti(mpr_num(&rat), op2); + cmp = mpr_docmp(op1, &rat, 1); + mpr_clear(&rat); + + return (cmp); +} + +int +mpr_cmpabs(mpr *op1, mpr *op2) +{ + return (mpr_docmp(op1, op2, 0)); +} + +int +mpr_cmpabsi(mpr *op1, long op2) +{ + int cmp; + mpr rat; + + mpr_init(&rat); + mpi_seti(mpr_num(&rat), op2); + cmp = mpr_docmp(op1, &rat, 0); + mpr_clear(&rat); + + return (cmp); +} + +static int +mpr_docmp(mpr *op1, mpr *op2, int sign) +{ + int cmp, neg; + mpi prod1, prod2; + + neg = 0; + if (sign) { + /* if op1 is negative */ + if (mpr_num(op1)->sign ^ mpr_den(op1)->sign) { + /* if op2 is positive */ + if (!(mpr_num(op2)->sign ^ mpr_den(op2)->sign)) + return (-1); + else + neg = 1; + } + /* if op2 is negative */ + else if (mpr_num(op2)->sign ^ mpr_den(op2)->sign) + return (1); + /* else same sign */ + } + + /* if denominators are equal, compare numerators */ + if (mpi_cmpabs(mpr_den(op1), mpr_den(op2)) == 0) { + cmp = mpi_cmpabs(mpr_num(op1), mpr_num(op2)); + if (cmp == 0) + return (0); + if (sign && neg) + return (cmp < 0 ? 1 : -1); + return (cmp); + } + + memset(&prod1, '\0', sizeof(mpi)); + memset(&prod2, '\0', sizeof(mpi)); + + /* "divide" op1 by op2 + * if result is smaller than 1, op1 is smaller than op2 */ + mpi_mul(&prod1, mpr_num(op1), mpr_den(op2)); + mpi_mul(&prod2, mpr_num(op2), mpr_den(op1)); + + cmp = mpi_cmpabs(&prod1, &prod2); + + mpi_clear(&prod1); + mpi_clear(&prod2); + + if (sign && neg) + return (cmp < 0 ? 1 : -1); + return (cmp); +} + +void +mpr_swap(mpr *op1, mpr *op2) +{ + if (op1 != op2) { + mpr swap; + + memcpy(&swap, op1, sizeof(mpr)); + memcpy(op1, op2, sizeof(mpr)); + memcpy(op2, &swap, sizeof(mpr)); + } +} + +int +mpr_fiti(mpr *op) +{ + return (mpi_fiti(mpr_num(op)) && mpi_fiti(mpr_den(op))); +} + +double +mpr_getd(mpr *op) +{ + return (mpi_getd(mpr_num(op)) / mpi_getd(mpr_den(op))); +} + +char * +mpr_getstr(char *str, mpr *op, int base) +{ + int len; + + if (str == NULL) { + len = mpi_getsize(mpr_num(op), base) + mpr_num(op)->sign + 1 + + mpi_getsize(mpr_den(op), base) + mpr_den(op)->sign + 1; + + str = mp_malloc(len); + } + + (void)mpi_getstr(str, mpr_num(op), base); + len = strlen(str); + str[len] = '/'; + (void)mpi_getstr(str + len + 1, mpr_den(op), base); + + return (str); +} diff --git a/lisp/package.c b/lisp/package.c new file mode 100644 index 0000000..c046e55 --- /dev/null +++ b/lisp/package.c @@ -0,0 +1,865 @@ +/* + * Copyright (c) 2002 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/package.c,v 1.20 2002/11/30 23:13:12 paulo Exp $ */ + +#include "package.h" +#include "private.h" + +/* + * Prototypes + */ +static int LispDoSymbol(LispObj*, LispAtom*, int, int); +static LispObj *LispReallyDoSymbols(LispBuiltin*, int, int); +static LispObj *LispDoSymbols(LispBuiltin*, int, int); +static LispObj *LispFindSymbol(LispBuiltin*, int); +static LispObj *LispFindPackageOrDie(LispBuiltin*, LispObj*); +static void LispDoExport(LispBuiltin*, LispObj*, LispObj*, int); +static void LispDoImport(LispBuiltin*, LispObj*); + +/* + * Initialization + */ +extern LispProperty *NOPROPERTY; +static LispObj *Kinternal, *Kexternal, *Kinherited; + +/* + * Implementation + */ +void +LispPackageInit(void) +{ + Kinternal = KEYWORD("INTERNAL"); + Kexternal = KEYWORD("EXTERNAL"); + Kinherited = KEYWORD("INHERITED"); +} + +LispObj * +LispFindPackageFromString(char *string) +{ + LispObj *list, *package, *nick; + + for (list = PACK; CONSP(list); list = CDR(list)) { + package = CAR(list); + if (strcmp(THESTR(package->data.package.name), string) == 0) + return (package); + for (nick = package->data.package.nicknames; + CONSP(nick); nick = CDR(nick)) + if (strcmp(THESTR(CAR(nick)), string) == 0) + return (package); + } + + return (NIL); +} + +LispObj * +LispFindPackage(LispObj *name) +{ + char *string = NULL; + + if (PACKAGEP(name)) + return (name); + + if (SYMBOLP(name)) + string = ATOMID(name); + else if (STRINGP(name)) + string = THESTR(name); + else + LispDestroy("FIND-PACKAGE: %s is not a string or symbol", STROBJ(name)); + + return (LispFindPackageFromString(string)); +} + +int +LispCheckAtomString(char *string) +{ + char *ptr; + + if (*string == '\0') + return (0); + + for (ptr = string; *ptr; ptr++) { + if (islower(*ptr) || strchr("\"\\;#()`'|:", *ptr) || + ((ptr == string || ptr[1] == '\0') && strchr(".,@", *ptr))) + return (0); + } + + return (1); +} + +/* This function is used to avoid some namespace polution caused by the + * way builtin functions are created, all function name arguments enter + * the current package, but most of them do not have a property */ +static int +LispDoSymbol(LispObj *package, LispAtom *atom, int if_extern, int all_packages) +{ + int dosymbol; + + /* condition 1: atom package is current package */ + dosymbol = !all_packages || atom->package == package; + if (dosymbol) { + /* condition 2: intern and extern symbols or symbol is extern */ + dosymbol = !if_extern || atom->ext; + if (dosymbol) { + /* condition 3: atom has properties or is in + * the current package */ + dosymbol = atom->property != NOPROPERTY || + package == lisp__data.keyword || + package == PACKAGE; + } + } + + return (dosymbol); +} + +static LispObj * +LispFindPackageOrDie(LispBuiltin *builtin, LispObj *name) +{ + LispObj *package; + + package = LispFindPackage(name); + + if (package == NIL) + LispDestroy("%s: package %s is not available", + STRFUN(builtin), STROBJ(name)); + + return (package); +} + +/* package must be of type LispPackage_t, symbol type is checked + bypass lisp.c:LispExportSymbol() */ +static void +LispDoExport(LispBuiltin *builtin, + LispObj *package, LispObj *symbol, int export) +{ + CHECK_SYMBOL(symbol); + if (!export) { + if (package == lisp__data.keyword || + symbol->data.atom->package == lisp__data.keyword) + LispDestroy("%s: symbol %s cannot be unexported", + STRFUN(builtin), STROBJ(symbol)); + } + + if (package == PACKAGE) + symbol->data.atom->ext = export ? 1 : 0; + else { + int i; + char *string; + LispAtom *atom; + LispPackage *pack; + + string = ATOMID(symbol); + pack = package->data.package.package; + i = STRHASH(string); + atom = pack->atoms[i]; + while (atom) { + if (strcmp(atom->string, string) == 0) { + atom->ext = export ? 1 : 0; + return; + } + + atom = atom->next; + } + + LispDestroy("%s: the symbol %s is not available in package %s", + STRFUN(builtin), STROBJ(symbol), + THESTR(package->data.package.name)); + } +} + +static void +LispDoImport(LispBuiltin *builtin, LispObj *symbol) +{ + CHECK_SYMBOL(symbol); + LispImportSymbol(symbol); +} + +static LispObj * +LispReallyDoSymbols(LispBuiltin *builtin, int only_externs, int all_symbols) +{ + int i, head = lisp__data.env.length; + LispPackage *pack = NULL; + LispAtom *atom, *next_atom; + LispObj *variable, *package = NULL, *list, *code, *result_form; + + LispObj *init, *body; + + body = ARGUMENT(1); + init = ARGUMENT(0); + + /* Prepare for loop */ + CHECK_CONS(init); + variable = CAR(init); + CHECK_SYMBOL(variable); + + if (!all_symbols) { + /* if all_symbols, a package name is not specified in the init form */ + + init = CDR(init); + if (!CONSP(init)) + LispDestroy("%s: missing package name", STRFUN(builtin)); + + /* Evaluate package specification */ + package = EVAL(CAR(init)); + if (!PACKAGEP(package)) + package = LispFindPackageOrDie(builtin, package); + + pack = package->data.package.package; + } + + result_form = NIL; + + init = CDR(init); + if (CONSP(init)) + result_form = init; + + /* Initialize iteration variable */ + CHECK_CONSTANT(variable); + LispAddVar(variable, NIL); + ++lisp__data.env.head; + + for (list = PACK; CONSP(list); list = CDR(list)) { + if (all_symbols) { + package = CAR(list); + pack = package->data.package.package; + } + + /* Traverse the symbol list, executing body */ + for (i = 0; i < STRTBLSZ; i++) { + atom = pack->atoms[i]; + while (atom) { + /* Save pointer to next atom. If variable is removed, + * predicatable result is only guaranteed if the bound + * variable is removed. */ + next_atom = atom->next; + + if (LispDoSymbol(package, atom, only_externs, all_symbols)) { + LispSetVar(variable, atom->object); + for (code = body; CONSP(code); code = CDR(code)) + EVAL(CAR(code)); + } + + atom = next_atom; + } + } + + if (!all_symbols) + break; + } + + /* Variable is still bound */ + for (code = result_form; CONSP(code); code = CDR(code)) + EVAL(CAR(code)); + + lisp__data.env.head = lisp__data.env.length = head; + + return (NIL); +} + +static LispObj * +LispDoSymbols(LispBuiltin *builtin, int only_externs, int all_symbols) +{ + int did_jump, *pdid_jump = &did_jump; + LispObj *result, **presult = &result; + LispBlock *block; + + *presult = NIL; + *pdid_jump = 1; + block = LispBeginBlock(NIL, LispBlockTag); + if (setjmp(block->jmp) == 0) { + *presult = LispReallyDoSymbols(builtin, only_externs, all_symbols); + *pdid_jump = 0; + } + LispEndBlock(block); + if (*pdid_jump) + *presult = lisp__data.block.block_ret; + + return (*presult); +} + +LispObj * +LispFindSymbol(LispBuiltin *builtin, int intern) +{ + int i; + char *ptr; + LispAtom *atom; + LispObj *symbol; + LispPackage *pack; + + LispObj *string, *package; + + package = ARGUMENT(1); + string = ARGUMENT(0); + + CHECK_STRING(string); + if (package != UNSPEC) + package = LispFindPackageOrDie(builtin, package); + else + package = PACKAGE; + + /* If got here, package is a LispPackage_t */ + pack = package->data.package.package; + + /* Search symbol in specified package */ + ptr = THESTR(string); + + RETURN_COUNT = 1; + + symbol = NULL; + /* Fix for current behaviour where NIL and T aren't symbols... */ + if (STRLEN(string) == 3 && memcmp(ptr, "NIL", 3) == 0) + symbol = NIL; + else if (STRLEN(string) == 1 && ptr[0] == 'T') + symbol = T; + if (symbol) { + RETURN(0) = NIL; + return (symbol); + } + + i = STRHASH(ptr); + atom = pack->atoms[i]; + while (atom) { + if (strcmp(atom->string, ptr) == 0) { + symbol = atom->object; + break; + } + atom = atom->next; + } + + if (symbol == NULL || symbol->data.atom->package == NULL) { + RETURN(0) = NIL; + if (intern) { + /* symbol does not exist in the specified package, create a new + * internal symbol */ + + if (package == PACKAGE) + symbol = ATOM(ptr); + else { + LispPackage *savepack; + LispObj *savepackage; + + /* Save package environment */ + savepackage = PACKAGE; + savepack = lisp__data.pack; + + /* Change package environment */ + PACKAGE = package; + lisp__data.pack = package->data.package.package; + + symbol = ATOM(ptr); + + /* Restore package environment */ + PACKAGE = savepackage; + lisp__data.pack = savepack; + } + + symbol->data.atom->unreadable = !LispCheckAtomString(ptr); + /* If symbol being create in the keyword package, make it external */ + if (package == lisp__data.keyword) + symbol->data.atom->ext = symbol->data.atom->constant = 1; + } + else + symbol = NIL; + } + else { + if (symbol->data.atom->package == package) + RETURN(0) = symbol->data.atom->ext ? Kexternal : Kinternal; + else + RETURN(0) = Kinherited; + } + + return (symbol); +} + + +LispObj * +Lisp_DoAllSymbols(LispBuiltin *builtin) +/* + do-all-symbols init &rest body + */ +{ + return (LispDoSymbols(builtin, 0, 1)); +} + +LispObj * +Lisp_DoExternalSymbols(LispBuiltin *builtin) +/* + do-external-symbols init &rest body + */ +{ + return (LispDoSymbols(builtin, 1, 0)); +} + +LispObj * +Lisp_DoSymbols(LispBuiltin *builtin) +/* + do-symbols init &rest body + */ +{ + return (LispDoSymbols(builtin, 0, 0)); +} + +LispObj * +Lisp_FindAllSymbols(LispBuiltin *builtin) +/* + find-all-symbols string-or-symbol + */ +{ + GC_ENTER(); + char *string = NULL; + LispAtom *atom; + LispPackage *pack; + LispObj *list, *package, *result; + int i; + + LispObj *string_or_symbol; + + string_or_symbol = ARGUMENT(0); + + if (STRINGP(string_or_symbol)) + string = THESTR(string_or_symbol); + else if (SYMBOLP(string_or_symbol)) + string = ATOMID(string_or_symbol); + else + LispDestroy("%s: %s is not a string or symbol", + STRFUN(builtin), STROBJ(string_or_symbol)); + + result = NIL; + i = STRHASH(string); + + /* Traverse all packages, searching for symbols matching specified string */ + for (list = PACK; CONSP(list); list = CDR(list)) { + package = CAR(list); + pack = package->data.package.package; + + atom = pack->atoms[i]; + while (atom) { + if (strcmp(atom->string, string) == 0 && + LispDoSymbol(package, atom, 0, 1)) { + /* Return only one pointer to a matching symbol */ + + if (result == NIL) { + result = CONS(atom->object, NIL); + GC_PROTECT(result); + } + else { + /* Put symbols defined first in the + * beginning of the result list */ + RPLACD(result, CONS(CAR(result), CDR(result))); + RPLACA(result, atom->object); + } + } + atom = atom->next; + } + } + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_FindSymbol(LispBuiltin *builtin) +/* + find-symbol string &optional package + */ +{ + return (LispFindSymbol(builtin, 0)); +} + +LispObj * +Lisp_FindPackage(LispBuiltin *builtin) +/* + find-package name + */ +{ + LispObj *name; + + name = ARGUMENT(0); + + return (LispFindPackage(name)); +} + +LispObj * +Lisp_Export(LispBuiltin *builtin) +/* + export symbols &optional package + */ +{ + LispObj *list; + + LispObj *symbols, *package; + + package = ARGUMENT(1); + symbols = ARGUMENT(0); + + /* If specified, make sure package is available */ + if (package != UNSPEC) + package = LispFindPackageOrDie(builtin, package); + else + package = PACKAGE; + + /* Export symbols */ + if (CONSP(symbols)) { + for (list = symbols; CONSP(list); list = CDR(list)) + LispDoExport(builtin, package, CAR(list), 1); + } + else + LispDoExport(builtin, package, symbols, 1); + + return (T); +} + +LispObj * +Lisp_Import(LispBuiltin *builtin) +/* + import symbols &optional package + */ +{ + int restore_package; + LispPackage *savepack = NULL; + LispObj *list, *savepackage = NULL; + + LispObj *symbols, *package; + + package = ARGUMENT(1); + symbols = ARGUMENT(0); + + /* If specified, make sure package is available */ + if (package != UNSPEC) + package = LispFindPackageOrDie(builtin, package); + else + package = PACKAGE; + + restore_package = package != PACKAGE; + if (restore_package) { + /* Save package environment */ + savepackage = PACKAGE; + savepack = lisp__data.pack; + + /* Change package environment */ + PACKAGE = package; + lisp__data.pack = package->data.package.package; + } + + /* Export symbols */ + if (CONSP(symbols)) { + for (list = symbols; CONSP(list); list = CDR(list)) + LispDoImport(builtin, CAR(list)); + } + else + LispDoImport(builtin, symbols); + + if (restore_package) { + /* Restore package environment */ + PACKAGE = savepackage; + lisp__data.pack = savepack; + } + + return (T); +} + +LispObj * +Lisp_InPackage(LispBuiltin *builtin) +/* + in-package name + */ +{ + LispObj *package; + + LispObj *name; + + name = ARGUMENT(0); + + package = LispFindPackageOrDie(builtin, name); + + /* Update pointer to package symbol table */ + lisp__data.pack = package->data.package.package; + PACKAGE = package; + + return (package); +} + +LispObj * +Lisp_Intern(LispBuiltin *builtin) +/* + intern string &optional package + */ +{ + return (LispFindSymbol(builtin, 1)); +} + +LispObj * +Lisp_ListAllPackages(LispBuiltin *builtin) +/* + list-all-packages + */ +{ + /* Maybe this should be read-only or a copy of the package list. + * But, if properly implemented, it should be possible to (rplaca) + * this variable from lisp code with no problems. Don't do it at home. */ + + return (PACK); +} + +LispObj * +Lisp_MakePackage(LispBuiltin *builtin) +/* + make-package package-name &key nicknames use + */ +{ + GC_ENTER(); + LispObj *list, *package, *nicks, *cons, *savepackage; + + LispObj *package_name, *nicknames, *use; + + use = ARGUMENT(2); + nicknames = ARGUMENT(1); + package_name = ARGUMENT(0); + + /* Check if package already exists */ + package = LispFindPackage(package_name); + if (package != NIL) + /* FIXME: this should be a correctable error */ + LispDestroy("%s: package %s already defined", + STRFUN(builtin), STROBJ(package_name)); + + /* Error checks done, package_name is either a symbol or string */ + if (!XSTRINGP(package_name)) + package_name = STRING(ATOMID(package_name)); + + GC_PROTECT(package_name); + + /* Check nicknames */ + nicks = cons = NIL; + for (list = nicknames; CONSP(list); list = CDR(list)) { + package = LispFindPackage(CAR(list)); + if (package != NIL) + /* FIXME: this should be a correctable error */ + LispDestroy("%s: nickname %s matches package %s", + STRFUN(builtin), STROBJ(CAR(list)), + THESTR(package->data.package.name)); + /* Store all nicknames as strings */ + package = CAR(list); + if (!XSTRINGP(package)) + package = STRING(ATOMID(package)); + if (nicks == NIL) { + nicks = cons = CONS(package, NIL); + GC_PROTECT(nicks); + } + else { + RPLACD(cons, CONS(package, NIL)); + cons = CDR(cons); + } + } + + /* Check use list */ + for (list = use; CONSP(list); list = CDR(list)) + (void)LispFindPackageOrDie(builtin, CAR(list)); + + /* No errors, create new package */ + package = LispNewPackage(package_name, nicks); + + /* Update list of packages */ + PACK = CONS(package, PACK); + + /* No need for gc protection anymore */ + GC_LEAVE(); + + /* Import symbols from use list */ + savepackage = PACKAGE; + + /* Update pointer to package symbol table */ + lisp__data.pack = package->data.package.package; + PACKAGE = package; + + if (use != UNSPEC) { + for (list = use; CONSP(list); list = CDR(list)) + LispUsePackage(LispFindPackage(CAR(list))); + } + else + LispUsePackage(lisp__data.lisp); + + /* Restore pointer to package symbol table */ + lisp__data.pack = savepackage->data.package.package; + PACKAGE = savepackage; + + return (package); +} + +LispObj * +Lisp_Packagep(LispBuiltin *builtin) +/* + packagep object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (PACKAGEP(object) ? T : NIL); +} + +LispObj * +Lisp_PackageName(LispBuiltin *builtin) +/* + package-name package + */ +{ + LispObj *package; + + package = ARGUMENT(0); + + package = LispFindPackageOrDie(builtin, package); + + return (package->data.package.name); +} + +LispObj * +Lisp_PackageNicknames(LispBuiltin *builtin) +/* + package-nicknames package + */ +{ + LispObj *package; + + package = ARGUMENT(0); + + package = LispFindPackageOrDie(builtin, package); + + return (package->data.package.nicknames); +} + +LispObj * +Lisp_PackageUseList(LispBuiltin *builtin) +/* + package-use-list package + */ +{ + /* If the variable returned by this function is expected to be changeable, + * need to change the layout of the LispPackage structure. */ + + LispPackage *pack; + LispObj *package, *use, *cons; + + package = ARGUMENT(0); + + package = LispFindPackageOrDie(builtin, package); + + use = cons = NIL; + pack = package->data.package.package; + + if (pack->use.length) { + GC_ENTER(); + int i = pack->use.length - 1; + + use = cons = CONS(pack->use.pairs[i], NIL); + GC_PROTECT(use); + for (--i; i >= 0; i--) { + RPLACD(cons, CONS(pack->use.pairs[i], NIL)); + cons = CDR(cons); + } + GC_LEAVE(); + } + + return (use); +} + +LispObj * +Lisp_PackageUsedByList(LispBuiltin *builtin) +/* + package-used-by-list package + */ +{ + GC_ENTER(); + int i; + LispPackage *pack; + LispObj *package, *other, *used, *cons, *list; + + package = ARGUMENT(0); + + package = LispFindPackageOrDie(builtin, package); + + used = cons = NIL; + + for (list = PACK; CONSP(list); list = CDR(list)) { + other = CAR(list); + if (package == other) + /* Surely package uses itself */ + continue; + + pack = other->data.package.package; + + for (i = 0; i < pack->use.length; i++) { + if (pack->use.pairs[i] == package) { + if (used == NIL) { + used = cons = CONS(other, NIL); + GC_PROTECT(used); + } + else { + RPLACD(cons, CONS(other, NIL)); + cons = CDR(cons); + } + } + } + } + + GC_LEAVE(); + + return (used); +} + +LispObj * +Lisp_Unexport(LispBuiltin *builtin) +/* + unexport symbols &optional package + */ +{ + LispObj *list; + + LispObj *symbols, *package; + + package = ARGUMENT(1); + symbols = ARGUMENT(0); + + /* If specified, make sure package is available */ + if (package != UNSPEC) + package = LispFindPackageOrDie(builtin, package); + else + package = PACKAGE; + + /* Export symbols */ + if (CONSP(symbols)) { + for (list = symbols; CONSP(list); list = CDR(list)) + LispDoExport(builtin, package, CAR(list), 0); + } + else + LispDoExport(builtin, package, symbols, 0); + + return (T); +} diff --git a/lisp/package.h b/lisp/package.h new file mode 100644 index 0000000..23ad822 --- /dev/null +++ b/lisp/package.h @@ -0,0 +1,62 @@ +/* + * Copyright (c) 2002 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/package.h,v 1.7 2002/11/26 04:06:28 paulo Exp $ */ + +#ifndef Lisp_package_h +#define Lisp_package_h + +#include "internal.h" + +void LispPackageInit(void); +LispObj *LispFindPackage(LispObj*); +LispObj *LispFindPackageFromString(char*); +/* returns 1 if string can safely be read back */ +int LispCheckAtomString(char*); + +LispObj *Lisp_DoAllSymbols(LispBuiltin*); +LispObj *Lisp_DoExternalSymbols(LispBuiltin*); +LispObj *Lisp_DoSymbols(LispBuiltin*); +LispObj *Lisp_FindAllSymbols(LispBuiltin*); +LispObj *Lisp_FindPackage(LispBuiltin*); +LispObj *Lisp_FindSymbol(LispBuiltin*); +LispObj *Lisp_Export(LispBuiltin*); +LispObj *Lisp_Import(LispBuiltin*); +LispObj *Lisp_InPackage(LispBuiltin*); +LispObj *Lisp_Intern(LispBuiltin*); +LispObj *Lisp_ListAllPackages(LispBuiltin*); +LispObj *Lisp_MakePackage(LispBuiltin*); +LispObj *Lisp_Packagep(LispBuiltin*); +LispObj *Lisp_PackageName(LispBuiltin*); +LispObj *Lisp_PackageNicknames(LispBuiltin*); +LispObj *Lisp_PackageUseList(LispBuiltin*); +LispObj *Lisp_PackageUsedByList(LispBuiltin*); +LispObj *Lisp_Unexport(LispBuiltin*); + +#endif /* Lisp_package_h */ diff --git a/lisp/pathname.c b/lisp/pathname.c new file mode 100644 index 0000000..6af8cd1 --- /dev/null +++ b/lisp/pathname.c @@ -0,0 +1,1096 @@ +/* + * 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/pathname.c,v 1.17 2002/12/24 00:25:39 dawes Exp $ */ + +#include <stdio.h> /* including dirent.h first may cause problems */ +#include <sys/types.h> +#include <dirent.h> +#include <errno.h> +#include <sys/stat.h> +#include "pathname.h" +#include "private.h" + +#define NOREAD_SKIP 0 +#define NOREAD_ERROR 1 + +/* + * Initialization + */ +LispObj *Oparse_namestring, *Kerror, *Kabsolute, *Krelative, *Kskip; + +/* + * Implementation + */ +void +LispPathnameInit(void) +{ + Kerror = KEYWORD("ERROR"); + Oparse_namestring = STATIC_ATOM("PARSE-NAMESTRING"); + Kabsolute = KEYWORD("ABSOLUTE"); + Krelative = KEYWORD("RELATIVE"); +} + +static int +glob_match(char *cmp1, char *cmp2) +/* + * Note: this code was written from scratch, and may generate incorrect + * results for very complex glob masks. + */ +{ + for (;;) { + while (*cmp1 && *cmp1 == *cmp2) { + ++cmp1; + ++cmp2; + } + if (*cmp2) { + if (*cmp1 == '*') { + while (*cmp1 == '*') + ++cmp1; + if (*cmp1) { + int count = 0, settmp = 1; + char *tmp = cmp2, *sav2; + + while (*cmp1 && *cmp1 == '?') { + ++cmp1; + ++count; + } + + /* need to recurse here to make sure + * all cases are tested. + */ + while (*cmp2 && *cmp2 != *cmp1) + ++cmp2; + if (!*cmp1 && cmp2 - tmp < count) + return (0); + sav2 = cmp2; + + /* if recursive calls fails, make sure all '?' + * following '*' are processed */ + while (*sav2 && sav2 - tmp < count) + ++sav2; + + for (; *cmp2;) { + if (settmp) /* repeated letters: *?o? => boot, root */ + tmp = cmp2; + else + settmp = 1; + while (*cmp2 && *cmp2 != *cmp1) + ++cmp2; + if (cmp2 - tmp < count) { + if (*cmp2) + ++cmp2; + settmp = 0; + continue; + } + if (*cmp2) { + if (glob_match(cmp1, cmp2)) + return (1); + ++cmp2; + } + } + cmp2 = sav2; + } + else { + while (*cmp2) + ++cmp2; + break; + } + } + else if (*cmp1 == '?') { + while (*cmp1 == '?' && *cmp2) { + ++cmp1; + ++cmp2; + } + continue; + } + else + break; + } + else { + while (*cmp1 == '*') + ++cmp1; + break; + } + } + + return (*cmp1 == '\0' && *cmp2 == '\0'); +} + +/* + * Since directory is a function to be extended by the implementation, + * current extensions are: + * all => list files and directories + * it is an error to call + * (directory "<pathname-spec>/" :all t) + * if non nil, it is like the shell command + * echo <pathname-spec>, but normally, not in the + * same order, as the code does not sort the result. + * !=nil => list files and directories + * (default) nil => list only files, or only directories if + * <pathname-spec> ends with PATH_SEP char. + * if-cannot-read => if opendir fails on a directory + * :error => generate an error + * (default) :skip => skip search in this directory + */ +LispObj * +Lisp_Directory(LispBuiltin *builtin) +/* + directory pathname &key all if-cannot-read + */ +{ + GC_ENTER(); + DIR *dir; + struct stat st; + struct dirent *ent; + int length, listdirs, i, ndirs, nmatches; + char name[PATH_MAX + 1], path[PATH_MAX + 2], directory[PATH_MAX + 2]; + char *sep, *base, *ptr, **dirs, **matches, + dot[] = {'.', PATH_SEP, '\0'}, + dotdot[] = {'.', '.', PATH_SEP, '\0'}; + int cannot_read; + + LispObj *pathname, *all, *if_cannot_read, *result, *cons, *object; + + if_cannot_read = ARGUMENT(2); + all = ARGUMENT(1); + pathname = ARGUMENT(0); + result = NIL; + + cons = NIL; + + if (if_cannot_read != UNSPEC) { + if (!KEYWORDP(if_cannot_read) || + (if_cannot_read != Kskip && + if_cannot_read != Kerror)) + LispDestroy("%s: bad :IF-CANNOT-READ %s", + STRFUN(builtin), STROBJ(if_cannot_read)); + if (if_cannot_read != Kskip) + cannot_read = NOREAD_SKIP; + else + cannot_read = NOREAD_ERROR; + } + else + cannot_read = NOREAD_SKIP; + + if (PATHNAMEP(pathname)) + pathname = CAR(pathname->data.pathname); + else if (STREAMP(pathname) && pathname->data.stream.type == LispStreamFile) + pathname = CAR(pathname->data.stream.pathname->data.pathname); + else if (!STRINGP(pathname)) + LispDestroy("%s: %s is not a pathname", + STRFUN(builtin), STROBJ(pathname)); + + strncpy(name, THESTR(pathname), sizeof(name) - 1); + name[sizeof(name) - 1] = '\0'; + length = strlen(name); + if (length < STRLEN(pathname)) + LispDestroy("%s: pathname too long %s", + STRFUN(builtin), name); + + if (length == 0) { + if (getcwd(path, sizeof(path) - 2) == NULL) + LispDestroy("%s: getcwd(): %s", STRFUN(builtin), strerror(errno)); + length = strlen(path); + if (!length || path[length - 1] != PATH_SEP) { + path[length++] = PATH_SEP; + path[length] = '\0'; + } + result = APPLY1(Oparse_namestring, LSTRING(path, length)); + GC_LEAVE(); + + return (result); + } + + if (name[length - 1] == PATH_SEP) { + listdirs = 1; + if (length > 1) { + --length; + name[length] = '\0'; + } + } + else + listdirs = 0; + + if (name[0] != PATH_SEP) { + if (getcwd(path, sizeof(path) - 2) == NULL) + LispDestroy("%s: getcwd(): %s", STRFUN(builtin), strerror(errno)); + length = strlen(path); + if (!length || path[length - 1] != PATH_SEP) { + path[length++] = PATH_SEP; + path[length] = '\0'; + } + } + else + path[0] = '\0'; + + result = NIL; + + /* list intermediate directories */ + matches = NULL; + nmatches = 0; + dirs = LispMalloc(sizeof(char*)); + ndirs = 1; + if (snprintf(directory, sizeof(directory), "%s%s%c", + path, name, PATH_SEP) > PATH_MAX) + LispDestroy("%s: pathname too long %s", STRFUN(builtin), directory); + + /* Remove ../ */ + sep = directory; + for (sep = strstr(sep, dotdot); sep; sep = strstr(sep, dotdot)) { + if (sep <= directory + 1) + strcpy(directory, sep + 2); + else if (sep[-1] == PATH_SEP) { + for (base = sep - 2; base > directory; base--) + if (*base == PATH_SEP) + break; + strcpy(base, sep + 2); + sep = base; + } + else + ++sep; + } + + /* Remove "./" */ + sep = directory; + for (sep = strstr(sep, dot); sep; sep = strstr(sep, dot)) { + if (sep == directory || sep[-1] == PATH_SEP) + strcpy(sep, sep + 2); + else + ++sep; + } + + /* This will happen when there are too many '../' in the path */ + if (directory[1] == '\0') { + directory[1] = PATH_SEP; + directory[2] = '\0'; + } + + base = directory; + sep = strchr(base + 1, PATH_SEP); + dirs[0] = LispMalloc(2); + dirs[0][0] = PATH_SEP; + dirs[0][1] = '\0'; + + for (base = directory + 1, sep = strchr(base, PATH_SEP); ; + base = sep + 1, sep = strchr(base, PATH_SEP)) { + *sep = '\0'; + if (sep[1] == '\0') + sep = NULL; + length = strlen(base); + if (length == 0) { + if (sep) + *sep = PATH_SEP; + else + break; + continue; + } + + for (i = 0; i < ndirs; i++) { + length = strlen(dirs[i]); + if (length > 1) + dirs[i][length - 1] = '\0'; /* remove trailing / */ + if ((dir = opendir(dirs[i])) != NULL) { + (void)readdir(dir); /* "." */ + (void)readdir(dir); /* ".." */ + if (length > 1) + dirs[i][length - 1] = PATH_SEP; /* add trailing / again */ + + snprintf(path, sizeof(path), "%s", dirs[i]); + length = strlen(path); + ptr = path + length; + + while ((ent = readdir(dir)) != NULL) { + int isdir; + unsigned d_namlen = strlen(ent->d_name); + + if (length + d_namlen + 2 < sizeof(path)) + strcpy(ptr, ent->d_name); + else { + closedir(dir); + LispDestroy("%s: pathname too long %s", + STRFUN(builtin), dirs[i]); + } + + if (stat(path, &st) != 0) + isdir = 0; + else + isdir = S_ISDIR(st.st_mode); + + if (all != UNSPEC || ((isdir && (listdirs || sep)) || + (!listdirs && !sep && !isdir))) { + if (glob_match(base, ent->d_name)) { + if (isdir) { + length = strlen(ptr); + ptr[length++] = PATH_SEP; + ptr[length] = '\0'; + } + /* XXX won't closedir on memory allocation failure! */ + matches = LispRealloc(matches, sizeof(char*) * + nmatches + 1); + matches[nmatches++] = LispStrdup(ptr); + } + } + } + closedir(dir); + + if (nmatches == 0) { + if (sep || !listdirs || *base) { + LispFree(dirs[i]); + if (i + 1 < ndirs) + memmove(dirs + i, dirs + i + 1, + sizeof(char*) * (ndirs - (i + 1))); + --ndirs; + --i; /* XXX playing with for loop */ + } + } + else { + int j; + + length = strlen(dirs[i]); + if (nmatches > 1) { + dirs = LispRealloc(dirs, sizeof(char*) * + (ndirs + nmatches)); + if (i + 1 < ndirs) + memmove(dirs + i + nmatches, dirs + i + 1, + sizeof(char*) * (ndirs - (i + 1))); + } + for (j = 1; j < nmatches; j++) { + dirs[i + j] = LispMalloc(length + + strlen(matches[j]) + 1); + sprintf(dirs[i + j], "%s%s", dirs[i], matches[j]); + } + dirs[i] = LispRealloc(dirs[i], + length + strlen(matches[0]) + 1); + strcpy(dirs[i] + length, matches[0]); + i += nmatches - 1; /* XXX playing with for loop */ + ndirs += nmatches - 1; + + for (j = 0; j < nmatches; j++) + LispFree(matches[j]); + LispFree(matches); + matches = NULL; + nmatches = 0; + } + } + else { + if (cannot_read == NOREAD_ERROR) + LispDestroy("%s: opendir(%s): %s", + STRFUN(builtin), dirs[i], strerror(errno)); + else { + LispFree(dirs[i]); + if (i + 1 < ndirs) + memmove(dirs + i, dirs + i + 1, + sizeof(char*) * (ndirs - (i + 1))); + --ndirs; + --i; /* XXX playing with for loop */ + } + } + } + if (sep) + *sep = PATH_SEP; + else + break; + } + + for (i = 0; i < ndirs; i++) { + object = APPLY1(Oparse_namestring, STRING2(dirs[i])); + if (result == NIL) { + result = cons = CONS(object, NIL); + GC_PROTECT(result); + } + else { + RPLACD(cons, CONS(object, NIL)); + cons = CDR(cons); + } + } + LispFree(dirs); + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_ParseNamestring(LispBuiltin *builtin) +/* + parse-namestring object &optional host defaults &key start end junk-allowed + */ +{ + GC_ENTER(); + LispObj *result; + + LispObj *object, *host, *defaults, *ostart, *oend, *junk_allowed; + + junk_allowed = ARGUMENT(5); + oend = ARGUMENT(4); + ostart = ARGUMENT(3); + defaults = ARGUMENT(2); + host = ARGUMENT(1); + object = ARGUMENT(0); + + if (host == UNSPEC) + host = NIL; + if (defaults == UNSPEC) + defaults = NIL; + + RETURN_COUNT = 1; + if (STREAMP(object)) { + if (object->data.stream.type == LispStreamFile) + object = object->data.stream.pathname; + /* else just check for JUNK-ALLOWED... */ + } + if (PATHNAMEP(object)) { + RETURN(0) = FIXNUM(0); + return (object); + } + + if (host != NIL) { + CHECK_STRING(host); + } + if (defaults != NIL) { + if (!PATHNAMEP(defaults)) { + defaults = APPLY1(Oparse_namestring, defaults); + GC_PROTECT(defaults); + } + } + + result = NIL; + if (STRINGP(object)) { + LispObj *cons, *cdr; + char *name = THESTR(object), *ptr, *str, data[PATH_MAX + 1], + string[PATH_MAX + 1], *namestr, *typestr, *send; + long start, end, length, alength, namelen, typelen; + + LispCheckSequenceStartEnd(builtin, object, ostart, oend, + &start, &end, &length); + alength = end - start; + + if (alength > sizeof(data) - 1) + LispDestroy("%s: string %s too large", + STRFUN(builtin), STROBJ(object)); + memcpy(data, name + start, alength); +#ifndef KEEP_EXTRA_PATH_SEP + ptr = data; + send = ptr + alength; + while (ptr < send) { + if (*ptr++ == PATH_SEP) { + for (str = ptr; str < send && *str == PATH_SEP; str++) + ; + if (str - ptr) { + memmove(ptr, str, alength - (str - data)); + alength -= str - ptr; + send -= str - ptr; + } + } + } +#endif + data[alength] = '\0'; + memcpy(string, data, alength + 1); + + if (PATHNAMEP(defaults)) + defaults = defaults->data.pathname; + + /* string name */ + result = cons = CONS(NIL, NIL); + GC_PROTECT(result); + + /* host */ + if (defaults != NIL) + defaults = CDR(defaults); + cdr = defaults == NIL ? NIL : CAR(defaults); + RPLACD(cons, CONS(cdr, NIL)); + cons = CDR(cons); + + /* device */ + if (defaults != NIL) + defaults = CDR(defaults); + cdr = defaults == NIL ? NIL : CAR(defaults); + RPLACD(cons, CONS(cdr, NIL)); + cons = CDR(cons); + + /* directory */ + if (defaults != NIL) + defaults = CDR(defaults); + if (*data == PATH_SEP) + cdr = CONS(Kabsolute, NIL); + else + cdr = CONS(Krelative, NIL); + RPLACD(cons, CONS(cdr, NIL)); + cons = CDR(cons); + /* directory components */ + ptr = data; + send = data + alength; + if (*ptr == PATH_SEP) + ++ptr; + for (str = ptr; str < send; str++) { + if (*str == PATH_SEP) + break; + } + while (str < send) { + *str++ = '\0'; + if (str - ptr > NAME_MAX) + LispDestroy("%s: directory name too long %s", + STRFUN(builtin), ptr); + RPLACD(cdr, CONS(LSTRING(ptr, str - ptr - 1), NIL)); + cdr = CDR(cdr); + for (ptr = str; str < send; str++) { + if (*str == PATH_SEP) + break; + } + } + if (str - ptr > NAME_MAX) + LispDestroy("%s: file name too long %s", STRFUN(builtin), ptr); + if (CAAR(cons) == Krelative && + defaults != NIL && CAAR(defaults) == Kabsolute) { + /* defaults specify directory and pathname doesn't */ + char *tstring; + long dlength, tlength; + LispObj *dir = CDAR(defaults); + + for (dlength = 1; CONSP(dir); dir = CDR(dir)) + dlength += STRLEN(CAR(dir)) + 1; + if (alength + dlength < PATH_MAX) { + memmove(data + dlength, data, alength + 1); + memmove(string + dlength, string, alength + 1); + alength += dlength; + ptr += dlength; + send += dlength; + CAAR(cons) = Kabsolute; + for (dir = CDAR(defaults), cdr = CAR(cons); + CONSP(dir); + dir = CDR(dir)) { + RPLACD(cdr, CONS(CAR(dir), CDR(cdr))); + cdr = CDR(cdr); + } + dir = CDAR(defaults); + data[0] = string[0] = PATH_SEP; + for (dlength = 1; CONSP(dir); dir = CDR(dir)) { + tstring = THESTR(CAR(dir)); + tlength = STRLEN(CAR(dir)); + memcpy(data + dlength, tstring, tlength); + memcpy(string + dlength, tstring, tlength); + dlength += tlength; + data[dlength] = string[dlength] = PATH_SEP; + ++dlength; + } + } + } + + /* name */ + if (defaults != NIL) + defaults = CDR(defaults); + cdr = defaults == NIL ? NIL : CAR(defaults); + for (typelen = 0, str = ptr; str < send; str++) { + if (*str == PATH_TYPESEP) { + typelen = 1; + break; + } + } + if (*ptr) + cdr = LSTRING(ptr, str - ptr); + if (STRINGP(cdr)) { + namestr = THESTR(cdr); + namelen = STRLEN(cdr); + } + else { + namestr = ""; + namelen = 0; + } + RPLACD(cons, CONS(cdr, NIL)); + cons = CDR(cons); + + /* type */ + if (defaults != NIL) + defaults = CDR(defaults); + cdr = defaults == NIL ? NIL : CAR(defaults); + ptr = str + typelen; + if (*ptr) + cdr = LSTRING(ptr, send - ptr); + if (STRINGP(cdr)) { + typestr = THESTR(cdr); + typelen = STRLEN(cdr); + } + else { + typestr = ""; + typelen = 0; + } + RPLACD(cons, CONS(cdr, NIL)); + cons = CDR(cons); + + /* version */ + if (defaults != NIL) + defaults = CDR(defaults); + cdr = defaults == NIL ? NIL : CAR(defaults); + RPLACD(cons, CONS(cdr, NIL)); + + /* string representation, must be done here to use defaults */ + for (ptr = string + alength; ptr >= string; ptr--) { + if (*ptr == PATH_SEP) + break; + } + if (ptr >= string) + ++ptr; + else + ptr = string; + *ptr = '\0'; + + length = ptr - string; + + alength = namelen; + if (alength) { + if (length + alength + 2 > sizeof(string)) + alength = sizeof(string) - length - 2; + memcpy(string + length, namestr, alength); + length += alength; + } + + alength = typelen; + if (alength) { + if (length + 2 < sizeof(string)) + string[length++] = PATH_TYPESEP; + if (length + alength + 2 > sizeof(string)) + alength = sizeof(string) - length - 2; + memcpy(string + length, typestr, alength); + length += alength; + } + string[length] = '\0'; + + RPLACA(result, LSTRING(string, length)); + RETURN(0) = FIXNUM(end); + + result = PATHNAME(result); + } + else if (junk_allowed == UNSPEC || junk_allowed == NIL) + LispDestroy("%s: bad argument %s", STRFUN(builtin), STROBJ(object)); + else + RETURN(0) = NIL; + + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_MakePathname(LispBuiltin *builtin) +/* + make-pathname &key host device directory name type version defaults + */ +{ + GC_ENTER(); + int length, alength; + char *string, pathname[PATH_MAX + 1]; + LispObj *result, *cdr, *cons; + + LispObj *host, *device, *directory, *name, *type, *version, *defaults; + + defaults = ARGUMENT(6); + version = ARGUMENT(5); + type = ARGUMENT(4); + name = ARGUMENT(3); + directory = ARGUMENT(2); + device = ARGUMENT(1); + host = ARGUMENT(0); + + if (host != UNSPEC) { + CHECK_STRING(host); + } + if (device != UNSPEC) { + CHECK_STRING(device); + } + + if (directory != UNSPEC) { + LispObj *dir; + + CHECK_CONS(directory); + dir = CAR(directory); + CHECK_KEYWORD(dir); + if (dir != Kabsolute && dir != Krelative) + LispDestroy("%s: directory type %s unknown", + STRFUN(builtin), STROBJ(dir)); + } + + if (name != UNSPEC) { + CHECK_STRING(name); + } + if (type != UNSPEC) { + CHECK_STRING(type); + } + + if (version != UNSPEC && version != NIL) { + switch (OBJECT_TYPE(version)) { + case LispFixnum_t: + if (FIXNUM_VALUE(version) >= 0) + goto version_ok; + case LispInteger_t: + if (INT_VALUE(version) >= 0) + goto version_ok; + break; + case LispDFloat_t: + if (DFLOAT_VALUE(version) >= 0.0) + goto version_ok; + break; + default: + break; + } + LispDestroy("%s: %s is not a positive real number", + STRFUN(builtin), STROBJ(version)); + } +version_ok: + + if (defaults != UNSPEC && !PATHNAMEP(defaults) && + (host == UNSPEC || device == UNSPEC || directory == UNSPEC || + name == UNSPEC || type == UNSPEC || version == UNSPEC)) { + defaults = APPLY1(Oparse_namestring, defaults); + GC_PROTECT(defaults); + } + + if (defaults != UNSPEC) { + defaults = defaults->data.pathname; + defaults = CDR(defaults); /* host */ + if (host == UNSPEC) + host = CAR(defaults); + defaults = CDR(defaults); /* device */ + if (device == UNSPEC) + device = CAR(defaults); + defaults = CDR(defaults); /* directory */ + if (directory == UNSPEC) + directory = CAR(defaults); + defaults = CDR(defaults); /* name */ + if (name == UNSPEC) + name = CAR(defaults); + defaults = CDR(defaults); /* type */ + if (type == UNSPEC) + type = CAR(defaults); + defaults = CDR(defaults); /* version */ + if (version == UNSPEC) + version = CAR(defaults); + } + + /* string representation */ + length = 0; + if (CONSP(directory)) { + if (CAR(directory) == Kabsolute) + pathname[length++] = PATH_SEP; + + for (cdr = CDR(directory); CONSP(cdr); cdr = CDR(cdr)) { + CHECK_STRING(CAR(cdr)); + string = THESTR(CAR(cdr)); + alength = STRLEN(CAR(cdr)); + if (alength > NAME_MAX) + LispDestroy("%s: directory name too long %s", + STRFUN(builtin), string); + if (length + alength + 2 > sizeof(pathname)) + alength = sizeof(pathname) - length - 2; + memcpy(pathname + length, string, alength); + length += alength; + pathname[length++] = PATH_SEP; + } + } + if (STRINGP(name)) { + int xlength = 0; + + if (STRINGP(type)) + xlength = STRLEN(type) + 1; + + string = THESTR(name); + alength = STRLEN(name); + if (alength + xlength > NAME_MAX) + LispDestroy("%s: file name too long %s", + STRFUN(builtin), string); + if (length + alength + 2 > sizeof(pathname)) + alength = sizeof(pathname) - length - 2; + memcpy(pathname + length, string, alength); + length += alength; + } + if (STRINGP(type)) { + if (length + 2 < sizeof(pathname)) + pathname[length++] = PATH_TYPESEP; + string = THESTR(type); + alength = STRLEN(type); + if (length + alength + 2 > sizeof(pathname)) + alength = sizeof(pathname) - length - 2; + memcpy(pathname + length, string, alength); + length += alength; + } + pathname[length] = '\0'; + result = cons = CONS(LSTRING(pathname, length), NIL); + GC_PROTECT(result); + + /* host */ + RPLACD(cons, CONS(host == UNSPEC ? NIL : host, NIL)); + cons = CDR(cons); + + /* device */ + RPLACD(cons, CONS(device == UNSPEC ? NIL : device, NIL)); + cons = CDR(cons); + + /* directory */ + if (directory == UNSPEC) + cdr = CONS(Krelative, NIL); + else + cdr = directory; + RPLACD(cons, CONS(cdr, NIL)); + cons = CDR(cons); + + /* name */ + RPLACD(cons, CONS(name == UNSPEC ? NIL : name, NIL)); + cons = CDR(cons); + + /* type */ + RPLACD(cons, CONS(type == UNSPEC ? NIL : type, NIL)); + cons = CDR(cons); + + /* version */ + RPLACD(cons, CONS(version == UNSPEC ? NIL : version, NIL)); + + GC_LEAVE(); + + return (PATHNAME(result)); +} + +LispObj * +Lisp_PathnameHost(LispBuiltin *builtin) +/* + pathname-host pathname + */ +{ + return (LispPathnameField(PATH_HOST, 0)); +} + +LispObj * +Lisp_PathnameDevice(LispBuiltin *builtin) +/* + pathname-device pathname + */ +{ + return (LispPathnameField(PATH_DEVICE, 0)); +} + +LispObj * +Lisp_PathnameDirectory(LispBuiltin *builtin) +/* + pathname-device pathname + */ +{ + return (LispPathnameField(PATH_DIRECTORY, 0)); +} + +LispObj * +Lisp_PathnameName(LispBuiltin *builtin) +/* + pathname-name pathname + */ +{ + return (LispPathnameField(PATH_NAME, 0)); +} + +LispObj * +Lisp_PathnameType(LispBuiltin *builtin) +/* + pathname-type pathname + */ +{ + return (LispPathnameField(PATH_TYPE, 0)); +} + +LispObj * +Lisp_PathnameVersion(LispBuiltin *builtin) +/* + pathname-version pathname + */ +{ + return (LispPathnameField(PATH_VERSION, 0)); +} + +LispObj * +Lisp_FileNamestring(LispBuiltin *builtin) +/* + file-namestring pathname + */ +{ + return (LispPathnameField(PATH_NAME, 1)); +} + +LispObj * +Lisp_DirectoryNamestring(LispBuiltin *builtin) +/* + directory-namestring pathname + */ +{ + return (LispPathnameField(PATH_DIRECTORY, 1)); +} + +LispObj * +Lisp_EnoughNamestring(LispBuiltin *builtin) +/* + enough-pathname pathname &optional defaults + */ +{ + LispObj *pathname, *defaults; + + defaults = ARGUMENT(1); + pathname = ARGUMENT(0); + + if (defaults != UNSPEC && defaults != NIL) { + char *ppathname, *pdefaults, *pp, *pd; + + if (!STRINGP(pathname)) { + if (PATHNAMEP(pathname)) + pathname = CAR(pathname->data.pathname); + else if (STREAMP(pathname) && + pathname->data.stream.type == LispStreamFile) + pathname = CAR(pathname->data.stream.pathname->data.pathname); + else + LispDestroy("%s: bad PATHNAME %s", + STRFUN(builtin), STROBJ(pathname)); + } + + if (!STRINGP(defaults)) { + if (PATHNAMEP(defaults)) + defaults = CAR(defaults->data.pathname); + else if (STREAMP(defaults) && + defaults->data.stream.type == LispStreamFile) + defaults = CAR(defaults->data.stream.pathname->data.pathname); + else + LispDestroy("%s: bad DEFAULTS %s", + STRFUN(builtin), STROBJ(defaults)); + } + + ppathname = pp = THESTR(pathname); + pdefaults = pd = THESTR(defaults); + while (*ppathname && *pdefaults && *ppathname == *pdefaults) { + ppathname++; + pdefaults++; + } + if (*pdefaults == '\0' && pdefaults > pd) + --pdefaults; + if (*ppathname && *pdefaults && *pdefaults != PATH_SEP) { + --ppathname; + while (*ppathname != PATH_SEP && ppathname > pp) + --ppathname; + if (*ppathname == PATH_SEP) + ++ppathname; + } + + return (STRING(ppathname)); + } + else { + if (STRINGP(pathname)) + return (pathname); + else if (PATHNAMEP(pathname)) + return (CAR(pathname->data.pathname)); + else if (STREAMP(pathname)) { + if (pathname->data.stream.type == LispStreamFile) + return (CAR(pathname->data.stream.pathname->data.pathname)); + } + } + LispDestroy("%s: bad PATHNAME %s", STRFUN(builtin), STROBJ(pathname)); + + return (NIL); +} + +LispObj * +Lisp_Namestring(LispBuiltin *builtin) +/* + namestring pathname + */ +{ + return (LispPathnameField(PATH_STRING, 1)); +} + +LispObj * +Lisp_HostNamestring(LispBuiltin *builtin) +/* + host-namestring pathname + */ +{ + return (LispPathnameField(PATH_HOST, 1)); +} + +LispObj * +Lisp_Pathnamep(LispBuiltin *builtin) +/* + pathnamep object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (PATHNAMEP(object) ? T : NIL); +} + +/* XXX only checks if host is a string and only checks the HOME enviroment + * variable */ +LispObj * +Lisp_UserHomedirPathname(LispBuiltin *builtin) +/* + user-homedir-pathname &optional host + */ +{ + GC_ENTER(); + int length; + char *home = getenv("HOME"), data[PATH_MAX + 1]; + LispObj *result; + + LispObj *host; + + host = ARGUMENT(0); + + if (host != UNSPEC && !STRINGP(host)) + LispDestroy("%s: bad hostname %s", STRFUN(builtin), STROBJ(host)); + + length = 0; + if (home) { + length = strlen(home); + strncpy(data, home, length); + if (length && home[length - 1] != PATH_SEP) + data[length++] = PATH_SEP; + } + data[length] = '\0'; + + result = LSTRING(data, length); + GC_PROTECT(result); + result = APPLY1(Oparse_namestring, result); + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Truename(LispBuiltin *builtin) +{ + return (LispProbeFile(builtin, 0)); +} + +LispObj * +Lisp_ProbeFile(LispBuiltin *builtin) +{ + return (LispProbeFile(builtin, 1)); +} diff --git a/lisp/pathname.h b/lisp/pathname.h new file mode 100644 index 0000000..f99917e --- /dev/null +++ b/lisp/pathname.h @@ -0,0 +1,78 @@ +/* + * 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/pathname.h,v 1.4 2002/11/08 08:00:57 paulo Exp $ */ + +#ifndef Lisp_pathname_h +#define Lisp_pathname_h + +#include "internal.h" + +#define PATH_SEP '/' +#define PATH_TYPESEP '.' + +#ifndef PATH_MAX +#define PATH_MAX 4096 +#endif + +#ifndef NAME_MAX +#define NAME_MAX 256 +#endif + + +#define PATH_STRING 0 +#define PATH_HOST 1 +#define PATH_DEVICE 2 +#define PATH_DIRECTORY 3 +#define PATH_NAME 4 +#define PATH_TYPE 5 +#define PATH_VERSION 6 + +void LispPathnameInit(void); + +LispObj *Lisp_Directory(LispBuiltin*); +LispObj *Lisp_Namestring(LispBuiltin*); +LispObj *Lisp_FileNamestring(LispBuiltin*); +LispObj *Lisp_DirectoryNamestring(LispBuiltin*); +LispObj *Lisp_EnoughNamestring(LispBuiltin*); +LispObj *Lisp_HostNamestring(LispBuiltin*); +LispObj *Lisp_MakePathname(LispBuiltin*); +LispObj *Lisp_Pathnamep(LispBuiltin*); +LispObj *Lisp_ParseNamestring(LispBuiltin*); +LispObj *Lisp_PathnameHost(LispBuiltin*); +LispObj *Lisp_PathnameDevice(LispBuiltin*); +LispObj *Lisp_PathnameDirectory(LispBuiltin*); +LispObj *Lisp_PathnameName(LispBuiltin*); +LispObj *Lisp_PathnameType(LispBuiltin*); +LispObj *Lisp_PathnameVersion(LispBuiltin*); +LispObj *Lisp_Truename(LispBuiltin*); +LispObj *Lisp_ProbeFile(LispBuiltin*); +LispObj *Lisp_UserHomedirPathname(LispBuiltin*); + +#endif /* Lisp_pathname_h */ diff --git a/lisp/private.h b/lisp/private.h new file mode 100644 index 0000000..6e5b128 --- /dev/null +++ b/lisp/private.h @@ -0,0 +1,536 @@ +/* + * 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/private.h,v 1.39 2002/12/20 04:32:46 paulo Exp $ */ + +#ifndef Lisp_private_h +#define Lisp_private_h + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <setjmp.h> +#include <unistd.h> +#include <sys/time.h> +#include "internal.h" + +#include "core.h" +#ifdef DEBUGGER +#include "debugger.h" +#endif +#include "helper.h" +#include "string.h" +#include "struct.h" + +/* + * Defines + */ +#define STRTBLSZ 23 +#define MULTIPLE_VALUES_LIMIT 127 +#define MAX_STACK_DEPTH 16384 + +#define FEATURES \ + lisp__data.features->data.atom->a_object ? \ + lisp__data.features->data.atom->property->value : \ + NIL +#define PACK lisp__data.packlist +#define PACKAGE lisp__data.package->data.atom->property->value +#define MOD lisp__data.modlist +#define COD lisp__data.codlist +#define RUN lisp__data.runlist +#define RES lisp__data.reslist +#define DBG lisp__data.dbglist +#define BRK lisp__data.brklist +#define PRO lisp__data.prolist + +#define SINPUT lisp__data.input +#define SOUTPUT lisp__data.output +#define STANDARD_INPUT \ + lisp__data.standard_input->data.atom->property->value +#define STANDARD_OUTPUT \ + lisp__data.standard_output->data.atom->property->value +#define STANDARDSTREAM(file, desc, flags) \ + LispNewStandardStream(file, desc, flags) + +/* + * Types + */ +typedef struct _LispStream LispStream; +typedef struct _LispBlock LispBlock; +typedef struct _LispOpaque LispOpaque; +typedef struct _LispModule LispModule; +typedef struct _LispProperty LispProperty; +typedef struct _LispObjList LispObjList; +typedef struct _LispStringHash LispStringHash; +typedef struct _LispCharInfo LispCharInfo; + + +/* Normal function/macro arguments */ +typedef struct _LispNormalArgs { + int num_symbols; + LispObj **symbols; /* symbol names */ +} LispNormalArgs; + +/* &optional function/macro arguments */ +typedef struct _LispOptionalArgs { + int num_symbols; + LispObj **symbols; /* symbol names */ + LispObj **defaults; /* default values, when unspecifed */ + LispObj **sforms; /* T if variable specified, NIL otherwise */ +} LispOptionalArgs; + +/* &key function/macro arguments */ +typedef struct _LispKeyArgs { + int num_symbols; + LispObj **symbols; /* symbol names */ + LispObj **defaults; /* default values */ + LispObj **sforms; /* T if variable specified, NIL otherwise */ + LispObj **keys; /* key names, for special keywords */ +} LispKeyArgs; + +/* &aux function/macro arguments */ +typedef struct _LispAuxArgs { + int num_symbols; + LispObj **symbols; /* symbol names */ + LispObj **initials; /* initial values */ +} LispAuxArgs; + +/* characters in the field description have the format: + * '.' normals has a list of normal arguments + * 'o' optionals has a list of &optional arguments + * 'k' keys has a list of &key arguments + * 'r' rest is a valid pointer to a &rest symbol + * 'a' auxs has a list of &aux arguments + */ +typedef struct _LispArgList { + LispNormalArgs normals; + LispOptionalArgs optionals; + LispKeyArgs keys; + LispObj *rest; + LispAuxArgs auxs; + int num_arguments; + char *description; +} LispArgList; + +typedef enum _LispDocType_t { + LispDocVariable, + LispDocFunction, + LispDocStructure, + LispDocType, + LispDocSetf +} LispDocType_t; + +struct _LispProperty { + /* may be used by multiple packages */ + unsigned int refcount; + + /* package where the property was created */ + LispPackage *package; + + /* value of variable attached to symbol */ + LispObj *value; + + union { + /* function attached to symbol */ + LispObj *function; + /* builtin function attached to symbol*/ + LispBuiltin *builtin; + } fun; + /* function/macro argument list description */ + LispArgList *alist; + + /* symbol properties list */ + LispObj *properties; + + /* setf method */ + LispObj *setf; + /* setf argument list description */ + LispArgList *salist; + + /* structure information */ + struct { + LispObj *definition; +#define STRUCT_NAME -3 +#define STRUCT_CHECK -2 +#define STRUCT_CONSTRUCTOR -1 + int function; /* if >= 0, it is a structure field index */ + } structure; +}; + +struct _LispAtom { + /* hint: dynamically binded variable */ + unsigned int dyn : 1; + + /* Property has useful data in value field */ + unsigned int a_object : 1; + /* Property has useful data in fun.function field */ + unsigned int a_function : 1; + /* Property has useful data in fun.builtin field */ + unsigned int a_builtin : 1; + /* Property has useful data in fun.function field */ + unsigned int a_compiled : 1; + /* Property has useful data in properties field */ + unsigned int a_property : 1; + /* Property has useful data in setf field */ + unsigned int a_defsetf : 1; + /* Property has useful data in defstruct field */ + unsigned int a_defstruct : 1; + + /* Symbol is extern */ + unsigned int ext : 1; + + /* Symbol must be quoted with '|' to be allow reading back */ + unsigned int unreadable : 1; + + /* Symbol value may need special handling when changed */ + unsigned int watch : 1; + + /* Symbol value is constant, cannot be changed */ + unsigned int constant : 1; + + char *string; + LispObj *object; /* backpointer to object ATOM */ + int offset; /* in the environment list */ + LispObj *package; /* package home of symbol */ + LispObj *function; /* symbol function */ + LispObj *name; /* symbol string */ + LispProperty *property; + struct _LispAtom *next; + + LispObj *documentation[5]; +}; + +struct _LispObjList { + LispObj **pairs; /* name0 ... nameN */ + int length; /* number of objects */ + int space; /* space allocated in field pairs */ +}; + +struct _LispPackage { + LispObjList glb; /* global symbols in package */ + LispObjList use; /* inherited packages */ + LispAtom *atoms[STRTBLSZ]; /* atoms in this package */ +}; + +struct _LispOpaque { + int type; + char *desc; + LispOpaque *next; +}; + +/* These strings are never released, they are used to avoid + * the need of strcmp() on two symbol names, just compare pointers */ +struct _LispStringHash { + char *string; + LispStringHash *next; +}; + +typedef enum _LispBlockType { + LispBlockNone, /* no block */ + LispBlockTag, /* may become "invisible" */ + LispBlockCatch, /* can be used to jump across function calls */ + LispBlockClosure, /* hides blocks of type LispBlockTag bellow it */ + LispBlockProtect, /* used by unwind-protect */ + LispBlockBody /* used by tagbody and go */ +} LispBlockType; + +struct _LispBlock { + LispBlockType type; + LispObj *tag; + jmp_buf jmp; + int stack; + int protect; + int block_level; +#ifdef DEBUGGER + int debug_level; + int debug_step; +#endif +}; + +struct _LispModule { + LispModule *next; + void *handle; + LispModuleData *data; +}; + +typedef struct _LispUngetInfo { + char buffer[16]; + int offset; +} LispUngetInfo; + +struct _LispMac { + /* stack for builtin function arguments */ + struct { + LispObj **values; + int base; /* base of arguments to function */ + int length; + int space; + } stack; + + /* environment */ + struct { + LispObj **values; + Atom_id *names; + int lex; /* until where variables are visible */ + int head; /* top of environment */ + int length; /* number of used pairs */ + int space; /* number of objects in pairs */ + } env; + + struct { + LispObj **values; + int count; + } returns; + + struct { + LispObj **objects; + int length; + int space; + } protect; + + LispObj *package; /* package object */ + LispPackage *pack; /* pointer to lisp__data.package->data.package.package */ + + /* fast access to the KEYWORD package */ + LispObj *keyword; + LispPackage *key; + + /* the LISP package */ + LispObj *lisp; + + /* only used if the package was changed, but an error generated + * before returning to the toplevel */ + LispObj *savepackage; + LispPackage *savepack; + + struct { + int block_level; + int block_size; + LispObj *block_ret; + LispBlock **block; + } block; + + sigjmp_buf jmp; + + struct { + unsigned int expandbits : 3; /* code doesn't look like reusing cells + * so try to have a larger number of + * free cells */ + unsigned int immutablebits : 1; /* need to reset immutable bits */ + unsigned int timebits : 1; /* update gctime counter */ + unsigned int count; + long gctime; + int average; /* of cells freed after gc calls */ + } gc; + + LispStringHash *strings[STRTBLSZ]; + LispOpaque *opqs[STRTBLSZ]; + int opaque; + + LispObj *standard_input, *input, *input_list; + LispObj *standard_output, *output, *output_list; + LispObj *error_stream; + LispUngetInfo **unget; + int iunget, nunget; + int eof; + + int interactive; + int errexit; + + struct { + int index; + int level; + int space; + void **mem; + } mem; /* memory from Lisp*Alloc, to be release in error */ + LispModule *module; + LispObj *modules; + char *prompt; + + LispObj *features; + + LispObj *modlist; /* module list */ + LispObj *packlist; /* list of packages */ + LispObj *codlist; /* current code */ + LispObj *runlist[3]; /* +, ++, and +++ */ + LispObj *reslist[3]; /* *, **, and *** */ +#ifdef DEBUGGER + LispObj *dbglist; /* debug information */ + LispObj *brklist; /* breakpoints information */ +#endif + LispObj *prolist; /* protect objects list */ + +#ifdef SIGNALRETURNSINT + int (*sigint)(int); + int (*sigfpe)(int); +#else + void (*sigint)(int); + void (*sigfpe)(int); +#endif + + int destroyed; /* reached LispDestroy, used by unwind-protect */ + int running; /* there is somewhere to siglongjmp */ + + int ignore_errors; /* inside a ignore-errors block */ + LispObj *error_condition; /* actually, a string */ + + int debugging; /* debugger enabled? */ +#ifdef DEBUGGER + int debug_level; /* almost always the same as lisp__data.level */ + int debug_step; /* control for stoping and printing output */ + int debug_break; /* next breakpoint number */ + LispDebugState debug; +#endif +}; + +struct _LispCharInfo { + char **names; +}; + + +/* + * Prototypes + */ +void LispUseArgList(LispArgList*); +void LispFreeArgList(LispArgList*); +LispArgList *LispCheckArguments(LispFunType, LispObj*, char*, int); +LispObj *LispListProtectedArguments(LispArgList*); + +LispObj *LispGetDoc(LispObj*); +LispObj *LispGetVar(LispObj*); +#ifdef DEBUGGER +void *LispGetVarAddr(LispObj*); /* used by debugger */ +#endif +LispObj *LispAddVar(LispObj*, LispObj*); +LispObj *LispSetVar(LispObj*, LispObj*); +void LispUnsetVar(LispObj*); + + /* only used at initialization time */ +LispObj *LispNewStandardStream(LispFile*, LispObj*, int); + + /* create a new package */ +LispObj *LispNewPackage(LispObj*, LispObj*); + /* add package to use-list of current, and imports all extern symbols */ +void LispUsePackage(LispObj*); + /* make symbol extern in the current package */ +void LispExportSymbol(LispObj*); + /* imports symbol to current package */ +void LispImportSymbol(LispObj*); + + /* always returns the same string */ +char *LispGetAtomString(char*, int); + +/* destructive fast reverse, note that don't receive a LispMac* argument */ +LispObj *LispReverse(LispObj *list); + +char *LispIntToOpaqueType(int); + +/* (print) */ +void LispPrint(LispObj*, LispObj*, int); + +LispBlock *LispBeginBlock(LispObj*, LispBlockType); +#define BLOCKJUMP(block) \ + lisp__data.stack.length = (block)->stack; \ + lisp__data.protect.length = (block)->protect; \ + longjmp((block)->jmp, 1) +void LispEndBlock(LispBlock*); + /* if unwind-protect active, jump to cleanup code, else do nothing */ +void LispBlockUnwind(LispBlock*); + +void LispUpdateResults(LispObj*, LispObj*); +void LispTopLevel(void); + +#define STRHASH(string) LispDoHashString(string) +int LispDoHashString(char*); +LispAtom *LispDoGetAtom(char *str, int); + /* get value from atom's property list */ +LispObj *LispGetAtomProperty(LispAtom*, LispObj*); + /* put value in atom's property list */ +LispObj *LispPutAtomProperty(LispAtom*, LispObj*, LispObj*); + /* remove value from atom's property list */ +LispObj *LispRemAtomProperty(LispAtom*, LispObj*); + /* replace atom's property list */ +LispObj *LispReplaceAtomPropertyList(LispAtom*, LispObj*); + + /* returns function associated with symbol */ +LispObj *LispSymbolFunction(LispObj*); + /* returns symbol string name */ +LispObj *LispSymbolName(LispObj*); + + /* define byte compiled function, or replace definition */ +void LispSetAtomCompiledProperty(LispAtom*, LispObj*); + /* remove byte compiled function property */ +void LispRemAtomCompiledProperty(LispAtom*); + /* define function, or replace function definition */ +void LispSetAtomFunctionProperty(LispAtom*, LispObj*, LispArgList*); + /* remove function property */ +void LispRemAtomFunctionProperty(LispAtom*); + /* define builtin, or replace builtin definition */ +void LispSetAtomBuiltinProperty(LispAtom*, LispBuiltin*, LispArgList*); + /* remove builtin property */ +void LispRemAtomBuiltinProperty(LispAtom*); + /* define setf macro, or replace current definition */ +void LispSetAtomSetfProperty(LispAtom*, LispObj*, LispArgList*); + /* remove setf macro */ +void LispRemAtomSetfProperty(LispAtom*); + /* create or change structure property */ +void LispSetAtomStructProperty(LispAtom*, LispObj*, int); + /* remove structure property */ +void LispRemAtomStructProperty(LispAtom*); + +void LispProclaimSpecial(LispObj*, LispObj*, LispObj*); +void LispDefconstant(LispObj*, LispObj*, LispObj*); + +void LispAddDocumentation(LispObj*, LispObj*, LispDocType_t); +void LispRemDocumentation(LispObj*, LispDocType_t); +LispObj *LispGetDocumentation(LispObj*, LispDocType_t); + +/* increases storage for functions returning multiple values */ +void LispMoreReturns(void); + +/* increases storage for temporarily protected data */ +void LispMoreProtects(void); + +/* Initialization */ +extern int LispArgList_t; +extern LispCharInfo LispChars[256]; + +/* This function will return if the interpreter cannot be stopped */ +extern void LispSignal(int); + +void LispDisableInterrupts(void); +void LispEnableInterrupts(void); +#define DISABLE_INTERRUPTS() LispDisableInterrupts() +#define ENABLE_INTERRUPTS() LispEnableInterrupts() + +/* Value returned by LispBegin, used everywhere in the code. + * Only one interpreter instance allowed. */ +extern LispMac lisp__data; + +#endif /* Lisp_private_h */ diff --git a/lisp/re/README b/lisp/re/README new file mode 100644 index 0000000..848e1e9 --- /dev/null +++ b/lisp/re/README @@ -0,0 +1,121 @@ +$XFree86: xc/programs/xedit/lisp/re/README,v 1.4 2002/11/15 07:01:32 paulo Exp $ + +LAST UPDATED: $Date$ + + This is a small regex library for fast matching tokens in text. It was built +to be used by xedit and it's syntax highlight code. It is not compliant with +IEEE Std 1003.2, but is expected to be used where very fast matching is +required, and exotic patterns will not be used. + + To understand what kind of patterns this library is expected to be used with, +see the file <XRoot>xc/programs/xedit/lisp/modules/progmodes/c.lsp and some +samples in the file tests.txt, with comments for patterns that will not work, +or may give incorrect results. + + The library is not built upon the standard regex library by Henry Spencer, +but is completely written from scratch, but it's syntax is heavily based on +that library, and the only reason for it to exist is that unfortunately +the standard version does not fit the requirements needed by xedit. +Anyways, I would like to thanks Henry for his regex library, it is a really +very useful tool. + + Small description of understood tokens: + + M A T C H I N G +------------------------------------------------------------------------ +. Any character (won't match newline if compiled with RE_NEWLINE) +\w Any word letter (shortcut to [a-zA-Z0-9_] +\W Not a word letter (shortcut to [^a-zA-Z0-9_] +\d Decimal number +\D Not a decimal number +\s A space +\S Not a space +\l A lower case letter +\u An upper case letter +\c A control character, currently the range 1-32 (minus tab) +\C Not a control character +\o Octal number +\O Not an octal number +\x Hexadecimal number +\X Not an hexadecimal number +\< Beginning of a word (matches an empty string) +\> End of a word (matches an empty string) +^ Beginning of a line (matches an empty string) +$ End of a line (matches an empty string) +[...] Matches one of the characters inside the brackets + ranges are specified separating two characters with "-". + If the first character is "^", matches only if the + character is not in this range. To add a "]" make it + the first character, and to add a "-" make it the last. +\1 to \9 Backreference, matches the text that was matched by a group, + that is, text that was matched by the pattern inside + "(" and ")". + + + O P E R A T O R S +------------------------------------------------------------------------ +() Any pattern inside works as a backreference, and is also + used to group patterns. +| Alternation, allows choosing different possibilities, like + character ranges, but allows patterns of different lengths. + + + R E P E T I T I O N +------------------------------------------------------------------------ +<re>* <re> may occur any number of times, including zero +<re>+ <re> must occur at least once +<re>? <re> is optional +<re>{<e>} <re> must occur exactly <e> times +<re>{<n>,} <re> must occur at least <n> times +<re>{,<m>} <re> must not occur more than <m> times +<re>{<n>,<m>} <re> must occur at least <n> times, but no more than <m> + + + Note that "." is a special character, and when used with a repetition +operator it changes completely its meaning. For example, ".*" matches +anything up to the end of the input string (unless the pattern was compiled +with RE_NEWLINE, in that case it will match anything, but a newline). + + + Limitations: + +o Only minimal matches supported. The engine has only one level "backtracking", + so, it also only does minimal matches to allow backreferences working + properly, and to avoid failing to match depending on the input. + +o Only one level "grouping", for example, with the pattern: + (a(b)c) + If "abc" is anywhere in the input, it will be in "\1", but there will + not exist a "\2" for "b". + +o Some "special repetitions" were not implemented, these are: + .{<e>} + .{<n>,} + .{,<m>} + .{<n>,<m>} + +o Some patterns will never match, for example: + \w*\d + Since "\w*" already includes all possible matches of "\d", "\d" will + only be tested when "\w*" failed. There are no plans to make such + patterns work. + + + Some of these limitations may be worked on future versions of the library, +but this is not what the library is expected to do, and, adding support for +correct handling of these would probably make the library slower, what is +not the reason of it to exist in the first time. + + If you need "true" regex than this library is not for you, but if all +you need is support for very quickly finding simple patterns, than this +library can be a very powerful tool, on some patterns it can run more +than 200 times faster than "true" regex implementations! And this is +the reason it was written. + + + + Send comments and code to me (paulo@XFree86.Org) or to the XFree86 +mailing/patch lists. + +-- +Paulo diff --git a/lisp/re/re.c b/lisp/re/re.c new file mode 100644 index 0000000..d848a4b --- /dev/null +++ b/lisp/re/re.c @@ -0,0 +1,2648 @@ +/* + * Copyright (c) 2002 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/re/re.c,v 1.9 2002/12/11 04:44:28 paulo Exp $ */ + +#include <stdio.h> +#include "rep.h" +#define DEBUG +/* + * Types + */ + +/* Information used when generating the final form of the compiled re. + */ +struct _re_inf { + rec_alt *alt; + unsigned char *cod; + long len; + long spc; + + /* Start offset of special repetition instruction */ + long sr[MAX_DEPTH]; + + /* Jump offset of special repetition instruction */ + long sj[MAX_DEPTH]; + + /* Just a flag, to know if this nesting is for a special repetition */ + char sp[MAX_DEPTH]; + + int bas; /* Alternatives/repetitions depth */ + int par; /* Open parenthesis counter */ + int ref; /* Backreference counter */ + + rec_pat *apat; /* Alternatives duplicate patterns + * if a special repetition is found, + * this is done to somewhat simplify + * the bytecode engine and still allow + * some complex (and time consuming) + * patterns. */ + + int flags; + int ecode; +}; + +/* This structure is not associated with re_cod as it's data only matters + * to the current match search. + */ +struct _re_eng { + unsigned char *bas; /* Base string pointer */ + unsigned char *str; /* String to search for pattern */ + unsigned char *end; /* Where to stop searching */ + unsigned char *cod; /* Pointer in the re_cod structure */ + long off; /* Number of used entries in so/eo etc */ + + /* Match offset/nesting information */ + long so[MAX_DEPTH]; /* (s)tart of (m)atch */ + long eo[MAX_DEPTH]; /* (e)nd of (m)atch */ + long sv[MAX_DEPTH]; /* (s)a(v)e match end offset */ + long re[MAX_DEPTH]; /* (re)petition count */ + long ss[MAX_DEPTH]; /* (s)ave (s)tart of match */ + unsigned char *rcod[MAX_DEPTH]; /* restart position in regex code */ + unsigned char *rstr[MAX_DEPTH]; /* restart position in string */ + + /* Group/backreference information */ + long goff; + long gso[9]; + long geo[9]; +}; + +/* + * Prototypes + */ +static void reinit(void); +static int rec_check(re_inf*, int); +static int rec_code(re_inf*, ReCode); +static int rec_byte(re_inf*, int); +static int rec_byte_byte(re_inf*, int, int); +static int rec_code_byte(re_inf*, ReCode, int); +static int rec_length(re_inf*, int); +static int rec_code_byte_byte(re_inf*, ReCode, int, int); +static int rec_build_alt(re_inf*, rec_alt*); +static int rec_build_pat(re_inf*, rec_pat*); +static int rec_build_rng(re_inf*, rec_rng*); +static int rec_build_grp(re_inf*, rec_grp*); +static int rec_build_stl(re_inf*, rec_stl*); +static int rec_build_rep(re_inf*, rec_rep*); +static int rec_inc_spc(re_inf*); +static int rec_dec_spc(re_inf*); +static int rec_add_spc(re_inf*, int); +static int rec_off_spc(re_inf*); +static int rec_alt_spc(re_inf*, int); +static int rec_rep_spc(re_inf*, int); +#ifdef DEBUG +static void redump(re_cod*); +#endif + +/* + * Initialization + */ +unsigned char re__alnum[256]; +unsigned char re__odigit[256]; +unsigned char re__ddigit[256]; +unsigned char re__xdigit[256]; +unsigned char re__control[256]; + +/* + * Implementation + */ +int +recomp(re_cod *preg, const char *pattern, int flags) +{ + int i, ecode; + re_inf inf; + + reinit(); + + preg->cod = NULL; + inf.alt = irec_comp(pattern, + flags & RE_PEND ? preg->re_endp : + pattern + strlen(pattern), + flags, &ecode); + if (ecode != 0) + return (ecode); + + inf.cod = NULL; + inf.len = inf.spc = 0; + inf.bas = 0; + inf.par = 0; + inf.ref = 0; + inf.apat = NULL; + inf.flags = flags; + inf.ecode = 0; + for (i = 0; i < MAX_DEPTH; i++) + inf.sp[i] = 0; + + /* First byte is runtime modifier flags */ + if (rec_byte(&inf, flags & (RE_NEWLINE | RE_NOSUB)) == 0 && + rec_byte(&inf, 0xff) == 0 && + rec_build_alt(&inf, inf.alt) == 0 && + rec_rep_spc(&inf, 0) == 0 && + rec_code(&inf, Re_Done) == 0) { + /* Number of possible references, loops will not leave this + * value correct, but it is cheap to read it from the second + * byte, instead of adding several extra checks in the bytecode. */ + if (inf.ref) + inf.cod[1] = inf.ref - 1; + preg->cod = inf.cod; + /* Public structure member */ + preg->re_nsub = inf.ref; + } + + irec_free_alt(inf.alt); + if (inf.ecode) + free(inf.cod); +#ifdef DEBUG + else if (flags & RE_DUMP) + redump(preg); +#endif + + return (inf.ecode); +} + +int +reexec(const re_cod *preg, const char *string, + int nmatch, re_mat pmat[], int flags) +{ + unsigned char *ptr, *str, newline, nosub; + int len, si, ci, bas, i, j, k, l, m; + re_eng eng; + + if (preg == NULL || preg->cod == NULL || nmatch < 0 || + ((flags & RE_STARTEND) && + (pmat == NULL || pmat[0].rm_eo < pmat[0].rm_so))) + return (RE_INVARG); + + eng.str = (unsigned char*)string; + if (flags & RE_STARTEND) { + eng.end = eng.str + pmat[0].rm_eo; + eng.str += pmat[0].rm_so; + } + else + eng.end = eng.str + strlen(string); + eng.bas = eng.str; + nosub = preg->cod[0] & RE_NOSUB; + newline = preg->cod[0] & RE_NEWLINE; + eng.cod = preg->cod + 2; + + if (!nosub && preg->cod[1] != 0xff) { + for (i = 0; i <= preg->cod[1]; i++) { + eng.gso[i] = 0; + eng.geo[i] = -1; + } + } + + /* Setup to search for start of match from the first character */ + eng.so[0] = 0; + eng.eo[0] = eng.sv[0] = -1; + eng.rcod[0] = eng.cod; + eng.rstr[0] = eng.str + 1; + eng.off = 0; + eng.goff = -1; + for (ci = si = 1;;) { +reset: + switch (*eng.cod) { + /**************************************************** + * One byte codes * + ****************************************************/ + case Re_Any: + if (eng.str == eng.end || (newline && eng.str[0] == '\n')) + goto fail; + goto match; + case Re_AnyEatAnyTimes: + if (newline) { + for (ptr = eng.str; ptr < eng.end; ptr++) { + if (*ptr == '\n') + break; + } + si = ptr - eng.str; + } + else + si = eng.end - eng.str; + goto match; + case Re_AnyEatMaybe: + si = eng.end > eng.str; + if (newline && si && eng.str[0] == '\n') + si = 0; + goto match; + case Re_AnyEatAtLeast: + if (newline) { + for (ptr = eng.str; ptr < eng.end; ptr++) { + if (*ptr == '\n') + break; + } + si = ptr - eng.str; + } + else + si = eng.end - eng.str; + if (si == 0) { + si = 1; + goto fail; + } + goto match; + case Re_Odigit: + if (eng.str >= eng.end) + goto fail; + if (re__odigit[eng.str[0]]) + goto match; + goto fail; + case Re_OdigitNot: + if (eng.str >= eng.end || re__odigit[eng.str[0]]) + goto fail; + goto match; + case Re_Digit: + if (eng.str >= eng.end) + goto fail; + if (re__ddigit[eng.str[0]]) + goto match; + goto fail; + case Re_DigitNot: + if (eng.str >= eng.end || re__ddigit[eng.str[0]]) + goto fail; + goto match; + case Re_Xdigit: + if (eng.str >= eng.end) + goto fail; + if (re__xdigit[eng.str[0]]) + goto match; + goto fail; + case Re_XdigitNot: + if (eng.str >= eng.end || re__xdigit[eng.str[0]]) + goto fail; + goto match; + case Re_Space: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] == ' ' || eng.str[0] == '\t') + goto match; + goto fail; + case Re_SpaceNot: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] != ' ' && eng.str[0] != '\t') + goto match; + goto fail; + case Re_Tab: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] == '\t') + goto match; + goto fail; + case Re_Newline: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] == '\n') + goto match; + goto fail; + case Re_Lower: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] >= 'a' && eng.str[0] <= 'z') + goto match; + goto fail; + case Re_Upper: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] >= 'A' && eng.str[0] <= 'Z') + goto match; + goto fail; + case Re_Alnum: + if (eng.str >= eng.end) + goto fail; + if (re__alnum[eng.str[0]]) + goto match; + goto fail; + case Re_AlnumNot: + if (eng.str >= eng.end) + goto fail; + if (re__alnum[eng.str[0]]) + goto fail; + goto match; + case Re_Control: + if (eng.str >= eng.end) + goto fail; + if (re__control[eng.str[0]]) + goto match; + goto fail; + case Re_ControlNot: + if (eng.str >= eng.end || re__control[eng.str[0]]) + goto fail; + goto match; + + /**************************************************** + * One byte codes, match special emtpy strings * + ****************************************************/ + case Re_Bol: + if (eng.str == eng.bas) { + if ((flags & RE_NOTBOL)) { + /* String does not start at the beginning of a line */ + if (newline) + goto fail; + goto wont; + } + si = 0; + goto match; + } + if (newline && eng.str[-1] == '\n') { + si = 0; + goto match; + } + goto fail; + case Re_Eol: + if (eng.str == eng.end) { + if (flags & RE_NOTEOL) + /* String does not finish at the end of a line */ + goto wont; + si = 0; + goto match; + } + if (newline && eng.str[0] == '\n') { + si = 0; + goto match; + } + goto fail; + case Re_Bow: + if (eng.str >= eng.end || + (eng.str > eng.bas && + (re__alnum[eng.str[-1]]))) + goto fail; + if (re__alnum[eng.str[0]]) { + si = 0; + goto match; + } + goto fail; + case Re_Eow: + if (eng.str == eng.bas || + (eng.str < eng.end && + re__alnum[eng.str[0]])) + goto fail; + if (re__alnum[eng.str[-1]]) { + si = 0; + goto match; + } + goto fail; + + /**************************************************** + * One byte code, one byte argument * + ****************************************************/ + case Re_Literal: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] == eng.cod[1]) { + ci = 2; + goto match; + } + goto fail; + case Re_LiteralNot: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] != eng.cod[1]) { + ci = 2; + goto match; + } + goto fail; + case Re_SearchLiteral: + for (str = eng.str; str < eng.end; str++) { + if (*str == eng.cod[1]) { + ci = 2; + eng.str = str; + goto match; + } + } + /* This bytecode only happens in the toplevel */ + eng.so[0] = str - eng.bas; + eng.str = str; + goto fail; + + /**************************************************** + * One byte code, two bytes argument * + ****************************************************/ + case Re_CaseLiteral: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] == eng.cod[1] || eng.str[0] == eng.cod[2]) { + ci = 3; + goto match; + } + goto fail; + case Re_CaseLiteralNot: + if (eng.str >= eng.end) + goto fail; + if (eng.str[0] != eng.cod[1] && eng.str[0] != eng.cod[2]) { + ci = 3; + goto match; + } + goto fail; + case Re_SearchCaseLiteral: + for (str = eng.str; str < eng.end; str++) { + if (*str == eng.cod[1] || *str == eng.cod[2]) { + ci = 3; + eng.str = str; + goto match; + } + } + eng.so[0] = str - eng.bas; + eng.str = str; + goto fail; + + /**************************************************** + * One byte codes, two arguments, n bytes * + ****************************************************/ + case Re_String: + len = eng.cod[1]; + if (len & 0x80) { + i = 3; + len = (len & 0x7f) + (eng.cod[2] << 7); + } + else + i = 2; + if (eng.end - eng.str < len) + goto fail; + ptr = eng.cod + i; + str = eng.str; + for (k = len; k > 0; k--) { + if (*ptr++ != *str++) + goto fail; + } + ci = i + len; + si = len; + goto match; + case Re_SearchString: + len = eng.cod[1]; + if (len & 0x80) { + i = 3; + len = (len & 0x7f) + (eng.cod[2] << 7); + } + else + i = 2; + for (str = eng.str; eng.end - str >= len; str = eng.str++) { + for (ptr = eng.cod + i, str = eng.str, k = len; k > 0; k--) + if (*ptr++ != *str++) + break; + if (k == 0) { + /* Substring found */ + ci = i + len; + si = str - eng.str; + goto match; + } + } + eng.so[0] = eng.end - eng.bas; + eng.str = eng.end; + goto fail; + + case Re_CaseString: + len = eng.cod[1]; + if (len & 0x80) { + i = 3; + len = (len & 0x7f) + (eng.cod[2] << 7); + } + else + i = 2; + + len >>= 1; + /* Check if there are at least len/2 bytes left, string + * is represented as two bytes, lower and upper case */ + if (eng.end - eng.str < len) + goto fail; + ptr = eng.cod + i; + str = eng.str; + for (k = len; k > 0; str++, ptr += 2, k--) { + if (*str != ptr[0] && *str != ptr[1]) + goto fail; + } + ci = i + (len << 1); + si = len; + goto match; + case Re_SearchCaseString: + len = eng.cod[1]; + if (len & 0x80) { + i = 3; + len = (len & 0x7f) + (eng.cod[2] << 7); + } + else + i = 2; + len >>= 1; + for (str = eng.str; eng.end - str >= len; str = eng.str++) { + for (ptr = eng.cod + i, str = eng.str, k = len; + k > 0; k--, ptr += 2, str++) + if (ptr[0] != str[0] && ptr[1] != str[0]) + break; + if (k == 0) { + /* Substring found */ + ci = i + (len << 1); + si = str - eng.str; + goto match; + } + } + eng.so[0] = eng.end - eng.bas; + eng.str = eng.end; + goto fail; + + case Re_StringList: + /* Number of strings */ + k = eng.cod[1]; + + /* Where to jump after match */ + bas = eng.cod[2] | (eng.cod[3] << 8); + + str = eng.str; + ptr = eng.cod + k + 4; + l = eng.end - eng.str; + for (j = 0; j < k; j++) { + len = eng.cod[j + 4]; + if (len <= l) { + for (i = 0; i < len; i++) + if (ptr[i] != str[i]) + goto next_stl; + goto stl_match; + } +next_stl: + ptr += len; + } + goto fail; +stl_match: + ci = bas; + si = len; + goto match; + + case Re_CaseStringList: + /* Number of strings */ + k = eng.cod[1]; + + /* Where to jump after match */ + bas = eng.cod[2] | (eng.cod[3] << 8); + + str = eng.str; + ptr = eng.cod + k + 4; + l = eng.end - eng.str; + for (j = 0; j < k; j++) { + len = eng.cod[j + 4]; + if ((len >> 1) <= l) { + for (i = m = 0; i < len; m++, i += 2) + if (ptr[i] != str[m] && ptr[i + 1] != str[m]) + goto next_cstl; + goto cstl_match; + } +next_cstl: + ptr += len; + } + goto fail; +cstl_match: + ci = bas; + si = len >> 1; + goto match; + + + case Re_LargeStringList: + /* Where to jump after match */ + bas = eng.cod[1] | (eng.cod[2] << 8); + + str = eng.str; + + /* First entry in index map */ + ptr = eng.cod + 3; + i = (int)str[0] << 1; + j = ptr[i] | (ptr[i + 1] << 8); + if (j == 0xffff) + /* No entry with this byte */ + goto fail; + + /* Bytes left in input */ + l = eng.end - eng.str; + + /* First entry matching initial byte */ + ptr += 512 + j; + + for (len = ptr[0]; + str[0] == ptr[1]; + ptr += len + 1, len = ptr[0]) { + if (len <= l) { + for (i = 1; i < len; i++) { + if (ptr[i + 1] != str[i]) + goto next_lstl; + } + ci = bas; + si = len; + goto match; + } +next_lstl:; + } + goto fail; + + case Re_LargeCaseStringList: + /* Where to jump after match */ + bas = eng.cod[1] | (eng.cod[2] << 8); + + str = eng.str; + + /* First entry in index map */ + ptr = eng.cod + 3; + i = (int)str[0] << 1; + j = ptr[i] | (ptr[i + 1] << 8); + if (j == 0xffff) + /* No entry with this byte */ + goto fail; + + /* Bytes left in input */ + l = eng.end - eng.str; + + /* First entry matching initial byte */ + ptr += 512 + j; + + for (len = ptr[0]; + str[0] == ptr[1] || str[0] == ptr[2]; + ptr += len + 1, len = ptr[0]) { + if ((k = (len >> 1)) <= l) { + for (i = 2, j = 1; i < len; i += 2, j++) { + if (ptr[i + 1] != str[j] && ptr[i + 2] != str[j]) + goto next_lcstl; + } + ci = bas; + si = k; + goto match; + } +next_lcstl:; + } + goto fail; + + + /**************************************************** + * Character range matching * + ****************************************************/ + case Re_Range: + if (eng.str < eng.end && eng.cod[eng.str[0] + 1]) { + ci = 257; + goto match; + } + goto fail; + case Re_RangeNot: + if (eng.str >= eng.end || eng.cod[eng.str[0] + 1]) + goto fail; + ci = 257; + goto match; + + /**************************************************** + * Group handling * + ****************************************************/ + case Re_Open: + if (++eng.goff >= 9) + return (RE_ASSERT); + eng.gso[eng.goff] = eng.str - eng.bas; + ++eng.cod; + continue; + case Re_Close: + eng.geo[eng.goff] = eng.str - eng.bas; + ++eng.cod; + continue; + case Re_Update: + bas = eng.cod[1]; + eng.geo[eng.goff] = eng.str - eng.bas; + eng.cod += 2; /* + Update + bas */ + continue; + + /**************************************************** + * Backreference * + ****************************************************/ + case Re_Backref: + i = eng.cod[1]; + j = eng.gso[i]; + k = eng.geo[i]; + len = k - j; + if (k < j || eng.end - eng.str < len) + goto fail; + ptr = eng.bas + j; + str = eng.str; + for (l = len; l > 0; l--) { + if (*ptr++ != *str++) + goto fail; + } + ci = 2; + si = len; + goto match; + + /**************************************************** + * Alternatives handling * + ****************************************************/ + case Re_Alt: + bas = eng.off; + if (++eng.off >= MAX_DEPTH) + return (RE_ASSERT); + + /* Get offset of next alternative */ + i = eng.cod[1] | (eng.cod[2] << 8); + + /* Setup for next alternative if the current fails */ + eng.rcod[eng.off] = eng.cod + i + 1; /* + Alt */ + + /* If fail, test the next alternative in the same string */ + eng.rstr[eng.off] = eng.str; + + /* Setup match offsets */ + if (eng.so[bas] <= eng.eo[bas]) + eng.so[eng.off] = eng.eo[bas]; + else + eng.so[eng.off] = eng.so[bas]; + eng.sv[eng.off] = eng.eo[eng.off] = eng.so[eng.off] - 1; + + /* Save start of possible previous matches */ + eng.ss[eng.off] = eng.so[bas]; + + /* Skip code */ + eng.cod += 3; + + /* Go try the first alternative */ + continue; + + case Re_AltNext: + bas = eng.off - 1; + /* Check if matched and if it is a better match */ + if (eng.sv[eng.off] - eng.so[eng.off] < + eng.eo[eng.off] - eng.so[eng.off]) + eng.sv[eng.off] = eng.eo[eng.off]; + + /* Get offset of next alternative */ + i = eng.cod[1] | (eng.cod[2] << 8); + + /* Setup for next alternative if the current fails */ + eng.rcod[eng.off] = eng.cod + i + 1; /* + AltNext */ + + /* Setup match offset */ + eng.eo[eng.off] = eng.so[eng.off] - 1; + + /* Reset string for next alternative */ + eng.str = eng.rstr[eng.off]; + + /* Skip code */ + eng.cod += 3; + + /* Go try the next alternative */ + continue; + + case Re_AltDone: + bas = eng.off - 1; + /* Check if matched and if it is a better match */ + if (eng.sv[eng.off] - eng.so[eng.off] < + eng.eo[eng.off] - eng.so[eng.off]) + eng.sv[eng.off] = eng.eo[eng.off]; + + /* If there is a match */ + if (eng.sv[eng.off] >= eng.so[eng.off]) { + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.sv[eng.off]; + eng.str = eng.bas + eng.eo[bas]; + + /* Pop stack and skip code */ + --eng.off; + ++eng.cod; + + /* Go try next regular expression pattern */ + continue; + } + + /* Failed, reset string and pop stack */ + eng.str = eng.rstr[eng.off]; + --eng.off; + goto fail; + + + /**************************************************** + * Repetition * + ****************************************************/ + + /* Note that the repetition counter is not + * updated for <re>*, <re>+ and <re>? + * it is easy to updated, but since it is not + * really useful, code to do it was removed + * to save a few cpu cicles. */ + +#define REPETITION_SETUP() \ + if (++eng.off >= MAX_DEPTH) \ + return (RE_ASSERT); \ + \ + /* Return here for recovery if match fail */ \ + eng.rcod[eng.off] = eng.cod; \ + \ + /* Setup match offsets */ \ + if (eng.so[bas] <= eng.eo[bas]) \ + eng.so[eng.off] = eng.eo[bas]; \ + else \ + eng.so[eng.off] = eng.so[bas]; \ + eng.ss[eng.off] = eng.so[bas]; \ + eng.sv[eng.off] = eng.eo[eng.off] = eng.so[eng.off] - 1;\ + \ + /* Skip repetition instruction */ \ + eng.cod += 4; + + + case Re_AnyTimes: + bas = eng.cod[1]; + if (eng.off == bas) { + /* First iteration */ + REPETITION_SETUP(); + } + else { + if (eng.eo[eng.off] >= eng.so[eng.off] && + eng.eo[eng.off] > eng.sv[eng.off]) { + /* Update offset of match */ + eng.sv[eng.off] = eng.eo[eng.off]; + + /* Skip repetition instruction */ + eng.cod += 4; + } + else { + /* Match failed but it is ok */ + len = eng.cod[2] | (eng.cod[3] << 8); + eng.so[bas] = eng.ss[eng.off]; + if (eng.sv[eng.off] >= eng.so[eng.off]) + /* Something matched earlier, update */ + eng.eo[bas] = eng.sv[eng.off]; + else if (eng.eo[bas] < eng.so[bas]) + /* Empty match */ + eng.eo[bas] = eng.so[bas]; + + /* Try next pattern at correct offset */ + eng.str = eng.bas + eng.eo[bas]; + + /* Pop stack and skip code */ + --eng.off; + eng.cod += len; + } + } + continue; + + case Re_Maybe: + bas = eng.cod[1]; + if (eng.off == bas) { + /* First iteration */ + REPETITION_SETUP(); + } + else { + /* Matched or first iteration is done */ + len = eng.cod[2] | (eng.cod[3] << 8); + eng.so[bas] = eng.ss[eng.off]; + if (eng.eo[eng.off] > eng.so[eng.off]) { + /* Something matched earlier, update */ + eng.eo[bas] = eng.eo[eng.off]; + eng.str = eng.bas + eng.eo[bas]; + /* Don't need to update counter */ + } + else { + /* Empty match */ + if (eng.eo[bas] < eng.so[bas]) + eng.eo[bas] = eng.so[bas]; + + /* Try next pattern at correct offset */ + eng.str = eng.bas + eng.eo[bas]; + } + + /* Pop stack */ + --eng.off; + + /* Skip code */ + eng.cod += len; + } + continue; + + case Re_AtLeast: + bas = eng.cod[1]; + if (eng.off == bas) { + /* First iteration */ + REPETITION_SETUP(); + } + else { + if (eng.eo[eng.off] >= eng.so[eng.off] && + eng.eo[eng.off] > eng.sv[eng.off]) { + /* Update offset of match */ + eng.sv[eng.off] = eng.eo[eng.off]; + + /* Skip repetition instruction */ + eng.cod += 4; + } + else { + /* Last try failed */ + len = eng.cod[2] | (eng.cod[3] << 8); + if (eng.sv[eng.off] >= eng.so[eng.off]) { + /* Something matched earlier, update */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.sv[eng.off]; + eng.str = eng.bas + eng.eo[bas]; + } + else { + /* Do it here, so that the fail label does + * not need to do too expensive work for + * simple patterns. */ + eng.so[bas] = eng.str - eng.bas; + + /* Zero matches, pop stack and restart */ + --eng.off; + goto fail; + } + + /* Pop stack and skip code */ + --eng.off; + eng.cod += len; + } + } + continue; + + + /**************************************************** + * Repetition with arguments * + ****************************************************/ + case Re_Exact: +#define COMPLEX_REPETITION_SETUP_0() \ + i = eng.cod[1]; \ + bas = eng.cod[2]; + +#define COMPLEX_REPETITION_SETUP() \ + /* First iteration */ \ + if (++eng.off >= MAX_DEPTH) \ + return (RE_ASSERT); \ + \ + /* Remeber number or repetitions */ \ + eng.re[eng.off] = 0; \ + \ + /* Return here for recovery if match fail */ \ + eng.rcod[eng.off] = eng.cod; \ + \ + /* Setup match offsets */ \ + if (eng.so[bas] <= eng.eo[bas]) \ + eng.so[eng.off] = eng.eo[bas]; \ + else \ + eng.so[eng.off] = eng.so[bas]; \ + eng.sv[eng.off] = eng.eo[eng.off] = eng.so[eng.off] - 1;\ + eng.ss[eng.off] = eng.so[bas]; \ + \ + /* Skip repetition instruction */ \ + eng.cod += 5; + + COMPLEX_REPETITION_SETUP_0(); + if (eng.off == bas) { + /* First iteration */ + COMPLEX_REPETITION_SETUP(); + } + else { + if (eng.eo[eng.off] >= eng.so[eng.off] && + eng.eo[eng.off] > eng.sv[eng.off]) { + /* Update offset of match */ + eng.sv[eng.off] = eng.eo[eng.off]; + + /* Update repetition counter */ + if (++eng.re[eng.off] == i) { + /* Matched the required times */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.sv[eng.off]; + eng.str = eng.bas + eng.eo[bas]; + + /* Update code */ + k = eng.cod[3] | (eng.cod[4] << 8); + eng.cod += k; + + /* Pop stack and go for next pattern */ + --eng.off; + continue; + } + + /* Skip repetition instruction */ + eng.cod += 5; + } + else { + /* Do it here, so that the fail label does + * not need to do too expensive work for + * simple patterns. */ + eng.so[bas] = eng.str - eng.bas; + + /* Pop stack and restart */ + --eng.off; + goto fail; + } + } + continue; + + case Re_Min: + COMPLEX_REPETITION_SETUP_0(); + if (eng.off == bas) { + /* First iteration */ + COMPLEX_REPETITION_SETUP(); + } + else { + if (eng.eo[eng.off] >= eng.so[eng.off] && + eng.eo[eng.off] > eng.sv[eng.off]) { + /* Update offset of match */ + eng.sv[eng.off] = eng.eo[eng.off]; + + /* Update repetition counter */ + ++eng.re[eng.off]; + + /* Skip repetition instruction and try again */ + eng.cod += 5; + } + else { + /* Match failed! */ + if (eng.re[eng.off] < i) { + /* Do it here, so that the fail label does + * not need to do too expensive work for + * simple patterns. */ + eng.so[bas] = eng.str - eng.bas; + + /* Didn't match required number of times */ + --eng.off; + goto fail; + } + else { + /* Matched minimum number of times */ + eng.eo[bas] = eng.sv[eng.off]; + eng.str = eng.bas + eng.eo[bas]; + k = eng.cod[3] | (eng.cod[4] << 8); + + /* Update code and pop stack */ + eng.cod += k; + --eng.off; + } + } + } + continue; + + case Re_Max: + COMPLEX_REPETITION_SETUP_0(); + if (eng.off == bas) { + /* First iteration */ + COMPLEX_REPETITION_SETUP(); + } + else { + if (eng.eo[eng.off] >= eng.so[eng.off] && + eng.eo[eng.off] > eng.sv[eng.off]) { + /* Update offset of match */ + eng.sv[eng.off] = eng.eo[eng.off]; + + /* Update repetition counter */ + if (++eng.re[eng.off] == i) { + /* Matched the maximum times */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.sv[eng.off]; + eng.str = eng.bas + eng.eo[bas]; + + k = eng.cod[3] | (eng.cod[4] << 8); + + /* Update code and pop stack */ + eng.cod += k; + --eng.off; + continue; + } + + /* Skip repetition instruction and try again */ + eng.cod += 5; + } + else { + /* No matches, but zero matches are ok */ + k = eng.cod[3] | (eng.cod[4] << 8); + if (eng.sv[eng.off] >= eng.so[eng.off]) { + /* Something matched earlier, update */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.sv[eng.off]; + eng.str = eng.bas + eng.eo[bas]; + } + else { + /* Empty match */ + if (eng.eo[bas] < eng.so[bas]) + eng.eo[bas] = eng.so[bas]; + + /* Try next pattern at correct offset */ + eng.str = eng.bas + eng.eo[bas]; + } + + /* Pop stack and update code */ + --eng.off; + eng.cod += k; + } + } + continue; + + case Re_MinMax: + bas = eng.cod[3]; + if (eng.off == bas) { + /* First iteration */ + COMPLEX_REPETITION_SETUP(); + } + else { + if (eng.eo[eng.off] >= eng.so[eng.off] && + eng.eo[eng.off] > eng.sv[eng.off]) { + /* Update offset of match */ + eng.sv[eng.off] = eng.eo[eng.off]; + + /* Update repetition counter */ + if (++eng.re[eng.off] == eng.cod[2]) { + /* Matched the maximum times */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.sv[eng.off]; + eng.str = eng.bas + eng.eo[bas]; + k = eng.cod[4] | (eng.cod[5] << 8); + + /* Update code and pop stack */ + eng.cod += k; + --eng.off; + continue; + } + + /* Skip repetition instruction and try again */ + eng.cod += 6; + } + else { + /* Match failed! */ + if (eng.re[eng.off] < eng.cod[1]) { + /* Do it here, so that the fail label does + * not need to do too expensive work for + * simple patterns. */ + eng.so[bas] = eng.str - eng.bas; + + /* Didn't match required number of times */ + --eng.off; + goto fail; + } + else { + /* Matched minimum number of times */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.sv[eng.off]; + eng.str = eng.bas + eng.eo[bas]; + k = eng.cod[4] | (eng.cod[5] << 8); + + /* Update code and pop stack */ + eng.cod += k; + --eng.off; + } + } + } + continue; + + + /**************************************************** + * Special repetition handling * + ****************************************************/ + case Re_AnyAnyTimes: + /* code(1) + bas(1) + gbas(1) + jump(2) */ + bas = eng.cod[1]; + if (eng.off == bas) { + /* First iteration */ + if (++eng.off >= MAX_DEPTH) + return (RE_ASSERT); + + /* Return here for recovery if match fail */ + eng.rcod[eng.off] = eng.cod; + + /* If fail, test the next pattern at the same point */ + eng.rstr[eng.off] = eng.str; + + /* Setup match offsets */ + eng.so[eng.off] = eng.str - eng.bas; + eng.eo[eng.off] = eng.so[eng.off] - 1; + + if (newline) + /* Use the repetition counter to store start of + * skipped string, to later check if skipping a + * newline. */ + eng.re[eng.off] = eng.so[eng.off]; + + /* Save start of possible previous matches */ + eng.ss[eng.off] = eng.so[bas]; + + /* Skip repetition instruction */ + eng.cod += 5; + } + else { + /* -1 as an unsigned char */ + if (eng.cod[2] != 0xff) + eng.goff = eng.cod[2]; + else + eng.goff = -1; + + if (newline) { + ptr = eng.bas + eng.re[eng.off]; + str = eng.bas + eng.so[eng.off]; + for (; ptr < str; ptr++) + if (*ptr == '\n') { + eng.cod = eng.rcod[0]; + eng.so[0] = ptr - eng.bas + 1; + eng.eo[0] = eng.so[0] - 1; + eng.rstr[0] = eng.str = ptr + 1; + eng.off = 0; + goto reset; + } + /* If looping, don't do too many noops */ + eng.re[eng.off] = ptr - eng.bas; + } + + if (eng.eo[eng.off] >= eng.so[eng.off]) { + /* Note that this is only true if all possibly + * nested special repetitions also matched. */ + + if (eng.goff >= 0) { + if (eng.cod[5] == Re_Update) + eng.gso[eng.goff] = eng.eo[bas] + + (eng.so[bas] > eng.eo[bas]); + else if (eng.geo[eng.goff] < eng.so[eng.off]) + eng.geo[eng.goff] = eng.so[eng.off]; + } + + /* Jump relative offset */ + len = eng.cod[3] | (eng.cod[4] << 8); + + /* Restore offset from where started trying */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.eo[eng.off]; + + /* Pop stack and skip code */ + --eng.off; + eng.cod += len; + } + else { + /* Only give up if the entire string was scanned */ + if (eng.str < eng.end) { + /* Update restart point for next pattern */ + eng.str = ++eng.rstr[eng.off]; + + /* Reset start of nested match */ + eng.so[eng.off] = eng.str - eng.bas; + + /* Skip repetition instruction */ + eng.cod += 5; + } + else { + /* Entire string scanned and failed */ + + /* Jump relative offset */ + len = eng.cod[3] | (eng.cod[4] << 8); + + /* Restore offset from where started trying */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.ss[eng.off] - 1; + + /* Pop stack and skip code */ + --eng.off; + eng.cod += len; + } + } + } + continue; + + /* This is significantly different than matching <re>.*<re> + * because it may need to restart several times since it is + * possible to find too many false positives, for example: + * a.*b => once one "a" is found, scan all + * the remaining string searching for a "b" + * a.?b => the string may have too many "a"s, but the + * first occurrences of "a" may not be followed + * by any-character and a "b" or a single "b". + */ + case Re_AnyMaybe: + bas = eng.cod[1]; + if (eng.off == bas) { + /* First iteration */ + if (++eng.off >= MAX_DEPTH) + return (RE_ASSERT); + + /* Return here for recovery if match fail */ + eng.rcod[eng.off] = eng.cod; + + /* First try without eating a byte */ + eng.rstr[eng.off] = eng.str; + + /* Remember this is the first try if match fail */ + eng.re[eng.off] = 0; + + /* Setup match offsets */ + eng.so[eng.off] = eng.str - eng.bas; + eng.eo[eng.off] = eng.so[eng.off] - 1; + + /* Save start of possible previous matches */ + eng.ss[eng.off] = eng.so[bas]; + + /* Skip repetition instruction */ + eng.cod += 5; + } + else { + /* -1 as an unsigned char */ + if (eng.cod[2] != 0xff) + eng.goff = eng.cod[2]; + else + eng.goff = -1; + + if (eng.eo[eng.off] >= eng.so[eng.off]) { + /* Something matched */ + + if (eng.goff >= 0) { + if (eng.cod[5] == Re_Update) + eng.gso[eng.goff] = eng.eo[bas] + + (eng.so[bas] > eng.eo[bas]); + else if (eng.geo[eng.goff] < eng.so[eng.off]) + eng.geo[eng.goff] = eng.so[eng.off]; + } + + /* Jump relative offset */ + len = eng.cod[3] | (eng.cod[4] << 8); + + /* Update offset of match */ + eng.eo[bas] = eng.eo[eng.off]; + + /* Pop stack and skip code */ + --eng.off; + eng.cod += len; + } + else if (eng.re[eng.off] == 0 && + (!newline || eng.rstr[eng.off][1] != '\n')) { + /* Try this time skiping a byte */ + ++eng.re[eng.off]; + + /* Reset string, skip code and go try one time more */ + eng.str = ++eng.rstr[eng.off]; + eng.cod += 5; + } + else { + /* Failed to match */ + + /* Update offsets */ + eng.eo[bas] = eng.ss[eng.off]; + eng.so[bas] = eng.eo[bas] + 1; + + eng.str = eng.rstr[eng.off] + (eng.re[eng.off] == 0); + + /* Pop stack and return to toplevel code */ + --eng.off; + if (eng.str >= eng.end) + goto wont; + eng.cod = eng.rcod[bas]; + } + } + continue; + + /* .+ almost identical to .* but requires eating at least one byte */ + case Re_AnyAtLeast: + bas = eng.cod[1]; + if (eng.off == bas) { + /* First iteration */ + if (++eng.off >= MAX_DEPTH) + return (RE_ASSERT); + + /* Return here for recovery if match fail */ + eng.rcod[eng.off] = eng.cod; + + /* Skip one byte for the restart string */ + if (newline && eng.str[0] == '\n') { + /* Cannot skip newline */ + eng.cod = eng.rcod[0]; + eng.rstr[0] = ++eng.str; + eng.so[0] = eng.str - eng.bas; + eng.eo[0] = eng.so[0] - 1; + eng.off = 0; + goto reset; + } + eng.rstr[eng.off] = ++eng.str; + + /* Setup match offsets */ + eng.so[eng.off] = eng.str - eng.bas; + eng.eo[eng.off] = eng.so[eng.off] - 1; + + if (newline) + /* Use the repetition counter to store start of + * skipped string, to later check if skipping a + * newline. */ + eng.re[eng.off] = eng.so[eng.off]; + + /* Save start of possible previous matches */ + eng.ss[eng.off] = eng.so[bas]; + + /* Skip repetition instruction */ + eng.cod += 5; + } + else { + /* -1 as an unsigned char */ + if (eng.cod[2] != 0xff) + eng.goff = eng.cod[2]; + else + eng.goff = -1; + + if (newline) { + ptr = eng.bas + eng.re[eng.off]; + str = eng.bas + eng.so[eng.off]; + for (; ptr < str; ptr++) + if (*ptr == '\n') { + eng.cod = eng.rcod[0]; + eng.so[0] = ptr - eng.bas + 1; + eng.eo[0] = eng.so[0] - 1; + eng.rstr[0] = eng.str = ptr + 1; + eng.off = 0; + goto reset; + } + /* If looping, don't do too many noops */ + eng.re[eng.off] = ptr - eng.bas; + } + + if (eng.eo[eng.off] >= eng.so[eng.off]) { + /* Note that this is only true if all possibly + * nested special repetitions also matched. */ + + if (eng.goff >= 0) { + if (eng.cod[5] == Re_Update) + eng.gso[eng.goff] = eng.eo[bas] + + (eng.so[bas] > eng.eo[bas]); + else if (eng.geo[eng.goff] < eng.so[eng.off]) + eng.geo[eng.goff] = eng.so[eng.off]; + } + + /* Jump relative offset */ + len = eng.cod[3] | (eng.cod[4] << 8); + + /* Restore offset from where started trying */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.eo[eng.off]; + + /* Pop stack and skip code */ + --eng.off; + eng.cod += len; + } + else { + /* Only give up if the entire string was scanned */ + if (eng.str < eng.end) { + /* Update restart point for next pattern */ + eng.str = ++eng.rstr[eng.off]; + + /* Reset start of nested match */ + eng.so[eng.off] = eng.str - eng.bas; + + /* Skip repetition instruction */ + eng.cod += 5; + } + else { + /* Entire string scanned and failed */ + + /* Jump relative offset */ + len = eng.cod[3] | (eng.cod[4] << 8); + + /* Restore offset from where started trying */ + eng.so[bas] = eng.ss[eng.off]; + eng.eo[bas] = eng.ss[eng.off] - 1; + + /* Pop stack and skip code */ + --eng.off; + eng.cod += len; + } + } + } + continue; + + + /**************************************************** + * Repetition matched! * + ****************************************************/ + case Re_RepJump: + /* eng.cod[1] is toplevel offset of repetition */ + if (eng.off > eng.cod[1]) + /* If still needs to try matches */ + eng.cod -= eng.cod[2]; + else + eng.cod += 3; /* + RepJump + bas + len-size */ + continue; + + case Re_RepLongJump: + /* eng.cod[1] is toplevel offset of repetition */ + if (eng.off > eng.cod[1]) + /* If still needs to try matches */ + eng.cod -= eng.cod[2] | (eng.cod[3] << 8); + else + eng.cod += 4; /* + RepLongJump + bas + len-size */ + continue; + + /**************************************************** + * Finished * + ****************************************************/ + case Re_DoneIf: + if (eng.eo[eng.off] >= eng.so[eng.off]) { + eng.so[0] = eng.ss[eng.off]; + eng.eo[0] = eng.eo[eng.off]; + goto done; + } + ++eng.cod; + continue; + case Re_MaybeDone: + if (eng.eo[eng.off] >= eng.so[eng.off]) { + eng.so[0] = eng.ss[eng.off]; + eng.eo[0] = eng.eo[eng.off]; + goto done; + } + ++eng.cod; + continue; + case Re_Done: + goto done; + + default: + /* Fatal internal error */ + return (RE_ASSERT); + } + + +wont: + /* Surely won't match */ + if (eng.off == 0) { + eng.eo[0] = eng.so[0] - 1; + break; + } + + +fail: + if (eng.off == 0) { + /* If the entire string scanned */ + if (++eng.str > eng.end) { + eng.eo[0] = eng.so[0] - 1; + break; + } + eng.goff = -1; + /* Update start of possible match after restart */ + if (eng.eo[0] >= eng.so[0]) { + /* If first fail */ + eng.str = eng.rstr[0]; + ++eng.rstr[0]; + eng.so[0] = eng.str - eng.bas; + eng.eo[0] = eng.so[eng.off] - 1; + } + else + /* Just trying at next byte */ + ++eng.so[0]; + } + else + /* Remember this match failed */ + eng.eo[eng.off] = eng.so[eng.off] - 1; + + /* Restart code */ + eng.cod = eng.rcod[eng.off]; + continue; + + +match: + /* If first match */ + if (eng.eo[eng.off] < eng.so[eng.off]) { + if (eng.off == 0) + eng.rstr[0] = eng.str + 1; + eng.so[eng.off] = eng.eo[eng.off] = eng.str - eng.bas; + } + eng.eo[eng.off] += si; + eng.cod += ci; + eng.str += si; + ci = si = 1; + continue; + +done: + break; + } + + if (nmatch) { + if (flags & RE_STARTEND) + len = pmat[0].rm_so; + else + len = 0; + if (!nosub) { + if (preg->cod[1] != 0xff) + eng.goff = preg->cod[1]; + pmat[0].rm_so = eng.so[0]; + pmat[0].rm_eo = eng.eo[0]; + for (i = 1; i < nmatch; i++) { + if (i - 1 <= eng.goff) { + pmat[i].rm_so = eng.gso[i - 1]; + pmat[i].rm_eo = eng.geo[i - 1]; + } + else { + pmat[i].rm_so = 0; + pmat[i].rm_eo = -1; + } + } + if (len) { + /* Update offsets, since the match was done in a substring */ + j = eng.goff + 2 > nmatch ? nmatch : eng.goff + 2; + for (i = 0; i < j; i++) { + pmat[i].rm_so += len; + pmat[i].rm_eo += len; + } + } + } + else { + /* Already know these values, allow compiling the regex with + * RE_NOSUB to use parenthesis only for grouping, but avoiding + * the runtime overhead of keeping track of the subexpression + * offsets. */ + pmat[0].rm_so = eng.so[0] + len; + pmat[0].rm_eo = eng.eo[0] + len; + } + } + + return (eng.so[0] <= eng.eo[0] ? 0 : RE_NOMATCH); +} + +int +reerror(int ecode, const re_cod *preg, char *ebuffer, int ebuffer_size) +{ + static char *errors[] = { + "No error", + "Failed to match", /* NOMATCH */ + + /* Errors not generated */ + "Invalid regular expression", /* BADPAT */ + "Invalid collating element", /* ECOLLATE */ + "Invalid character class", /* ECTYPE */ + + "`\' applied to unescapable character", /* EESCAPE */ + "Invalid backreference number", /* ESUBREG */ + "Brackets `[ ]' not balanced", /* EBRACK */ + "Parentheses `( )' not balanced", /* EPAREN */ + "Braces `{ }' not balanced", /* EBRACE */ + "Invalid repetition count(s) in `{ }'", /* BADBR */ + "Invalid character range in `[ ]'", /* ERANGE */ + "Out of memory", /* ESPACE */ + "`?', `*', or `+' operand invalid", /* BADRPT */ + "Empty (sub)expression", /* EMPTY */ + "Assertion error - you found a bug", /* ASSERT */ + "Invalid argument" /* INVARG */ + }; + char *str; + + if (ecode >= 0 && ecode < sizeof(errors) / sizeof(errors[0])) + str = errors[ecode]; + else + str = "Unknown error"; + + return (snprintf(ebuffer, ebuffer_size, "%s", str)); +} + +void +refree(re_cod *cod) +{ + free(cod->cod); + cod->cod = NULL; +} + +static void +reinit(void) +{ + int i; + static int first = 1; + + if (!first) + return; + first = 0; + + re__alnum['_'] = 1; + + for (i = '0'; i <= '7'; i++) + re__alnum[i] = re__odigit[i] = re__ddigit[i] = re__xdigit[i] = 1; + + for (; i <= '9'; i++) + re__alnum[i] = re__ddigit[i] = re__xdigit[i] = 1; + + for (i = 'a'; i <= 'f'; i++) + re__alnum[i] = re__xdigit[i] = 1; + for (; i <= 'z'; i++) + re__alnum[i] = 1; + + for (i = 'A'; i <= 'F'; i++) + re__alnum[i] = re__xdigit[i] = 1; + for (; i <= 'Z'; i++) + re__alnum[i] = 1; + + for (i = 1; i < 32; i++) + re__control[i] = 1; + re__control[127] = 1; + /* Don't show tabs as control characters */ + re__control['\t'] = 0; +} + +static int +rec_check(re_inf *inf, int count) +{ + if (inf->len + count >= inf->spc) { + int spc; + unsigned char *cod; + + if ((spc = (count % 64)) != 0) + spc = 64 - spc; + spc += count + inf->spc; + if ((cod = realloc(inf->cod, spc)) == NULL) + return (inf->ecode = RE_ESPACE); + inf->cod = cod; + inf->spc = spc; + } + + return (inf->ecode); +} + +static int +rec_code(re_inf *inf, ReCode code) +{ + if (rec_check(inf, 1) == 0) + inf->cod[inf->len++] = code; + + return (inf->ecode); +} + +static int +rec_byte(re_inf *inf, int value) +{ + if (rec_check(inf, 1) == 0) + inf->cod[inf->len++] = value; + + return (inf->ecode); +} + +static int +rec_code_byte(re_inf *inf, ReCode code, int value) +{ + if (rec_check(inf, 2) == 0) { + inf->cod[inf->len++] = code; + inf->cod[inf->len++] = value; + } + + return (inf->ecode); +} + +static int +rec_length(re_inf *inf, int length) +{ + int lo, hi, two; + + if (length >= 16384) + return (inf->ecode = RE_ESPACE); + + lo = length & 0xff; + hi = length & 0xff00; + two = ((length > 0x7f) != 0) + 1; + if (two == 2) { + hi <<= 1; + hi |= (lo & 0x80) != 0; + lo |= 0x80; + } + + if (rec_check(inf, two) == 0) { + inf->cod[inf->len++] = lo; + if (two == 2) + inf->cod[inf->len++] = hi >> 8; + } + + return (inf->ecode); +} + +static int +rec_byte_byte(re_inf *inf, int value0, int value1) +{ + if (rec_check(inf, 2) == 0) { + inf->cod[inf->len++] = value0; + inf->cod[inf->len++] = value1; + } + + return (inf->ecode); +} + +static int +rec_code_byte_byte(re_inf *inf, ReCode code, int value0, int value1) +{ + if (rec_check(inf, 3) == 0) { + inf->cod[inf->len++] = code; + inf->cod[inf->len++] = value0; + inf->cod[inf->len++] = value1; + } + + return (inf->ecode); +} + +static int +rec_build_alt(re_inf *inf, rec_alt *alt) +{ + int offset, value, bas = inf->bas + 1; + + if (alt) { + if (alt->next) { + if (rec_inc_spc(inf)) + return (inf->ecode); + + /* A real a list of alternatives */ + rec_code(inf, Re_Alt); + + offset = inf->len; /* Remember current offset */ + rec_byte_byte(inf, 0, 0); /* Reserve two bytes for retry address */ + while (alt && inf->ecode == 0) { + if (rec_build_pat(inf, alt->pat)) + break; + alt = alt->next; + if (alt && inf->ecode == 0) { + /* Handle (hyper)complex repetitions */ + if (inf->bas != bas) { + /* Duplicate patterns up to end of expression */ + rec_build_pat(inf, inf->apat); + /* Restore engine state for next alternative(s) */ + rec_alt_spc(inf, bas - 1); + } + + /* If the jump would be so long */ + if ((value = inf->len - offset) >= 16384) { + inf->ecode = RE_ESPACE; + break; + } + inf->cod[offset] = value & 0xff; + inf->cod[offset + 1] = (value & 0xff00) >> 8; + + rec_code(inf, Re_AltNext); + offset = inf->len; + rec_byte_byte(inf, 0, 0); + } + } + if (inf->ecode == 0) { + /* Handle (hyper)complex repetitions */ + if (inf->bas != bas) { + /* Duplicate patterns up to end of expression */ + rec_build_pat(inf, inf->apat); + /* Restore engine state for next alternative(s) */ + rec_alt_spc(inf, bas - 1); + } + + /* If the jump would be so long */ + if ((value = inf->len - offset) >= 16384) + return (inf->ecode = RE_ESPACE); + inf->cod[offset] = value & 0xff; + inf->cod[offset + 1] = (value & 0xff00) >> 8; + /* Last jump is here */ + rec_code(inf, Re_AltDone); + } + rec_dec_spc(inf); + } + else + /* Single alternative */ + rec_build_pat(inf, alt->pat); + } + + return (inf->ecode); +} + +static int +rec_build_pat(re_inf *inf, rec_pat *pat) +{ + rec_pat *apat; + int length, offset = 0, distance, jump = 0, bas = 0; + + while (pat && inf->ecode == 0) { + if (pat->rep) { + bas = inf->bas; + if (pat->type == Rep_Group && !inf->par && rec_code(inf, Re_Open)) + return (inf->ecode); + if (rec_inc_spc(inf)) + return (inf->ecode); + offset = inf->len; + if (rec_build_rep(inf, pat->rep)) + break; + /* Reserve space to jump after repetition done */ + jump = inf->len; + rec_byte_byte(inf, 0, 0); + } + switch (pat->type) { + case Rep_AnyAnyTimes: + case Rep_AnyMaybe: + case Rep_AnyAtLeast: + if (rec_add_spc(inf, pat->type == Rep_AnyMaybe)) + return (inf->ecode); + if (rec_code(inf, (ReCode)pat->type) == 0 && + rec_byte(inf, inf->bas - 1) == 0 && + rec_byte(inf, inf->ref - 1) == 0) + rec_off_spc(inf); + break; + case Rep_Literal: + case Rep_LiteralNot: + case Rep_SearchLiteral: + rec_code_byte(inf, (ReCode)pat->type, pat->data.chr); + break; + case Rep_CaseLiteral: + case Rep_CaseLiteralNot: + case Rep_SearchCaseLiteral: + rec_code_byte_byte(inf, (ReCode)pat->type, + pat->data.cse.lower, pat->data.cse.upper); + break; + case Rep_Range: + case Rep_RangeNot: + if (rec_code(inf, (ReCode)pat->type) == 0) + rec_build_rng(inf, pat->data.rng); + break; + case Rep_String: + case Rep_SearchString: + case Rep_CaseString: + case Rep_SearchCaseString: + rec_code(inf, (ReCode)pat->type); + length = strlen((char*)pat->data.str); + if (rec_length(inf, length) == 0 && rec_check(inf, length) == 0) { + memcpy(inf->cod + inf->len, pat->data.str, length); + inf->len += length; + } + break; + case Rep_Any: + case Rep_AnyEatAnyTimes: + case Rep_AnyEatMaybe: + case Rep_AnyEatAtLeast: + case Rep_Odigit: + case Rep_OdigitNot: + case Rep_Digit: + case Rep_DigitNot: + case Rep_Xdigit: + case Rep_XdigitNot: + case Rep_Space: + case Rep_SpaceNot: + case Rep_Tab: + case Rep_Newline: + case Rep_Lower: + case Rep_Upper: + case Rep_Alnum: + case Rep_AlnumNot: + case Rep_Control: + case Rep_ControlNot: + case Rep_Bol: + case Rep_Eol: + case Rep_Bow: + case Rep_Eow: + rec_code(inf, (ReCode)pat->type); + break; + case Rep_Backref: + rec_code_byte(inf, Re_Backref, pat->data.chr); + break; + case Rep_Group: + if (pat->rep == NULL && !inf->par && rec_code(inf, Re_Open)) + break; + apat = inf->apat; + inf->apat = pat->next; + rec_build_grp(inf, pat->data.grp); + inf->apat = apat; + break; + case Rep_StringList: + rec_build_stl(inf, pat->data.stl); + break; + } + if (pat->rep) { +#if 0 + if (rec_dec_spc(inf)) + return (inf->ecode); +#else + if (rec_rep_spc(inf, bas)) + return (inf->ecode); +#endif + distance = inf->len - offset; + if (distance > 255) { + if (rec_code(inf, Re_RepLongJump) || + rec_byte(inf, inf->bas) || + rec_byte(inf, distance & 0xff) || + rec_byte(inf, (distance & 0xff00) >> 8)) + break; + } + else if (rec_code(inf, Re_RepJump) || + rec_byte(inf, inf->bas) || + rec_byte(inf, distance)) + break; + distance = inf->len - offset; + inf->cod[jump] = distance & 0xff; + inf->cod[jump + 1] = (distance & 0xff00) >> 8; + } + pat = pat->next; + } + + return (inf->ecode); +} + +static int +rec_build_rng(re_inf *inf, rec_rng *rng) +{ + if (rec_check(inf, sizeof(rng->range)) == 0) { + memcpy(inf->cod + inf->len, rng->range, sizeof(rng->range)); + inf->len += sizeof(rng->range); + } + + return (inf->ecode); +} + +static int +rec_build_grp(re_inf *inf, rec_grp *grp) +{ + int par = inf->par; + + if (!(inf->flags & RE_NOSUB)) { + ++inf->par; + if (par == 0) + ++inf->ref; + if (rec_build_alt(inf, grp->alt) == 0) { + if (par == 0) { + if (grp->comp) + rec_code_byte(inf, Re_Update, inf->ref - 1); + else + rec_code(inf, Re_Close); + } + } + --inf->par; + } + else + rec_build_alt(inf, grp->alt); + + return (inf->ecode); +} + +static int +rec_build_stl(re_inf *inf, rec_stl *stl) +{ + int i, len, rlen; + ReCode code; + + /* Calculate jump distance information */ + rlen = stl->tlen + stl->nstrs + 4; + /* + code + nstrs + place-offset + data-length */ + + if (stl->nstrs >= LARGE_STL_COUNT) { + rlen += 511; /* Don't write number of strings */ + code = stl->type == Rep_StringList ? + Re_LargeStringList : Re_LargeCaseStringList; + } + else + code = (ReCode)stl->type; + + if (rlen >= 16386) + return (inf->ecode = RE_ESPACE); + if (rec_check(inf, rlen) || + rec_code(inf, code)) + return (inf->ecode); + + /* Space is allocated, just write the data */ + if (stl->nstrs < LARGE_STL_COUNT) + inf->cod[inf->len++] = stl->nstrs; + + inf->cod[inf->len++] = rlen & 0xff; + inf->cod[inf->len++] = (rlen & 0xff00) >> 8; + + if (stl->nstrs < LARGE_STL_COUNT) { + for (i = 0; i < stl->nstrs; i++) + inf->cod[inf->len++] = stl->lens[i]; + for (i = 0; i < stl->nstrs; i++) { + len = stl->lens[i]; + if (len > 2) { + memcpy(inf->cod + inf->len, stl->strs[i], len); + inf->len += len; + } + else { + if (len == 1) + inf->cod[inf->len++] = (long)stl->strs[i]; + else { + inf->cod[inf->len++] = (long)stl->strs[i] & 0xff; + inf->cod[inf->len++] = ((long)stl->strs[i] & 0xff00) >> 8; + } + } + } + } + else { + /* The string length goes before the string itself */ + int j, chl, chu; + + /* Fill everything with an invalid jump address */ + memset(inf->cod + inf->len, 0xff, 512); + for (i = len = 0, j = -1; i < stl->nstrs; i++) { + chl = stl->lens[i] > 2 ? stl->strs[i][0] : (long)stl->strs[i] & 0xff; + if (chl != j) { + inf->cod[inf->len + (chl << 1)] = len & 0xff; + inf->cod[inf->len + (chl << 1) + 1] = (len & 0xff00) >> 8; + if (code == Re_LargeCaseStringList) { + chu = stl->lens[i] > 2 ? + stl->strs[i][1] : ((long)(stl->strs[i]) & 0xff00) >> 8; + inf->cod[inf->len + (chu << 1)] = len & 0xff; + inf->cod[inf->len + (chu << 1) + 1] = (len & 0xff00) >> 8; + } + j = chl; + } + len += stl->lens[i] + 1; + } + inf->len += 512; + + for (i = 0; i < stl->nstrs; i++) { + len = stl->lens[i]; + inf->cod[inf->len++] = len; + if (len > 2) { + memcpy(inf->cod + inf->len, stl->strs[i], len); + inf->len += len; + } + else { + if (len == 1) + inf->cod[inf->len++] = (long)stl->strs[i]; + else { + inf->cod[inf->len++] = (long)stl->strs[i] & 0xff; + inf->cod[inf->len++] = ((long)stl->strs[i] & 0xff00) >> 8; + } + } + } + } + + return (inf->ecode); +} + +static int +rec_build_rep(re_inf *inf, rec_rep *rep) +{ + if (rep) { + switch (rep->type) { + case Rer_AnyTimes: + case Rer_AtLeast: + case Rer_Maybe: + rec_code(inf, (ReCode)rep->type); + break; + case Rer_Exact: + if (rec_code(inf, Re_Exact) == 0) + rec_byte(inf, rep->mine); + break; + case Rer_Min: + if (rec_code(inf, Re_Min) == 0) + rec_byte(inf, rep->mine); + break; + case Rer_Max: + if (rec_code(inf, Re_Max) == 0) + rec_byte(inf, rep->maxc); + break; + case Rer_MinMax: + if (rec_code(inf, Re_MinMax) == 0 && + rec_byte(inf, rep->mine) == 0) + rec_byte(inf, rep->maxc); + break; + } + /* It is incremented in rec_build_pat */ + rec_byte(inf, inf->bas - 1); + } + + return (inf->ecode); +} + +static int +rec_inc_spc(re_inf *inf) +{ + if (++inf->bas >= MAX_DEPTH) + return (inf->ecode = RE_ESPACE); + + return (inf->ecode); +} + +static int +rec_dec_spc(re_inf *inf) +{ + if (--inf->bas < 0) + return (inf->ecode = RE_ASSERT); + + return (inf->ecode); +} + +static int +rec_add_spc(re_inf *inf, int maybe) +{ + if (++inf->bas >= MAX_DEPTH) + return (inf->ecode = RE_ESPACE); + inf->sp[inf->bas] = maybe + 1; + + return (inf->ecode); +} + +/* Could be joined with rec_rep_spc, code almost identical */ +static int +rec_alt_spc(re_inf *inf, int top) +{ + int distance, i, bas = inf->bas; + + while ((inf->bas > top) && inf->sp[inf->bas]) { + /* Jump to this repetition for cleanup */ + distance = inf->len - inf->sr[inf->bas]; + + /* This will generate a jump to a jump decision opcode */ + inf->sj[inf->bas] = inf->len; + + if (distance > 255) { + if (rec_code(inf, Re_RepLongJump) || + rec_byte(inf, inf->bas - 1) || + rec_byte(inf, distance & 0xff) || + rec_byte(inf, (distance & 0xff00) >> 8)) + break; + } + else if (rec_code(inf, Re_RepJump) || + rec_byte(inf, inf->bas - 1) || + rec_byte(inf, distance)) + break; + + /* Top of stack value before repetition, or end condition value */ + --inf->bas; + } + + i = inf->bas + 1; + + if (inf->ecode == 0 && i <= bas && inf->sp[i]) { + /* Only the repetition at the bottom jump to code after testing + * all possibilities */ + distance = inf->len - inf->sr[i]; + inf->cod[inf->sr[i] + 3] = distance & 0xff; + inf->cod[inf->sr[i] + 4] = (distance & 0xff00) >> 8; + + /* The bottom jump is here */ + if (rec_code(inf, inf->sp[i] == 1 ? Re_DoneIf : Re_MaybeDone)) + return (inf->ecode); + + /* Generate jumps to the previous special repetition */ + for (++i; i <= bas; i++) { + if (inf->sp[i]) { + distance = inf->sj[i] - inf->sr[i]; + inf->cod[inf->sr[i] + 3] = distance & 0xff; + inf->cod[inf->sr[i] + 4] = (distance & 0xff00) >> 8; + } + } + } + + return (inf->ecode); +} + +static int +rec_rep_spc(re_inf *inf, int top) +{ + int distance, i, bas = inf->bas; + + while (inf->bas > top) { + if (inf->sp[inf->bas]) { + /* Jump to this repetition for cleanup */ + distance = inf->len - inf->sr[inf->bas]; + + /* This will generate a jump to a jump decision opcode */ + inf->sj[inf->bas] = inf->len; + + if (distance > 255) { + if (rec_code(inf, Re_RepLongJump) || + rec_byte(inf, inf->bas - 1) || + rec_byte(inf, distance & 0xff) || + rec_byte(inf, (distance & 0xff00) >> 8)) + break; + } + else if (rec_code(inf, Re_RepJump) || + rec_byte(inf, inf->bas - 1) || + rec_byte(inf, distance)) + break; + } + + /* Top of stack value before repetition, or end condition value */ + --inf->bas; + } + + /* Find first special repetition offset. XXX This should be a noop */ + for (i = 0; i < bas; i++) + if (inf->sp[i]) + break; + + if (inf->ecode == 0 && i <= bas && inf->sp[i]) { + /* Only the repetition at the bottom jump to code after testing + * all possibilities */ + distance = inf->len - inf->sr[i]; + inf->cod[inf->sr[i] + 3] = distance & 0xff; + inf->cod[inf->sr[i] + 4] = (distance & 0xff00) >> 8; + + /* Generate jumps to the previous special repetition */ + for (++i; i <= bas; i++) { + if (inf->sp[i]) { + distance = inf->sj[i] - inf->sr[i]; + inf->cod[inf->sr[i] + 3] = distance & 0xff; + inf->cod[inf->sr[i] + 4] = (distance & 0xff00) >> 8; + } + } + } + + return (inf->ecode); +} + +static int +rec_off_spc(re_inf *inf) +{ + /* The jump address before the three bytes instruction */ + inf->sr[inf->bas] = inf->len - 3; + /* Don't know yet where to go after done with the special + * repetition, just reserve two bytes for the jump address. */ + return (rec_byte_byte(inf, 0, 0)); +} + +#ifdef DEBUG +static void +redump(re_cod *code) +{ + int i, j, k; + unsigned char *cod = code->cod, *stl; + + if (cod[0] & RE_NOSUB) + printf("Nosub\n"); + if (cod[0] & RE_NEWLINE) + printf("Newline\n"); + ++cod; + if (cod[0] != 0xff) + printf("%d backrefs\n", cod[0] + 1); + ++cod; + for (;;) { + switch (*cod++) { + case Re_Open: + printf("Open"); + break; + case Re_Close: + printf("Close"); + break; + case Re_Update: + printf("Update (%d)", (int)*cod++); + break; + case Re_Alt: + printf("Alt"); + i = cod[0] | cod[1]; + cod += 2; + printf(" %d", i); + break; + case Re_AltNext: + printf("Alt-next"); + i = cod[0] | cod[1]; + cod += 2; + printf(" %d", i); + break; + case Re_AltDone: + printf("Alt-done"); + break; + case Re_AnyTimes: + printf("-> Anytimes %d", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_AnyEatAnyTimes: + printf("Any-eat-anytimes"); + break; + case Re_AnyAnyTimes: + printf("-> Any-anytimes %d", (int)*cod++); + printf(" (%d)", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_AnyEatMaybe: + printf("Any-eat-maybe"); + break; + case Re_AnyMaybe: + printf("-> Any-maybe %d", (int)*cod++); + printf(" (%d)", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_AnyAtLeast: + printf("-> Any-atleast %d", (int)*cod++); + printf(" (%d)", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_AnyEatAtLeast: + printf("Any-eat-atleast"); + break; + case Re_Maybe: + printf("-> Maybe %d", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_AtLeast: + printf("-> Atleast %d", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_Exact: + printf("-> Exact "); + i = *cod++; + printf("%d", i); + printf(" %d", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_Min: + printf("-> Min "); + i = *cod++; + printf("%d", i); + printf(" %d", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_Max: + printf("-> Max "); + i = *cod++; + printf("%d", i); + printf(" %d", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_MinMax: + printf("-> Min-max "); + i = *cod++; + printf("%d ", i); + i = *cod++; + printf("%d", i); + printf(" %d", (int)*cod++); + i = cod[0] | (cod[1] << 8); + cod += 2; + printf(" /%d", i); + break; + case Re_RepJump: + printf("<- Rep-jump %d ", (int)*cod++); + i = *cod++; + printf("%d", i); + break; + case Re_RepLongJump: + printf("<- Rep-long-jump %d ", (int)*cod++); + i = cod[0] | (cod[1] << 8); + printf("%d", i); + break; + case Re_Any: + printf("Any"); + break; + case Re_Odigit: + printf("Odigit"); + break; + case Re_OdigitNot: + printf("Odigit-not"); + break; + case Re_Digit: + printf("Digit"); + break; + case Re_DigitNot: + printf("Digit-not"); + break; + case Re_Xdigit: + printf("Xdigit"); + break; + case Re_XdigitNot: + printf("Xdigit-not"); + break; + case Re_Space: + printf("Space"); + break; + case Re_SpaceNot: + printf("Space-not"); + break; + case Re_Tab: + printf("Tab"); + break; + case Re_Newline: + printf("Newline"); + break; + case Re_Lower: + printf("Lower"); + break; + case Re_Upper: + printf("Upper"); + break; + case Re_Alnum: + printf("Alnum"); + break; + case Re_AlnumNot: + printf("Alnum-not"); + break; + case Re_Control: + printf("Control"); + break; + case Re_ControlNot: + printf("Control-not"); + break; + case Re_Bol: + printf("Bol"); + break; + case Re_Eol: + printf("Eol"); + break; + case Re_Bow: + printf("Bow"); + break; + case Re_Eow: + printf("Eow"); + break; + case Re_Range: + printf("Range "); + goto range; + case Re_RangeNot: + printf("Range-not "); +range: + for (i = 0; i < 256; i += 32) { + for (j = k = 0; j < 32; j++) + k |= (*cod++ & 1) << (31 - j); + printf("%x ", k); + } + break; + case Re_Literal: + printf("Literal %c", *cod++); + break; + case Re_LiteralNot: + printf("Literal-not %c", *cod++); + break; + case Re_SearchLiteral: + printf("Search-literal %c", *cod++); + break; + case Re_CaseLiteral: + printf("Case-literal %c", *cod++); + putchar(*cod++); + break; + case Re_CaseLiteralNot: + printf("Case-literal-not %c", *cod++); + putchar(*cod++); + break; + case Re_SearchCaseLiteral: + printf("Search-case-literal %c", *cod++); + putchar(*cod++); + break; + case Re_String: + printf("String "); + goto string; + case Re_SearchString: + printf("Search-string "); + goto string; + case Re_CaseString: + printf("Case-string "); + goto string; + case Re_SearchCaseString: + printf("Search-case-string "); +string: + i = *cod++; + if (i & 0x80) + i = (i & 0x7f) | (*cod++ << 7); + for (j = 0; j < i; j++) + putchar(*cod++); + break; + case Re_StringList: + printf("String-list"); + goto string_list; + case Re_CaseStringList: + printf("Case-string-list"); +string_list: + j = *cod++; + cod += 2; + stl = cod + j; + for (i = 0; i < j; i++) { + k = *cod++; + putchar(i ? ',' : ' '); + fwrite(stl, k, 1, stdout); + stl += k; + } + cod = stl; + break; + case Re_LargeStringList: + printf("Large-string-list"); +large_string_list: + i = cod[0] | (cod[1] << 8); + stl = cod + i - 1; + for (i = 0, cod += 514; cod < stl; i++) { + k = *cod++; + putchar(i ? ',' : ' '); + fwrite(cod, k, 1, stdout); + cod += k; + } + cod = stl; + break; + case Re_LargeCaseStringList: + printf("Large-case-string-list"); + goto large_string_list; + case Re_Backref: + printf("Backref %d", (int)*cod++); + break; + case Re_DoneIf: + printf("Done-if"); + break; + case Re_MaybeDone: + printf("Maybe-done"); + break; + case Re_Done: + printf("Done\n"); + return; + } + putchar('\n'); + } +} +#endif diff --git a/lisp/re/re.h b/lisp/re/re.h new file mode 100644 index 0000000..332366e --- /dev/null +++ b/lisp/re/re.h @@ -0,0 +1,123 @@ +/* + * Copyright (c) 2002 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/re/re.h,v 1.2 2002/09/23 01:25:41 paulo Exp $ */ + +#include <stdlib.h> +#include <string.h> +#include <ctype.h> + +#ifndef _re_h +#define _re_h + +/* + * Defines + */ + + /* Compile flags options */ +#define REG_BASIC 0000 /* Not used */ +#define REG_EXTENDED 0001 /* Not used, only extended supported */ + +#define RE_ICASE 0002 +#define RE_NOSUB 0004 +#define RE_NEWLINE 0010 +#define RE_NOSPEC 0020 +#define RE_PEND 0040 +#define RE_DUMP 0200 + + + + /* Execute flag options */ +#define RE_NOTBOL 1 +#define RE_NOTEOL 2 +#define RE_STARTEND 4 +#define RE_TRACE 00400 /* Not used/supported */ +#define RE_LARGE 01000 /* Not used/supported */ +#define RE_BACKR 02000 /* Not used/supported */ + + /* Value returned by reexec when match fails */ +#define RE_NOMATCH 1 + /* Compile error values */ +#define RE_BADPAT 2 +#define RE_ECOLLATE 3 +#define RE_ECTYPE 4 +#define RE_EESCAPE 5 +#define RE_ESUBREG 6 +#define RE_EBRACK 7 +#define RE_EPAREN 8 +#define RE_EBRACE 9 +#define RE_EBADBR 10 +#define RE_ERANGE 11 +#define RE_ESPACE 12 +#define RE_BADRPT 13 +#define RE_EMPTY 14 +#define RE_ASSERT 15 +#define RE_INVARG 16 +#define RE_ATOI 255 /* Not used/supported */ +#define RE_ITOA 0400 /* Not used/supported */ + + +/* + * Types + */ + +/* (re)gular expression (mat)ch result */ +typedef struct _re_mat { + long rm_so; + long rm_eo; +} re_mat; + +/* (re)gular expression (cod)e */ +typedef struct _re_cod { + unsigned char *cod; + int re_nsub; /* Public member */ + const char *re_endp; /* Support for RE_PEND */ +} re_cod; + + +/* + * Prototypes + */ + /* compile the given pattern string + * returns 0 on success, error code otherwise */ +int recomp(re_cod *preg, const char *pattern, int flags); + + /* execute the compiled pattern on the string. + * returns 0 if matched, RE_NOMATCH if failed, error code otherwise */ +int reexec(const re_cod *preg, const char *string, + int nmat, re_mat pmat[], int flags); + + /* formats an error message for the given code in ebuffer */ +int reerror(int ecode, const re_cod *preg, char *ebuffer, int ebuffer_size); + + /* frees the given parameter */ +void refree(re_cod *preg); + + +#endif /* _re_h */ diff --git a/lisp/re/rec.c b/lisp/re/rec.c new file mode 100644 index 0000000..20f9fd9 --- /dev/null +++ b/lisp/re/rec.c @@ -0,0 +1,1015 @@ +/* + * Copyright (c) 2002 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/re/rec.c,v 1.4 2003/01/16 06:25:52 paulo Exp $ */ + +#include "rep.h" + +/* + * Types + */ + +/* Information used while compiling the intermediate format of the re. */ +typedef struct _irec_info { + unsigned char *ptr; /* Pointer in the given regex pattern */ + unsigned char *end; /* End of regex pattern */ + int flags; /* Compile flags */ + rec_alt *alt; /* Toplevel first/single alternative */ + + rec_alt *palt; /* Current alternative being compiled */ + rec_grp *pgrp; /* Current group, if any */ + rec_pat *ppat; /* Current pattern, if any */ + + /* Number of open parenthesis, for error checking */ + int nparens; + + int ngrps; /* Number of groups, for backreference */ + + int ecode; +} irec_info; + + +/* + * Prototypes + */ + + /* (i)ntermediate (r)egular (e)xpression (c)ompile + * Generates an intermediate stage compiled regex from + * the specified pattern argument. Basically builds an + * intermediate data structure to analyse and do syntax + * error checking. + */ +static void irec_simple_pattern(irec_info*, rec_pat_t); +static void irec_literal_pattern(irec_info*, int); +static void irec_case_literal_pattern(irec_info*, int); +static void irec_open_group(irec_info*); +static void irec_close_group(irec_info*); +static void irec_range(irec_info*); +static void irec_range_single(irec_info*, int); +static void irec_range_complex(irec_info*, int, int); +static void irec_escape(irec_info*); +static void irec_simple_repetition(irec_info*, rec_rep_t); +static void irec_complex_repetition(irec_info*); +static void irec_add_repetition(irec_info*, rec_rep*); +static void irec_free(irec_info*); +static void irec_free_grp(rec_grp*); +static void irec_free_pats(rec_pat*); + + +/* + * Implementation + */ +rec_alt * +irec_comp(const char *pattern, const char *endp, int flags, int *ecode) +{ + unsigned char *ptr; + rec_alt *alt; + irec_info inf; + + if (pattern == NULL || endp < pattern) { + *ecode = RE_INVARG; + return (NULL); + } + + if (endp == pattern) { + *ecode = RE_EMPTY; + return (NULL); + } + + alt = calloc(1, sizeof(rec_alt)); + if (alt == NULL) { + *ecode = RE_ESPACE; + return (NULL); + } + + inf.ptr = (unsigned char*)pattern; + inf.end = (unsigned char*)endp; + inf.flags = flags; + inf.alt = inf.palt = alt; + inf.pgrp = NULL; + inf.ppat = NULL; + inf.nparens = inf.ngrps = 0; + inf.ecode = 0; + + if (flags & RE_NOSPEC) { + /* Just searching for a character or substring */ + for (; inf.ecode == 0 && inf.ptr < inf.end; inf.ptr++) { + if (!(flags & RE_ICASE) || + (!isupper(*inf.ptr) && !islower(*inf.ptr))) + irec_literal_pattern(&inf, *inf.ptr); + else + irec_case_literal_pattern(&inf, *inf.ptr); + } + } + /* inf.ptr = inf.end is nul if flags & RE_NOSPEC */ + for (; inf.ecode == 0 && inf.ptr < inf.end;) { + switch (*inf.ptr++) { + case '*': + irec_simple_repetition(&inf, Rer_AnyTimes); + break; + case '+': + irec_simple_repetition(&inf, Rer_AtLeast); + break; + case '?': + irec_simple_repetition(&inf, Rer_Maybe); + break; + case '.': + irec_simple_pattern(&inf, Rep_Any); + break; + case '^': + if (flags & RE_NEWLINE) + /* It is up to the user decide if this can match */ + irec_simple_pattern(&inf, Rep_Bol); + else { + for (ptr = inf.ptr - 1; + ptr > (unsigned char*)pattern && *ptr == '('; ptr--) + ; + /* If at the start of a pattern */ + if (ptr == (unsigned char*)pattern || *ptr == '|') + irec_simple_pattern(&inf, Rep_Bol); + else + /* In the middle of a pattern, treat as literal */ + irec_literal_pattern(&inf, '^'); + } + break; + case '$': + if (flags & RE_NEWLINE) + irec_simple_pattern(&inf, Rep_Eol); + else { + /* Look ahead to check if is the last char of a group */ + for (ptr = inf.ptr; ptr < inf.end && *ptr == ')'; ptr++) + ; + if (*ptr == '\0' || *ptr == '|') + /* Last character of pattern, an EOL match */ + irec_simple_pattern(&inf, Rep_Eol); + else + /* Normal character */ + irec_literal_pattern(&inf, '$'); + } + break; + case '(': + irec_open_group(&inf); + break; + case ')': + /* Look ahead to check if need to close the group now */ + ptr = inf.ptr; + if (*ptr != '*' && *ptr != '+' && *ptr != '?' && *ptr != '{') + /* If a repetition does not follow */ + irec_close_group(&inf); + else if (inf.pgrp == NULL) + /* A repetition follows, but current group is implicit */ + inf.ecode = RE_EPAREN; + else + /* Can do this as next character is known */ + inf.ppat = NULL; + break; + case '[': + irec_range(&inf); + break; + case ']': + irec_literal_pattern(&inf, ']'); + break; + case '{': + irec_complex_repetition(&inf); + break; + case '}': + irec_literal_pattern(&inf, '}'); + break; + case '|': + /* If first character in the pattern */ + if (inf.ptr - 1 == (unsigned char*)pattern || + /* If last character in the pattern */ + inf.ptr >= inf.end || + /* If empty pattern */ + inf.ptr[0] == '|' || + inf.ptr[0] == ')') + inf.ecode = RE_EMPTY; + else { + rec_alt *alt = calloc(1, sizeof(rec_alt)); + + if (alt) { + alt->prev = inf.palt; + inf.palt->next = alt; + inf.palt = alt; + inf.ppat = NULL; + } + else + inf.ecode = RE_ESPACE; + } + break; + case '\\': + irec_escape(&inf); + break; + default: + if (!(flags & RE_ICASE) || + (!isupper(inf.ptr[-1]) && !islower(inf.ptr[-1]))) + irec_literal_pattern(&inf, inf.ptr[-1]); + else + irec_case_literal_pattern(&inf, inf.ptr[-1]); + break; + } + } + + /* Check if not all groups closed */ + if (inf.ecode == 0 && inf.nparens) + inf.ecode = RE_EPAREN; + + if (inf.ecode == 0) + inf.ecode = orec_comp(inf.alt, flags); + + /* If an error generated */ + if (inf.ecode) { + irec_free(&inf); + alt = NULL; + } + + *ecode = inf.ecode; + + return (alt); +} + +void +irec_free_alt(rec_alt *alt) +{ + rec_alt *next; + + while (alt) { + next = alt->next; + irec_free_pats(alt->pat); + free(alt); + alt = next; + } +} + + + +static void +irec_simple_pattern(irec_info *inf, rec_pat_t type) +{ + rec_pat *pat; + + /* Always add a new pattern to list */ + if ((pat = calloc(1, sizeof(rec_pat))) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + + pat->type = type; + if ((pat->prev = inf->ppat) != NULL) + inf->ppat->next = pat; + else + inf->palt->pat = pat; + inf->ppat = pat; +} + +static void +irec_literal_pattern(irec_info *inf, int value) +{ + int length; + rec_pat *pat; + unsigned char chr, *str; + + /* If there is a current pattern */ + if (inf->ppat && inf->ppat->rep == NULL) { + switch (inf->ppat->type) { + case Rep_Literal: + /* Start literal string */ + chr = inf->ppat->data.chr; + if ((str = malloc(16)) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + inf->ppat->type = Rep_String; + inf->ppat->data.str = str; + str[0] = chr; + str[1] = value; + str[2] = '\0'; + return; + + case Rep_String: + /* Augments literal string */ + length = strlen((char*)inf->ppat->data.str); + if ((length % 16) >= 14) { + if ((str = realloc(inf->ppat->data.str, + length + 18)) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + inf->ppat->data.str = str; + } + inf->ppat->data.str[length] = value; + inf->ppat->data.str[length + 1] = '\0'; + return; + + default: + /* Anything else is added as a new pattern list element */ + break; + } + } + + if ((pat = calloc(1, sizeof(rec_pat))) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + + pat->type = Rep_Literal; + pat->data.chr = value; + if ((pat->prev = inf->ppat) != NULL) + inf->ppat->next = pat; + else + inf->palt->pat = pat; + inf->ppat = pat; +} + +static void +irec_case_literal_pattern(irec_info *inf, int value) +{ + int length; + rec_pat *pat; + unsigned char plower, pupper, lower, upper, *str; + + lower = tolower(value); + upper = toupper(value); + + /* If there is a current pattern */ + if (inf->ppat && inf->ppat->rep == NULL) { + switch (inf->ppat->type) { + case Rep_CaseLiteral: + /* Start case literal string */ + plower = inf->ppat->data.cse.lower; + pupper = inf->ppat->data.cse.upper; + if ((str = malloc(32)) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + inf->ppat->type = Rep_CaseString; + inf->ppat->data.str = str; + str[0] = plower; + str[1] = pupper; + str[2] = lower; + str[3] = upper; + str[4] = '\0'; + return; + + case Rep_CaseString: + /* Augments case literal string */ + length = strlen((char*)inf->ppat->data.str); + if (((length) % 32) >= 28) { + if ((str = realloc(inf->ppat->data.str, + length + 36)) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + inf->ppat->data.str = str; + } + inf->ppat->data.str[length] = lower; + inf->ppat->data.str[length + 1] = upper; + inf->ppat->data.str[length + 2] = '\0'; + return; + + default: + /* Anything else is added as a new pattern list element */ + break; + } + } + + if ((pat = calloc(1, sizeof(rec_pat))) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + + pat->type = Rep_CaseLiteral; + pat->data.cse.lower = lower; + pat->data.cse.upper = upper; + pat->prev = inf->ppat; + if ((pat->prev = inf->ppat) != NULL) + inf->ppat->next = pat; + else + inf->palt->pat = pat; + inf->ppat = pat; +} + +static void +irec_open_group(irec_info *inf) +{ + rec_pat *pat; + rec_alt *alt; + rec_grp *grp; + + if ((grp = calloc(1, sizeof(rec_grp))) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + + if ((pat = calloc(1, sizeof(rec_pat))) == NULL) { + free(grp); + inf->ecode = RE_ESPACE; + return; + } + + if ((alt = calloc(1, sizeof(rec_alt))) == NULL) { + free(grp); + free(pat); + inf->ecode = RE_ESPACE; + return; + } + + pat->type = Rep_Group; + pat->data.grp = grp; + grp->parent = pat; + grp->palt = inf->palt; + grp->pgrp = inf->pgrp; + grp->alt = alt; + grp->comp = 0; + if ((pat->prev = inf->ppat) != NULL) + inf->ppat->next = pat; + else + inf->palt->pat = pat; + inf->palt = alt; + inf->ppat = NULL; + + /* Only toplevel parenthesis supported */ + if (++inf->nparens == 1) + ++inf->ngrps; + + inf->pgrp = grp; +} + +static void +irec_close_group(irec_info *inf) +{ + if (inf->pgrp == NULL) { + inf->ecode = RE_EPAREN; + return; + } + + inf->palt = inf->pgrp->palt; + inf->ppat = inf->pgrp->parent; + inf->pgrp = inf->pgrp->pgrp; + + --inf->nparens; +} + +static void +irec_range(irec_info *inf) +{ + int count; + rec_pat *pat; + rec_rng *rng; + int not = inf->ptr[0] == '^'; + + if (not) + ++inf->ptr; + + pat = calloc(1, sizeof(rec_pat)); + if (pat == NULL) { + inf->ecode = RE_ESPACE; + return; + } + + rng = calloc(1, sizeof(rec_rng)); + if (pat == NULL) { + free(pat); + inf->ecode = RE_ESPACE; + return; + } + + pat->data.rng = rng; + pat->type = not ? Rep_RangeNot : Rep_Range; + if ((pat->prev = inf->ppat) != NULL) + inf->ppat->next = pat; + else + inf->palt->pat = pat; + inf->ppat = pat; + + /* First pass, add everything seen */ + for (count = 0; inf->ecode == 0; count++) { + /* If bracket not closed */ + if (inf->ptr == inf->end) { + inf->ecode = RE_EBRACK; + return; + } + /* If not the first character */ + else if (inf->ptr[0] == ']' && count) + break; + else { + /* If not a range of characters */ + if (inf->ptr[1] != '-' || inf->ptr[2] == ']') { + irec_range_single(inf, inf->ptr[0]); + ++inf->ptr; + } + else { + if ((inf->flags & RE_NEWLINE) && + inf->ptr[0] < '\n' && inf->ptr[2] > '\n') { + /* Unless it is forced to be a delimiter, don't allow + * a newline in a character range */ + if (inf->ptr[0] == '\n' - 1) + irec_range_single(inf, inf->ptr[0]); + else + irec_range_complex(inf, inf->ptr[0], '\n' - 1); + if (inf->ptr[2] == '\n' + 1) + irec_range_single(inf, inf->ptr[2]); + else + irec_range_complex(inf, '\n' + 1, inf->ptr[2]); + } + else + irec_range_complex(inf, inf->ptr[0], inf->ptr[2]); + inf->ptr += 3; + } + } + } + + /* Skip ] */ + ++inf->ptr; +} + +static void +irec_range_single(irec_info *inf, int value) +{ + if (value >= 0 && value <= 255) + inf->ppat->data.rng->range[value] = 1; + + if (inf->flags & RE_ICASE) { + if (islower(value)) { + value = toupper(value); + if (value >= 0 && value <= 255) + inf->ppat->data.rng->range[value] = 1; + } + else if (isupper(value)) { + value = tolower(value); + if (value >= 0 && value <= 255) + inf->ppat->data.rng->range[value] = 1; + } + } +} + +static void +irec_range_complex(irec_info *inf, int chrf, int chrt) +{ + if (chrf > chrt) { + inf->ecode = RE_ERANGE; + return; + } + + for (; chrf <= chrt; chrf++) + irec_range_single(inf, chrf); +} + +static void +irec_escape(irec_info *inf) +{ + rec_pat *pat; + unsigned char chr = inf->ptr[0]; + + if (chr == 0) { + inf->ecode = RE_EESCAPE; + return; + } + ++inf->ptr; + switch (chr) { + case 'o': + irec_simple_pattern(inf, Rep_Odigit); + break; + case 'O': + irec_simple_pattern(inf, Rep_OdigitNot); + break; + case 'd': + irec_simple_pattern(inf, Rep_Digit); + break; + case 'D': + irec_simple_pattern(inf, Rep_DigitNot); + break; + case 'x': + irec_simple_pattern(inf, Rep_Xdigit); + break; + case 'X': + irec_simple_pattern(inf, Rep_XdigitNot); + break; + case 's': + irec_simple_pattern(inf, Rep_Space); + break; + case 'S': + irec_simple_pattern(inf, Rep_SpaceNot); + break; + case 't': + irec_simple_pattern(inf, Rep_Tab); + break; + case 'n': + irec_simple_pattern(inf, Rep_Newline); + break; + case 'l': + irec_simple_pattern(inf, Rep_Lower); + break; + case 'u': + irec_simple_pattern(inf, Rep_Upper); + break; + case 'w': + irec_simple_pattern(inf, Rep_Alnum); + break; + case 'W': + irec_simple_pattern(inf, Rep_AlnumNot); + break; + case 'c': + irec_simple_pattern(inf, Rep_Control); + break; + case 'C': + irec_simple_pattern(inf, Rep_ControlNot); + break; + case '<': + irec_simple_pattern(inf, Rep_Bow); + break; + case '>': + irec_simple_pattern(inf, Rep_Eow); + break; + case '1': case '2': case '3': + case '4': case '5': case '6': + case '7': case '8': case '9': + if ((inf->flags & RE_NOSUB) || (chr -= '1') >= inf->ngrps) { + inf->ecode = RE_ESUBREG; + return; + } + if ((pat = calloc(1, sizeof(rec_pat))) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + pat->type = Rep_Backref; + pat->data.chr = chr; + pat->prev = inf->ppat; + if (inf->ppat) + inf->ppat->next = pat; + else + inf->palt->pat = pat; + inf->ppat = pat; + break; + + /* True literals */ + case '0': + irec_literal_pattern(inf, '\0'); + break; + case 'a': + irec_literal_pattern(inf, '\a'); + break; + case 'b': + irec_literal_pattern(inf, '\b'); + break; + case 'f': + irec_literal_pattern(inf, '\f'); + break; + case 'r': + irec_literal_pattern(inf, '\r'); + break; + case 'v': + irec_literal_pattern(inf, '\v'); + break; + + default: + /* Don't check if case insensitive regular expression */ + irec_literal_pattern(inf, chr); + break; + } +} + +static void +irec_simple_repetition(irec_info *inf, rec_rep_t type) +{ + rec_rep *rep; + + /* If nowhere to add repetition */ + if ((inf->pgrp == NULL && inf->ppat == NULL) || + /* If repetition already added to last/current pattern */ + (inf->pgrp == NULL && inf->ppat->rep != NULL) || + /* If repetition already added to last/current group */ + (inf->ppat == NULL && inf->pgrp->parent->rep != NULL)) { + inf->ecode = RE_BADRPT; + return; + } + + if ((rep = calloc(1, sizeof(rec_rep))) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + + rep->type = type; + irec_add_repetition(inf, rep); +} + +static void +irec_complex_repetition(irec_info *inf) +{ + int exact; + rec_rep *rep; + long mine, maxc; + unsigned char *end; + + /* If nowhere to add repetition */ + if ((inf->pgrp == NULL && inf->ppat == NULL) || + /* If repetition already added to last/current pattern */ + (inf->pgrp == NULL && inf->ppat->rep != NULL) || + /* If repetition already added to last/current group */ + (inf->ppat == NULL && inf->pgrp->parent->rep != NULL)) { + inf->ecode = RE_EBADBR; + return; + } + + exact = 0; + mine = maxc = -1; + if (inf->ptr[0] == ',') + /* Specify max number of ocurrences only */ + goto domax; + else if (!isdigit(inf->ptr[0])) + goto badbr; + + mine = strtol((char*)inf->ptr, (char**)&end, 10); + inf->ptr = end; + if (inf->ptr[0] == '}') { + exact = 1; + ++inf->ptr; + goto redone; + } + else if (inf->ptr[0] != ',') + goto badbr; + +domax: + /* Add one to skip comma */ + ++inf->ptr; + if (inf->ptr[0] == '}') { + ++inf->ptr; + goto redone; + } + else if (!isdigit(inf->ptr[0])) + goto badbr; + maxc = strtol((char*)inf->ptr, (char**)&end, 10); + inf->ptr = end; + if (inf->ptr[0] != '}') + goto badbr; + ++inf->ptr; + +redone: + if (mine == maxc) { + maxc = -1; + exact = 1; + } + + /* Check range and if min-max parameters are valid */ + if (mine >= 255 || maxc >= 255 || + (mine >= 0 && maxc >= 0 && mine > maxc)) + goto badbr; + + /* Check for noop */ + if (exact && mine == 1) + return; + + if ((rep = calloc(1, sizeof(rec_rep))) == NULL) { + inf->ecode = RE_ESPACE; + return; + } + + /* Convert {0,1} to ? */ + if (mine == 0 && maxc == 1) + rep->type = Rer_Maybe; + else if (exact) { + rep->type = Rer_Exact; + rep->mine = mine; + } + /* Convert {0,} to * */ + else if (mine == 0 && maxc == -1) + rep->type = Rer_AnyTimes; + /* Convert {1,} to + */ + else if (mine == 1 && maxc == -1) + rep->type = Rer_AtLeast; + else if (maxc == -1) { + rep->type = Rer_Min; + rep->mine = mine; + } + else if (mine < 1) { + rep->type = Rer_Max; + rep->maxc = maxc; + } + else { + rep->type = Rer_MinMax; + rep->mine = mine; + rep->maxc = maxc; + } + + irec_add_repetition(inf, rep); + + return; + +badbr: + inf->ecode = RE_EBADBR; +} + +/* The rep argument is allocated and has no reference yet, + * if something fails it must be freed before returning. + */ +static void +irec_add_repetition(irec_info *inf, rec_rep *rep) +{ + int length; + rec_pat *pat; + rec_grp *grp; + rec_rep_t rept; + unsigned char value, upper; + + rept = rep->type; + + if (inf->ppat == NULL) { + rec_pat *any; + rec_grp *grp = inf->pgrp; + + if (rept == Rer_AnyTimes || rept == Rer_Maybe || rept == Re_AtLeast) { + /* Convert (.)* to (.*), ((.))* not handled and may not match */ + any = NULL; + + if (grp->alt && grp->alt->pat) { + for (any = grp->alt->pat; any->next; any = any->next) + ; + switch (any->type) { + case Rep_Any: + break; + case Rep_AnyAnyTimes: + case Rep_AnyMaybe: + case Rep_AnyAtLeast: + free(rep); + inf->ecode = RE_BADRPT; + return; + default: + any = NULL; + break; + } + } + if (any) { + free(rep); + rep = NULL; + any->type = (rept == Rer_AnyTimes) ? Rep_AnyAnyTimes : + (rept == Rer_AtLeast) ? Rep_AnyAtLeast : + Rep_AnyMaybe; + while (grp) { + ++grp->comp; + grp = grp->pgrp; + } + } + } + inf->pgrp->parent->rep = rep; + irec_close_group(inf); + return; + } + + switch (inf->ppat->type) { + case Rep_Bol: + case Rep_Eol: + case Rep_Bow: + case Rep_Eow: + case Rep_AnyAnyTimes: + case Rep_AnyMaybe: + case Rep_AnyAtLeast: + /* Markers that cannot repeat */ + free(rep); + inf->ecode = RE_BADRPT; + return; + + case Rep_Any: + grp = inf->pgrp; + free(rep); + if (rept == Rer_AnyTimes || + rept == Rer_Maybe || + rept == Rer_AtLeast) { + inf->ppat->type = (rept == Rer_AnyTimes) ? + Rep_AnyAnyTimes : + (rept == Rer_Maybe) ? + Rep_AnyMaybe : + Rep_AnyAtLeast; + while (grp) { + ++grp->comp; + grp = grp->pgrp; + } + } + else + /* XXX Not (yet) implemented */ + inf->ecode = RE_BADRPT; + rep = NULL; + break; + + case Rep_String: + if ((pat = calloc(1, sizeof(rec_pat))) == NULL) { + free(rep); + inf->ecode = RE_ESPACE; + return; + } + + length = strlen((char*)inf->ppat->data.str); + pat->type = Rep_Literal; + pat->prev = inf->ppat; + pat->data.chr = inf->ppat->data.str[length - 1]; + if (length == 2) { + /* Must convert to two Rep_Literals */ + value = inf->ppat->data.str[0]; + free(inf->ppat->data.str); + inf->ppat->data.chr = value; + inf->ppat->type = Rep_Literal; + } + else + /* Must remove last character from string */ + inf->ppat->data.str[length - 1] = '\0'; + inf->ppat->next = pat; + inf->ppat = pat; + break; + + case Rep_CaseString: + if ((pat = calloc(1, sizeof(rec_pat))) == NULL) { + free(rep); + inf->ecode = RE_ESPACE; + return; + } + + length = strlen((char*)inf->ppat->data.str); + pat->type = Rep_CaseLiteral; + pat->prev = inf->ppat; + pat->data.cse.lower = inf->ppat->data.str[length - 2]; + pat->data.cse.upper = inf->ppat->data.str[length - 1]; + if (length == 4) { + /* Must convert to two Rep_CaseLiterals */ + value = inf->ppat->data.str[0]; + upper = inf->ppat->data.str[1]; + free(inf->ppat->data.str); + inf->ppat->data.cse.lower = value; + inf->ppat->data.cse.upper = upper; + inf->ppat->next = pat; + inf->ppat->type = Rep_CaseLiteral; + } + else + /* Must remove last character pair from string */ + inf->ppat->data.str[length - 2] = '\0'; + inf->ppat->next = pat; + inf->ppat = pat; + break; + + default: + /* Anything else does not need special handling */ + break; + } + + inf->ppat->rep = rep; +} + +static void +irec_free(irec_info *inf) +{ + irec_free_alt(inf->alt); +} + +static void +irec_free_grp(rec_grp *grp) +{ + if (grp->alt) + irec_free_alt(grp->alt); + free(grp); +} + +static void +irec_free_pats(rec_pat *pat) +{ + rec_pat *next; + rec_pat_t rect; + + while (pat) { + next = pat->next; + if (pat->rep) + free(pat->rep); + rect = pat->type; + if (rect == Rep_Range || rect == Rep_RangeNot) + free(pat->data.rng); + else if (rect == Rep_Group) + irec_free_grp(pat->data.grp); + else if (rect == Rep_StringList) + orec_free_stl(pat->data.stl); + free(pat); + pat = next; + } +} diff --git a/lisp/re/reo.c b/lisp/re/reo.c new file mode 100644 index 0000000..59cbf3b --- /dev/null +++ b/lisp/re/reo.c @@ -0,0 +1,685 @@ +/* + * Copyright (c) 2002 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/re/reo.c,v 1.9 2002/11/15 07:01:33 paulo Exp $ */ + +#include "rep.h" + +/* + * This file is a placeholder to add code to analyse and optimize the + * intermediate data structure generated in rep.c. + * Character ranges are optimized while being generated. + */ + +/* + * Types + */ +typedef struct _orec_inf { + rec_alt *alt; /* Main alternatives list */ + rec_grp *grp; /* Current group pointer */ + int flags; + int ecode; +} orec_inf; + +/* + * Prototypes + */ +static int orec_alt(orec_inf*, rec_alt*); +static int orec_pat(orec_inf*, rec_pat*); +static int orec_grp(orec_inf*, rec_grp*); +static int orec_pat_bad_rpt(orec_inf*, rec_pat*); +static int orec_pat_bad_forward_rpt(orec_inf*, rec_pat*); +static int orec_pat_rng(orec_inf*, rec_pat*); +static int orec_pat_cse(orec_inf*, rec_pat*); +static int orec_pat_cse_can(orec_inf*, rec_pat*); +static int orec_str_list(orec_inf*, rec_alt*, int, int); + +/* + * Initialization + */ +extern unsigned char re__alnum[256]; +extern unsigned char re__odigit[256]; +extern unsigned char re__ddigit[256]; +extern unsigned char re__xdigit[256]; +extern unsigned char re__control[256]; + +/* + * Implementation + */ +int +orec_comp(rec_alt *alt, int flags) +{ + orec_inf inf; + + inf.alt = alt; + inf.grp = NULL; + inf.flags = flags; + inf.ecode = 0; + + orec_alt(&inf, alt); + + return (inf.ecode); +} + +void +orec_free_stl(rec_stl *stl) +{ + int i; + + for (i = 0; i < stl->nstrs; i++) { + if (stl->lens[i] > 2) + free(stl->strs[i]); + } + + free(stl->lens); + free(stl->strs); + free(stl); +} + + +static int +orec_alt(orec_inf *inf, rec_alt *alt) +{ + if (alt) { + rec_alt *ptr = alt; + int ret, count = 0, str = 1, cstr = 1, lits = 0, clits = 0; + + /* Check if can build a string list */ + if (ptr->next) { + /* If more than one alternative */ + while (ptr && (str || cstr)) { + if (ptr->pat == NULL || ptr->pat->rep != NULL) { + cstr = str = 0; + break; + } + if ((inf->flags & RE_ICASE)) { + if (!(ret = orec_pat_cse_can(inf, ptr->pat))) { + cstr = str = 0; + break; + } + if (ret == 1) + ++lits; + else if (ret == 2) + ++clits; + } + else if (ptr->pat->next == NULL) { + if (ptr->pat->type != Rep_String) { + if (ptr->pat->type != Rep_Literal) { + str = 0; + if (ptr->pat->type != Rep_CaseString) { + if (ptr->pat->type != Rep_CaseLiteral) + cstr = 0; + else + ++clits; + } + else if (strlen((char*)ptr->pat->data.str) >= 255) + str = cstr = 0; + } + else + ++lits; + } + else if (strlen((char*)ptr->pat->data.str) >= 255) + str = cstr = 0; + } + else { + str = cstr = 0; + break; + } + if (++count >= 255) + str = cstr = 0; + ptr = ptr->next; + } + + if (str || cstr) { + if (inf->flags & RE_ICASE) { + for (ptr = alt; ptr; ptr = ptr->next) { + if (orec_pat_cse(inf, ptr->pat)) + return (inf->ecode); + } + str = 0; + } + return (orec_str_list(inf, alt, str, count)); + } + } + else if (alt == inf->alt && alt->pat && alt->pat->rep == NULL) { + /* If the toplevel single alternative */ + switch (alt->pat->type) { + /* One of these will always be true for RE_NOSPEC, + * but can also be optimized for simple patterns */ + case Rep_Literal: + alt->pat->type = Rep_SearchLiteral; + break; + case Rep_CaseLiteral: + alt->pat->type = Rep_SearchCaseLiteral; + break; + case Rep_String: + alt->pat->type = Rep_SearchString; + break; + case Rep_CaseString: + alt->pat->type = Rep_SearchCaseString; + break; + default: + break; + } + } + + while (alt) { + orec_pat(inf, alt->pat); + alt = alt->next; + } + } + + return (inf->ecode); +} + +static int +orec_pat(orec_inf *inf, rec_pat *pat) +{ + rec_pat *next; + + while (pat) { + switch (pat->type) { + case Rep_AnyAnyTimes: + if (pat->next == NULL) { + rec_grp *grp = inf->grp; + + next = NULL; + while (grp) { + next = grp->parent->next; + /* Cannot check if is .*$ as the input + * may be a substring */ + if (next) + break; + grp = grp->pgrp; + } + if (next == NULL) { + /* <re>.* */ + pat->type = Rep_AnyEatAnyTimes; + grp = inf->grp; + while (grp) { + --grp->comp; + next = grp->parent->next; + if (next) + break; + grp = grp->pgrp; + } + } + else if (orec_pat_bad_rpt(inf, next)) + return (inf->ecode); + } + else if (orec_pat_bad_rpt(inf, pat->next)) + return (inf->ecode); + break; + case Rep_AnyMaybe: + if (pat->next == NULL) { + rec_grp *grp = inf->grp; + + next = NULL; + while (grp) { + next = grp->parent->next; + if (next) + break; + grp = grp->pgrp; + } + if (next == NULL) { + /* <re>.? */ + pat->type = Rep_AnyEatMaybe; + grp = inf->grp; + while (grp) { + --grp->comp; + next = grp->parent->next; + if (next) + break; + grp = grp->pgrp; + } + } + else if (orec_pat_bad_rpt(inf, next)) + return (inf->ecode); + } + else if (orec_pat_bad_rpt(inf, pat->next)) + return (inf->ecode); + break; + case Rep_AnyAtLeast: + if (pat->next == NULL) { + rec_grp *grp = inf->grp; + + next = NULL; + while (grp) { + next = grp->parent->next; + if (next) + break; + grp = grp->pgrp; + } + if (next == NULL) { + /* <re>.+ */ + pat->type = Rep_AnyEatAtLeast; + grp = inf->grp; + while (grp) { + --grp->comp; + next = grp->parent->next; + if (next) + break; + grp = grp->pgrp; + } + } + else if (orec_pat_bad_rpt(inf, next)) + return (inf->ecode); + } + else if (orec_pat_bad_rpt(inf, pat->next)) + return (inf->ecode); + break; + case Rep_Range: + case Rep_RangeNot: + orec_pat_rng(inf, pat); + break; + case Rep_Group: + orec_grp(inf, pat->data.grp); + break; + default: + break; + } + pat = pat->next; + } + + return (inf->ecode); +} + +static int +orec_pat_bad_rpt(orec_inf *inf, rec_pat *pat) +{ + switch (pat->type) { + /* Not really an error, but aren't supported by the library. + * Includes: .*.*, .+<re>? .*<re>*, (.*)(<re>*), etc. + */ + + /* Not a repetition, but mathes anything... */ + case Rep_Any: + + /* Zero length matches */ + case Rep_Eol: + if (!(inf->flags & RE_NEWLINE)) + break; + case Rep_Bol: + case Rep_Bow: + case Rep_Eow: + + /* Repetitions */ + case Rep_AnyAnyTimes: + case Rep_AnyMaybe: + case Rep_AnyAtLeast: + inf->ecode = RE_BADRPT; + break; + + /* Check if the first group element is a complex pattern */ + case Rep_Group: + if (pat->rep == NULL) { + if (pat->data.grp->alt) { + for (pat = pat->data.grp->alt->pat; pat; pat = pat->next) { + if (orec_pat_bad_rpt(inf, pat)) + break; + } + } + break; + } + /*FALLTHROUGH*/ + default: + if (pat->rep) + inf->ecode = RE_BADRPT; + break; + } + + if (!inf->ecode && pat && pat->next) + orec_pat_bad_forward_rpt(inf, pat->next); + + return (inf->ecode); +} + +static int +orec_pat_bad_forward_rpt(orec_inf *inf, rec_pat *pat) +{ + if (pat->rep) { + switch (pat->rep->type) { + case Rer_MinMax: + if (pat->rep->mine > 0) + break; + case Rer_AnyTimes: + case Rer_Maybe: + case Rer_Max: + inf->ecode = RE_BADRPT; + default: + break; + } + } + else if (pat->type == Rep_Group && + pat->data.grp->alt && + pat->data.grp->alt->pat) + orec_pat_bad_forward_rpt(inf, pat->data.grp->alt->pat); + + return (inf->ecode); +} + +static int +orec_grp(orec_inf *inf, rec_grp *grp) +{ + rec_grp *prev = inf->grp; + + inf->grp = grp; + orec_alt(inf, grp->alt); + /* Could also just say: inf->grp = grp->gparent */ + inf->grp = prev; + + return (inf->ecode); +} + +static int +orec_pat_rng(orec_inf *inf, rec_pat *pat) +{ + int i, j[2], count; + rec_pat_t type = pat->type; + unsigned char *range = pat->data.rng->range; + + for (i = count = j[0] = j[1] = 0; i < 256; i++) { + if (range[i]) { + if (count == 2) { + ++count; + break; + } + j[count++] = i; + } + } + + if (count == 1 || + (count == 2 && + ((islower(j[0]) && toupper(j[0]) == j[1]) || + (isupper(j[0]) && tolower(j[0]) == j[1])))) { + free(pat->data.rng); + if (count == 1) { + pat->data.chr = j[0]; + pat->type = type == Rep_Range ? Rep_Literal : Rep_LiteralNot; + } + else { + pat->data.cse.upper = j[0]; + pat->data.cse.lower = j[1]; + pat->type = type == Rep_Range ? Rep_CaseLiteral : Rep_CaseLiteralNot; + } + } + else { + if (memcmp(re__alnum, range, 256) == 0) + type = type == Rep_Range ? Rep_Alnum : Rep_AlnumNot; + else if (memcmp(re__odigit, range, 256) == 0) + type = type == Rep_Range ? Rep_Odigit : Rep_OdigitNot; + else if (memcmp(re__ddigit, range, 256) == 0) + type = type == Rep_Range ? Rep_Digit : Rep_DigitNot; + else if (memcmp(re__xdigit, range, 256) == 0) + type = type == Rep_Range ? Rep_Xdigit : Rep_XdigitNot; + else if (memcmp(re__control, range, 256) == 0) + type = type == Rep_Range ? Rep_Control : Rep_ControlNot; + + if (type != pat->type) { + free(pat->data.rng); + pat->type = type; + } + } + + return (inf->ecode); +} + +/* Join patterns if required, will only fail on memory allocation failure: + */ +static int +orec_pat_cse(orec_inf *inf, rec_pat *pat) +{ + rec_pat_t type; + int i, len, length; + rec_pat *ptr, *next; + unsigned char *str, *tofree; + + if (pat->next == NULL && pat->type == Rep_CaseString) + return (inf->ecode); + + type = Rep_CaseString; + + /* First calculate how many bytes will be required */ + for (ptr = pat, length = 1; ptr; ptr = ptr->next) { + switch (ptr->type) { + case Rep_Literal: + length += 2; + break; + case Rep_String: + length += strlen((char*)ptr->data.str) << 1; + break; + case Rep_CaseLiteral: + length += 2; + break; + case Rep_CaseString: + length += strlen((char*)ptr->data.str); + break; + default: + break; + } + } + + if ((str = malloc(length)) == NULL) + return (inf->ecode = RE_ESPACE); + + for (ptr = pat, length = 0; ptr; ptr = next) { + tofree = NULL; + next = ptr->next; + switch (ptr->type) { + case Rep_Literal: + str[length++] = ptr->data.chr; + str[length++] = ptr->data.chr; + break; + case Rep_String: + tofree = ptr->data.str; + len = strlen((char*)tofree); + for (i = 0; i < len; i++) { + str[length++] = tofree[i]; + str[length++] = tofree[i]; + } + break; + case Rep_CaseLiteral: + str[length++] = ptr->data.cse.lower; + str[length++] = ptr->data.cse.upper; + break; + case Rep_CaseString: + tofree = ptr->data.str; + len = strlen((char*)tofree); + memcpy(str + length, tofree, len); + length += len; + break; + default: + break; + } + if (tofree) + free(tofree); + if (ptr != pat) + free(ptr); + } + str[length] = '\0'; + + pat->type = type; + pat->data.str = str; + pat->next = NULL; + + return (inf->ecode); +} + +/* Return 0 if the patterns in the list cannot be merged, 1 if will + * be a simple string, 2 if a case string. + * This is useful when building an alternative list that is composed + * only of strings, but the regex is case insensitive, in wich case + * the first pass may have splited some patterns, but if it is a member + * of an alternatives list, the cost of using a string list is smaller */ +static int +orec_pat_cse_can(orec_inf *inf, rec_pat *pat) +{ + int ret; + + if (pat == NULL) + return (0); + + for (ret = 1; pat; pat = pat->next) { + if (pat->rep) + return (0); + switch (pat->type) { + case Rep_Literal: + case Rep_String: + break; + case Rep_CaseLiteral: + case Rep_CaseString: + ret = 2; + break; + default: + return (0); + } + } + + return (ret); +} + + +/* XXX If everything is a (case) byte, the pattern should be + * [abcde] instead of a|b|c|d|e (or [aAbBcCdDeE] instead of aA|bB|cC|dD|eE) + * as a string list works fine, but as a character range + * should be faster, and maybe could be converted here. But not + * very important, if performance is required, it should have already + * been done in the pattern. + */ +static int +orec_str_list(orec_inf *inf, rec_alt *alt, int str, int count) +{ + rec_stl *stl; + rec_pat *pat; + rec_alt *ptr, *next; + int i, j, tlen, len, is; + + if ((stl = calloc(1, sizeof(rec_stl))) == NULL) + return (inf->ecode = RE_ESPACE); + + if ((stl->lens = malloc(sizeof(unsigned char) * count)) == NULL) { + free(stl); + return (inf->ecode = RE_ESPACE); + } + + if ((stl->strs = malloc(sizeof(char*) * count)) == NULL) { + free(stl->lens); + free(stl); + return (inf->ecode = RE_ESPACE); + } + + if ((pat = calloc(1, sizeof(rec_pat))) == NULL) { + free(stl->strs); + free(stl->lens); + free(stl); + return (inf->ecode = RE_ESPACE); + } + + pat->data.stl = stl; + pat->type = Rep_StringList; + stl->type = str ? Resl_StringList : Resl_CaseStringList; + for (i = tlen = 0, ptr = alt; i < count; i++) { + next = ptr->next; + switch (ptr->pat->type) { + case Rep_Literal: + is = len = 1; + break; + case Rep_CaseLiteral: + is = len = 2; + break; + default: + is = 0; + len = strlen((char*)ptr->pat->data.str); + break; + } + tlen += len; + stl->lens[i] = len; + if (!is) { + if (len > 2) + stl->strs[i] = ptr->pat->data.str; + else { + if (len == 1) + stl->strs[i] = (void*)(long)(ptr->pat->data.str[0]); + else + stl->strs[i] = (void*)(long) + (ptr->pat->data.str[0] | + ((int)ptr->pat->data.str[1] << 8)); + free(ptr->pat->data.str); + } + } + else { + if (is == 1) + stl->strs[i] = (void*)(long)ptr->pat->data.chr; + else + stl->strs[i] = (void*)(long) + (ptr->pat->data.cse.lower | + (ptr->pat->data.cse.upper << 8)); + } + free(ptr->pat); + if (i) + free(ptr); + ptr = next; + } + stl->tlen = tlen; + stl->nstrs = count; + + alt->pat = pat; + alt->next = NULL; + + { + int li, lj; + unsigned char ci, cj, *str; + + /* Don't need a stable sort, there shouldn't be duplicated strings, + * but don't check for it either. Only need to make sure that all + * strings that start with the same byte are together */ + for (i = 0; i < count; i++) { + li = stl->lens[i]; + ci = li > 2 ? stl->strs[i][0] : (long)stl->strs[i] & 0xff; + for (j = i + 1; j < count; j++) { + lj = stl->lens[j]; + cj = lj > 2 ? stl->strs[j][0] : (long)stl->strs[j] & 0xff; + if ((count >= LARGE_STL_COUNT && cj < ci) || + (cj == ci && lj > li)) { + /* If both strings start with the same byte, + * put the longer first */ + str = stl->strs[j]; + stl->strs[j] = stl->strs[i]; + stl->strs[i] = str; + stl->lens[j] = li; + stl->lens[i] = lj; + li ^= lj; lj ^= li; li ^= lj; + ci ^= cj; cj ^= ci; ci ^= cj; + } + } + } + } + + return (inf->ecode); +} diff --git a/lisp/re/rep.h b/lisp/re/rep.h new file mode 100644 index 0000000..5e4d5d5 --- /dev/null +++ b/lisp/re/rep.h @@ -0,0 +1,369 @@ +/* + * Copyright (c) 2002 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/re/rep.h,v 1.3 2002/11/25 02:35:32 paulo Exp $ */ + +#include "re.h" + +#ifndef _rep_h +#define _rep_h + +/* + * Local defines + */ + +#ifdef MIN +#undef MIN +#endif +#define MIN(a, b) ((a) < (b) ? (a) : (b)) + +#ifdef MAX +#undef MAX +#endif +#define MAX(a, b) ((a) > (b) ? (a) : (b)) + +/* This value can not be larger than 255, a depth value is the nesting of + * repetition operations and alternatives. The number of nested parenthesis + * does not matter, but a repetition on the pattern inside the parenthesis + * does. Note also that you cannot have more than 9 parenthesis pairs in + * an expression. + * Depth is always at least 1. So for MAX_DEPTH 8, it is only allowed + * 7 complex repetitions. A complex repetition is a dot followed by an + * repetition operator. It is called a complex repetition because dot + * matches anything but the empty string, so the engine needs to test + * all possible combinations until the end of the string is found. + * Repetitions like .* use one depth until the end of the string is found, + * for example a.*b.*c.*d has depth 4, while a*b*c*d has depth 2. + */ +#define MAX_DEPTH 8 + +/* Minimum number of strings to generate a "large" string list, that is, + * sort the strings and allocate 512 extra bytes to map the first string + * with a given initial byte. */ +#define LARGE_STL_COUNT 16 + +/* + * Local types + */ +/* Intermediate compilation types declaration */ + /* (r)egular (e)xpression (c)ompile (c)a(se) */ +typedef struct _rec_cse rec_cse; + + /* (r)egular (e)xpression (c)ompile (r)a(ng)e */ +typedef struct _rec_rng rec_rng; + + /* (r)egular (e)xpression (c)ompile (pat)tern */ +typedef struct _rec_pat rec_pat; + + /* (r)egular (e)xpression (c)ompile (rep)etition */ +typedef struct _rec_rep rec_rep; + + /* (r)egular (e)xpression (c)ompile (gr)ou(p) */ +typedef struct _rec_grp rec_grp; + + /* (r)egular (e)xpression (c)ompile (alt)ernatives */ +typedef struct _rec_alt rec_alt; + + +/* Optimization types */ + /* (r)egular (e)xpression (c)ompile (st)ring (l)ist */ +typedef struct _rec_stl rec_stl; + +/* Final compilation and execution types */ + /* (re)gular expression (inf)ormation */ +typedef struct _re_inf re_inf; + + /* (re)gular expression (eng)ine */ +typedef struct _re_eng re_eng; + + +/* Codes used by the engine */ +typedef enum { + /* Grouping */ + Re_Open, /* ( */ + Re_Close, /* ) */ + Re_Update, /* Like Re_Close, but is inside a loop */ + + /* Alternatives */ + Re_Alt, /* Start alternative list, + next offset */ + Re_AltNext, /* Next alternative, + next offset */ + Re_AltDone, /* Finish alternative list */ + + /* Repetition */ + Re_AnyTimes, /* * */ + Re_Maybe, /* ? */ + Re_AtLeast, /* +, at least one */ + + /* Repetition like */ + Re_AnyAnyTimes, /* .*<re> */ + Re_AnyMaybe, /* .?<re> */ + Re_AnyAtLeast, /* .+<re> */ + + Re_AnyEatAnyTimes, /* Expression ends with .* */ + Re_AnyEatMaybe, /* Expression ends with .? */ + Re_AnyEatAtLeast, /* Expression ends with .+ */ + + /* Repetition with arguments */ + Re_Exact, /* {e} */ + Re_Min, /* {n,} */ + Re_Max, /* {,m} */ + Re_MinMax, /* {n,m} */ + + /* Repetition helper instruction */ + Re_RepJump, /* Special code, go back to repetition */ + Re_RepLongJump, /* Jump needs two bytes */ + /* After the repetition data, all repetitions have an offset + * to the code after the repetition */ + + /* Matching */ + Re_Any, /* . */ + Re_Odigit, /* \o */ + Re_OdigitNot, /* \O */ + Re_Digit, /* \d */ + Re_DigitNot, /* \D */ + Re_Xdigit, /* \x */ + Re_XdigitNot, /* \x */ + Re_Space, /* \s */ + Re_SpaceNot, /* \S */ + Re_Tab, /* \t */ + Re_Newline, /* \n */ + Re_Lower, /* \l */ + Re_Upper, /* \u */ + Re_Alnum, /* \w */ + Re_AlnumNot, /* \W */ + Re_Control, /* \c */ + Re_ControlNot, /* \C */ + Re_Bol, /* ^ */ + Re_Eol, /* $ */ + Re_Bow, /* \< */ + Re_Eow, /* \> */ + + /* Range matching information */ + Re_Range, /* + 256 bytes */ + Re_RangeNot, /* + 256 bytes */ + + /* Matching with arguments */ + Re_Literal, /* + character */ + Re_CaseLiteral, /* + lower + upper */ + Re_LiteralNot, /* + character */ + Re_CaseLiteralNot, /* + lower + upper */ + Re_String, /* + length + string */ + Re_CaseString, /* + length + string in format lower-upper */ + + /* These are useful to start matching, or when RE_NOSPEC is used. */ + Re_SearchLiteral, + Re_SearchCaseLiteral, + Re_SearchString, + Re_SearchCaseString, + + Re_StringList, /* + total-length + lengths + strings */ + Re_CaseStringList, /* + total-length + lengths + strings */ + + Re_LargeStringList, /* + total-length + lengths + map + strings */ + Re_LargeCaseStringList, /* + total-length + lengths + map + strings */ + + /* Backreference */ + Re_Backref, /* + reference number */ + + /* The last codes */ + Re_DoneIf, /* Done if at end of input */ + Re_MaybeDone, /* Done */ + Re_Done /* If this code found, finished execution */ +} ReCode; + + +/* (r)egular (e)xpresssion (pat)rern (t)ype */ +typedef enum _rec_pat_t { + Rep_Literal = Re_Literal, + Rep_CaseLiteral = Re_CaseLiteral, + Rep_LiteralNot = Re_LiteralNot, + Rep_CaseLiteralNot = Re_CaseLiteralNot, + Rep_Range = Re_Range, + Rep_RangeNot = Re_RangeNot, + Rep_String = Re_String, + Rep_CaseString = Re_CaseString, + Rep_SearchLiteral = Re_SearchLiteral, + Rep_SearchCaseLiteral = Re_SearchCaseLiteral, + Rep_SearchString = Re_SearchString, + Rep_SearchCaseString = Re_SearchCaseString, + Rep_Any = Re_Any, + Rep_AnyAnyTimes = Re_AnyAnyTimes, + Rep_AnyEatAnyTimes = Re_AnyEatAnyTimes, + Rep_AnyMaybe = Re_AnyMaybe, + Rep_AnyEatMaybe = Re_AnyEatMaybe, + Rep_AnyAtLeast = Re_AnyAtLeast, + Rep_AnyEatAtLeast = Re_AnyEatAtLeast, + Rep_Odigit = Re_Odigit, + Rep_OdigitNot = Re_OdigitNot, + Rep_Digit = Re_Digit, + Rep_DigitNot = Re_DigitNot, + Rep_Xdigit = Re_Xdigit, + Rep_XdigitNot = Re_XdigitNot, + Rep_Space = Re_Space, + Rep_SpaceNot = Re_SpaceNot, + Rep_Tab = Re_Tab, + Rep_Newline = Re_Newline, + Rep_Lower = Re_Lower, + Rep_Upper = Re_Upper, + Rep_Alnum = Re_Alnum, + Rep_AlnumNot = Re_AlnumNot, + Rep_Control = Re_Control, + Rep_ControlNot = Re_ControlNot, + Rep_Bol = Re_Bol, + Rep_Eol = Re_Eol, + Rep_Bow = Re_Bow, + Rep_Eow = Re_Eow, + Rep_Backref = Re_Backref, + Rep_StringList = Re_StringList, + Rep_Group = Re_Open +} rec_pat_t; + + +/* (r)egular (e)xpression (rep)etition (t)ype */ +typedef enum _rec_rep_t { + Rer_AnyTimes = Re_AnyTimes, + Rer_AtLeast = Re_AtLeast, + Rer_Maybe = Re_Maybe, + Rer_Exact = Re_Exact, + Rer_Min = Re_Min, + Rer_Max = Re_Max, + Rer_MinMax = Re_MinMax +} rec_rep_t; + + +/* Decide at re compilation time what is lowercase and what is uppercase */ +struct _rec_cse { + unsigned char lower; + unsigned char upper; +}; + + +/* A rec_rng is used only during compilation, just a character map */ +struct _rec_rng { + unsigned char range[256]; +}; + + +/* A rec_pat is used only during compilation, and can be viewed as + * a regular expression element like a match to any character, a match + * to the beginning or end of the line, etc. + * It is implemented as a linked list, and does not have nesting. + * The data field can contain: + * chr: the value of a single character to match. + * cse: the upper and lower case value of a character to match. + * rng: a character map to match or not match. + * str: a simple string or a string where every two bytes + * represents the character to match, in lower/upper + * case sequence. + * The rep field is not used for strings, strings are broken in the + * last character in this case. That is, strings are just a concatenation + * of several character matches. + */ +struct _rec_pat { + rec_pat_t type; + rec_pat *next, *prev; /* Linked list information */ + union { + unsigned char chr; + rec_cse cse; + rec_rng *rng; + rec_grp *grp; + unsigned char *str; + rec_stl *stl; + } data; + rec_rep *rep; /* Pattern repetition information */ +}; + + +/* A rec_rep is used only during compilation, and can be viewed as: + * + * ? or * or + or {<e>} or {<m>,} or {,<M>} or {<m>,<M>} + * + * where <e> is "exact", <m> is "minimum" and <M> is "maximum". + * In the compiled step it can also be just a NULL pointer, that + * is actually equivalent to {1}. + */ +struct _rec_rep { + rec_rep_t type; + short mine; /* minimum or exact number of matches */ + short maxc; /* maximum number of matches */ +}; + + +/* A rec_alt is used only during compilation, and can be viewed as: + * + * <re>|<re> + * + * where <re> is any regular expression. The expressions are nested + * using the grp field of the rec_pat structure. + */ +struct _rec_alt { + rec_alt *next, *prev; /* Linked list information */ + rec_pat *pat; +}; + + +/* A rec_grp is a place holder for expressions enclosed in parenthesis + * and is linked to the compilation data by an rec_pat structure. */ +struct _rec_grp { + rec_pat *parent; /* Reference to parent pattern */ + rec_alt *alt; /* The pattern information */ + rec_alt *palt; /* Parent alternative */ + rec_grp *pgrp; /* Nested groups */ + int comp; /* (comp)lex repetition pattern inside group */ +}; + + +/* Optimization compilation types definition */ + /* (r)egular (e)xpression (c)ompile (st)ring (l)ist (t)ype */ +typedef enum { + Resl_StringList = Re_StringList, + Resl_CaseStringList = Re_CaseStringList +} rec_stl_t; + +struct _rec_stl { + rec_stl_t type; + int nstrs; /* Number of strings in list */ + int tlen; /* Total length of all strings */ + unsigned char *lens; /* Vector of string lengths */ + unsigned char **strs; /* The strings */ +}; + + +/* + * Prototypes + */ + /* rep.c */ +rec_alt *irec_comp(const char*, const char*, int, int*); +void irec_free_alt(rec_alt*); + + /* reo.c */ +int orec_comp(rec_alt*, int); +void orec_free_stl(rec_stl*); + +#endif /* _rep_h */ diff --git a/lisp/re/tests.c b/lisp/re/tests.c new file mode 100644 index 0000000..bd5c55d --- /dev/null +++ b/lisp/re/tests.c @@ -0,0 +1,199 @@ +/* + * Copyright (c) 2002 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/re/tests.c,v 1.1 2002/09/08 02:29:50 paulo Exp $ */ + +/* + * Compile with: cc -o tests tests.c -L. -lre + */ + +#include <stdio.h> +#include <string.h> +#include "re.h" + +int +main(int argc, char *argv[]) +{ + re_cod cod; + re_mat mat[10]; + int line, ecode, i, len, group, failed; + long eo, so; + char buf[8192]; + char str[8192]; + FILE *fp = fopen("tests.txt", "r"); + + if (fp == NULL) { + fprintf(stderr, "failed to open tests.txt\n"); + exit(1); + } + + ecode = line = group = failed = 0; + cod.cod = NULL; + while (fgets(buf, sizeof(buf), fp)) { + ++line; + if (buf[0] == '#' || buf[0] == '\n') + continue; + else if (buf[0] == '/') { + char *ptr = strrchr(buf, '/'); + + if (ptr == buf) { + fprintf(stderr, "syntax error at line %d\n", line); + break; + } + else { + int flags = 0; + + refree(&cod); + for (*ptr++ = '\0'; *ptr; ptr++) { + if (*ptr == 'i') + flags |= RE_ICASE; + else if (*ptr == 'n') + flags |= RE_NEWLINE; + } + ecode = recomp(&cod, buf + 1, flags); + failed = ecode; + } + } + else if (buf[0] == '>') { + if (cod.cod == NULL) { + fprintf(stderr, "no previous pattern at line %d\n", line); + break; + } + len = strlen(buf) - 1; + buf[len] = '\0'; + strcpy(str, buf + 1); + for (i = 0, --len; i < len - 1; i++) { + if (str[i] == '\\') { + memmove(str + i, str + i + 1, len); + --len; + switch (str[i]) { + case 'a': + str[i] = '\a'; + break; + case 'b': + str[i] = '\b'; + break; + case 'f': + str[i] = '\f'; + break; + case 'n': + str[i] = '\n'; + break; + case 'r': + str[i] = '\r'; + break; + case 't': + str[i] = '\t'; + break; + case 'v': + str[i] = '\v'; + break; + default: + break; + } + } + } + group = 0; + ecode = reexec(&cod, str, 10, &mat[0], 0); + if (ecode && ecode != RE_NOMATCH) { + reerror(failed, &cod, buf, sizeof(buf)); + fprintf(stderr, "%s, at line %d\n", buf, line); + break; + } + } + else if (buf[0] == ':') { + if (failed) { + len = strlen(buf) - 1; + buf[len] = '\0'; + if (failed == RE_EESCAPE && strcmp(buf, ":EESCAPE") == 0) + continue; + if (failed == RE_ESUBREG && strcmp(buf, ":ESUBREG") == 0) + continue; + if (failed == RE_EBRACK && strcmp(buf, ":EBRACK") == 0) + continue; + if (failed == RE_EPAREN && strcmp(buf, ":EPAREN") == 0) + continue; + if (failed == RE_EBRACE && strcmp(buf, ":EBRACE") == 0) + continue; + if (failed == RE_EBADBR && strcmp(buf, ":EBADBR") == 0) + continue; + if (failed == RE_ERANGE && strcmp(buf, ":ERANGE") == 0) + continue; + if (failed == RE_ESPACE && strcmp(buf, ":ESPACE") == 0) + continue; + if (failed == RE_BADRPT && strcmp(buf, ":BADRPT") == 0) + continue; + if (failed == RE_EMPTY && strcmp(buf, ":EMPTY") == 0) + continue; + reerror(failed, &cod, buf, sizeof(buf)); + fprintf(stderr, "Error value %d doesn't match: %s, at line %d\n", + failed, buf, line); + break; + } + else if (!ecode) { + fprintf(stderr, "found match when shoudn't, at line %d\n", line); + break; + } + } + else { + if (failed) { + reerror(failed, &cod, buf, sizeof(buf)); + fprintf(stderr, "%s, at line %d\n", line); + break; + } + if (sscanf(buf, "%ld,%ld:", &so, &eo) != 2) { + fprintf(stderr, "expecting match offsets at line %d\n", line); + break; + } + else if (ecode) { + fprintf(stderr, "didn't match, at line %d\n", line); + break; + } + else if (group >= 10) { + fprintf(stderr, "syntax error at line %d (too many groups)\n", + line); + break; + } + else if (so != mat[group].rm_so || eo != mat[group].rm_eo) { + fprintf(stderr, "match failed at line %d, got %ld,%ld: ", + line, mat[group].rm_so, mat[group].rm_eo); + if (mat[group].rm_so < mat[group].rm_eo) + fwrite(str + mat[group].rm_so, + mat[group].rm_eo - mat[group].rm_so, 1, stderr); + fputc('\n', stderr); + break; + } + ++group; + } + } + + fclose(fp); + + return (ecode); +} diff --git a/lisp/re/tests.txt b/lisp/re/tests.txt new file mode 100644 index 0000000..e3da032 --- /dev/null +++ b/lisp/re/tests.txt @@ -0,0 +1,461 @@ +# +# Copyright (c) 2002 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/re/tests.txt,v 1.3 2002/11/08 08:01:00 paulo Exp $ + +# Some tests for the library: +# lines starting with # are comments +# lines starting with / are a regular expression pattern +# The pattern must end with / and may be followed by: +# i -> ignore case +# n -> create newline sensitive regex +# lines starting with > are a string input to the last pattern +# To test newline sensitive matching, add \n to the string. +# lines starting with a number are the expected result +# If more than one line, every subsequent line is the +# value of an "subresult". +# :NOMATCH means that the string input should not match + +# Simple string +/abc/ +>abc +0,3: abc +>aaaaaaaaaaaaaaabc +14,17: abc +>xxxxxxxxxxxxxxaaaaaaaaaaaaaaaaabcxx +30,33: abc + +# String list +/abc|bcd|cde/ +>abc +0,3: abc +>aabc +1,4: abc +>xxxbcdef +3,6: bcd +>abdzzzcdabcde +8,11: abc +>xxxxabdecdabdcde +13,16: cde + +# Complex string +/a?bc|ab?c|abc?/ +>abc +0,3: abc +>xxxb +:NOMATCH +>xxxbc +3,5: bc +>sssssab +5,7: ab + +# Another complex string +/a*bc|ab*c|abc*/ +>aaaaaaabc +0,9: aaaaaaabc +>xaaaaaaabc +1,10: aaaaaaabc +>xyzaaaaaaabc +3,12: aaaaaaabc +>abbc +0,4: abbc +>xxabbbbbc +2,9: abbbbbc +>abcccccccccc +0,12: abcccccccccc +>abccccccccccd +0,12: abcccccccccc +>xxxxxxxaaaaaaaaaabbbbbbbbbbbccccccccccc +16,29: abbbbbbbbbbbc +>xxxbbbbbbbbbc +11,13: bc + +# Another complex string +/a+bc|ab+c|abc+/ +>xxxbc +:NOMATCH +>xaaabc +1,6: aaabc +>zzzzaaaaabbc +8,12: abbc +>zzzzaaaabbbbbbcccc +7,15: abbbbbbc + +# Simple pattern +/a.c/ +>abc +0,3: abc +>aaac +1,4: aac +>xac +:NOMATCH +>xaac +1,4: aac +>xxabc +2,5: abc +>xxxaxc +3,6: axc + +# Another simple pattern +/a*c/ +>c +0,1: c +>xxxxxxxxc +8,9: c +>xxxxxxxcc +7,8: c +>ac +0,2: ac +>aaaac +0,5: aaaac +>xac +1,3: ac +>xxxaac +3,6: aac +>xxac +2,4: ac +>xxxxac +4,6: ac + +# Another simple pattern +/a+c/ +>xxaac +2,5: aac +>xxxaaaac +3,8: aaaac +>xaaaabac +6,8: ac +>xxxc +:NOMATCH +>xxxxaaaaccc +4,9: aaaac + +# Another simple pattern +/a{4}b/ +>xabxxaabxxxaaabxxxxaaaab +19,24: aaaab +>aaabaaaab +4,9: aaaab + +# Another simple pattern +/a{4,}b/ +>xxxaaaab +3,8: aaaab +>zaaabzzzaaaaaaaaaaaaaaaab +8,25: aaaaaaaaaaaaaaaab + +# Another simple pattern +/a{,4}b/ +>b +0,1: b +>xxxxxxxxb +8,9: b +>xaaaaaaaaab +6,11: aaaab +>xxxab +3,5: ab +>aaaaaxaaab +6,10: aaab + +# Another simple pattern +/a{2,4}b/ +>xab +:NOMATCH +>xaab +1,4: aab +>xaaab +1,5: aaab +>xxaaaab +2,7: aaaab +>xxxaaaaab +4,9: aaaab + +# Some simple grouping tests +/foo(bar|baz)fee/ +>feebarbazfoobarfee +9,18: foobarfee +12,15: bar +>foofooobazfeefoobazfee +13,22: foobazfee +/f(oo|ee)ba[rz]/ +>barfoebaz +:NOMATCH +>bazfoobar +3,9: foobar +4,6: oo +>barfeebaz +3,9: feebaz +4,6: ee +/\<(int|char)\>/ +>aint character int foo +15,18: int +15,18: int + +# Some complex repetitions +/foo.*bar/ +>barfoblaboofoobarfoobarfoobar +11,17: foobar +/foo.+bar/ +>foobar +:NOMATCH +>fobbarfooxbarfooybar +6,13: fooxbar +/foo.?bar/ +>xfoobar +1,7: foobar +>xxfooxxbar +:NOMATCH +>yyyfootbar +3,10: footbar + +# Some nested complex repetitions +/a.*b.*c/ +>abc +0,3: abc +>xxxxxxxxxabbbbbbbccaaaaabbbc +9,18: abbbbbbbc +/a.+b.*c/ +>xxxabc +:NOMATCH +>xxaxbbc +2,7: axbbc +/a.+b.?c/ +>xaabc +1,5: aabc +>xxaabbc +2,7: aabbc + +# Very complex repetitions +/(foo.*|bar)fee/ +# XXX NOTE +# This pattern does not return the correct offset for the group. +# Support for this may and may not be added. + +>barfoofee +3,9: foofee +>foobarfee +0,9: foobarfee +>xxfobarfee +4,10: barfee +>barfooooooobarfee +3,17: fooooooobarfee +>xxfobarfeefoobar +4,10: barfee +/(foo.+|bar)fee/ +>barfoofee +:NOMATCH +>barfooxfee +3,10: fooxfee +/(foo.?|bar)fee/ +>foobar +:NOMATCH +>bafoofee +2,8:foofee +>bafooofeebarfee +2,9: fooofee +>bafoofeebarfee +2,8: foofee + +# Simple backreference +/(a|b|c)\1/ +>aa +0,2: aa +0,1: a +/(a|b|c)(a|b|c)\1\2/ +>acac +0,4: acac +0,1: a +1,2: c +>xxxxacac +4,8: acac +4,5: a +5,6: c +>xxacabacbcacbbacbcaaccabcaca +24,28: caca +24,25: c +25,26: a +>xyabcccc +4,8: cccc +4,5: c +5,6: c + +# Complex backreference +/(a*b)\1/ +>xxxaaaaabaaaaab +3,15: aaaaabaaaaab +3,9: aaaaab +/(ab+c)\1/ +>xaaabbbcabbbc +3,13: abbbcabbbc +3,8: abbbc +/(ab?c)\1/ +>abcac +:NOMATCH +>abcacabcabc +5,11: abcabc +5,8: abc +>abcacac +3,7: acac +3,5: acac + +# Very complex backreference +/a(.*)b\1/ +>xxxab +3,5: ab +4,4: +>xxxxazzzbzzz +4,12: azzzbzzz +5,8: zzz + +# Case testing +/abc/i +>AbC +0,3: AbC +/[0-9][a-z]+/i +>xxx0aaZxYT9 +3,10: 0aaZxYT +/a.b/i +>aaaaaaaaaaaxB +10,13: axB +/a.*z/i +>xxxAaaaaZ +3,9: AaaaaZ +>xxaaaZaaa +2,6: aaaZ +/\<(lambda|defun|defmacro)\>/i +> (lambda +5,11: lambda +5,11: lambda +/\<(nil|t)\>/i +>it Nil +3,6: Nil +3,6: Nil +/\<(begin|end)\>/i +>beginning the ending EnD +21,24: EnD +21,24: EnD + +# Some newline tests +/a.*/n +>a\naaa +0,1:a +>xyza\naa +3,4: a +/a.+/n +>a\naaa +2,5: aaa +>xyza\naa +5,7: aa +/a.?/n +>a\naaa +0,1: a +>xyza\naa +3,4: a + +# Newline tests envolving complex patterns +/a.*b.*c/n +>xxaa\nzyacb\nabc +11,14: abc +>xxxab\nabc\nc +6,9: abc +/a.+b.*c/n +>ab\nbc\nabbc +6,10: abbc +/a.?b.*c/n +>ab\ncabbc\ncc +4,8: abbc +/^foo$/n +>bar\nfoobar\nfoo +11,14: foo + +# Not so complex test involving a newline... +/^\s*#\s*(define|include)\s+.+/n +>#define\n#include x +8,18: #include x +9,16: include + +# Check if large strings are working +/xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx/ +>zzzxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxzzz +3,259: xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~/ +>String here: ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~/ +13,333: ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ + + +# Some complex repetitions not supported +# Listed here only to make sure the library is not crashing on these +# Repetitions that match an empty match, or an empty string cannot follow +# a complex repetition. A complex repetition is: +# .* or .+ or .? +# .{...} is not supported. +/(.*)(\d*)/ +:BADRPT +/(.*).(\d*)/ +:BADRPT +/(.*)\<(\d*)/ +:BADRPT +/(.*)\s(\d*)/ +:BADRPT +/(.*)\D(\d*)/ +:BADRPT + +# This is a more clear pattern and partially works +/(.*)\D(\d+)/ +>abcW12 +0,6: abcW12 +0,3: abc +4,6: 12 +>abcW12abcW12 +0,6: abcW12 +0,3: abc +4,6: 12 +# This wasn't working in the previous version, but now with only minimal +# matches supported, it works. +>abcW12abcW12a +0,6: abcW12 +0,3: abc +4,6: 12 + +# Note the minimal match +/.*\d/ +>a1a1a1aaaaaaa +0,2: a1 +# Check match offsets +/(.*)\d/ +>a1a1a1aaaaaaa +0,2: a1 +0,1: a +/.*(\d)/ +>a1a1a1aaaaaaa +0,2: a1 +1,2: 1 + +/.*(\d+)/ +:BADRPT diff --git a/lisp/read.c b/lisp/read.c new file mode 100644 index 0000000..b8872a2 --- /dev/null +++ b/lisp/read.c @@ -0,0 +1,2058 @@ +/* + * Copyright (c) 2002 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/read.c,v 1.34 2003/01/13 03:57:58 paulo Exp $ */ + +#include <errno.h> +#include "read.h" +#include "package.h" +#include "write.h" +#include <fcntl.h> +#include <stdarg.h> + +/* This should be visible only in read.c, but if an error is generated, + * the current code in write.c will print it as #<ERROR> */ +#define LABEL_BIT_COUNT 8 +#define LABEL_BIT_MASK 0xff +#define MAX_LABEL_VALUE ((1L << (sizeof(long) * 8 - 9)) - 1) +#define READLABEL(label) \ + (LispObj*)(((label) << LABEL_BIT_COUNT) | READLABEL_MASK) +#define READLABELP(object) \ + (((unsigned long)(object) & LABEL_BIT_MASK) == READLABEL_MASK) +#define READLABEL_VALUE(object) \ + ((long)(object) >> LABEL_BIT_COUNT) + +#define READ_ENTER() \ + LispObj *read__stream = SINPUT; \ + int read__line = LispGetLine(read__stream) +#define READ_ERROR0(format) \ + LispReadError(read__stream, read__line, format) +#define READ_ERROR1(format, arg1) \ + LispReadError(read__stream, read__line, format, arg1) +#define READ_ERROR2(format, arg1, arg2) \ + LispReadError(read__stream, read__line, format, arg1, arg2) + +#define READ_ERROR_EOF() READ_ERROR0("unexpected end of input") +#define READ_ERROR_FIXNUM() READ_ERROR0("number is not a fixnum") +#define READ_ERROR_INVARG() READ_ERROR0("invalid argument") + +/* + * Types + */ +typedef struct _object_info { + long label; /* the read label of this object */ + LispObj *object; /* the resulting object */ + long num_circles; /* references to object before it was completely read */ +} object_info; + +typedef struct _read_info { + int level; /* level of open parentheses */ + + int nodot; /* flag set when reading a "special" list */ + + int discard; /* flag used when reading an unavailable feature */ + + long circle_count; /* if non zero, must resolve some labels */ + + /* information for #<number>= and #<number># */ + object_info *objects; + long num_objects; + + /* could use only the objects field as all circular data is known, + * but check every object so that circular/shared references generated + * by evaluations would not cause an infinite loop at read time */ + LispObj **circles; + long num_circles; +} read_info; + +/* + * Protypes + */ +static LispObj *LispReadChar(LispBuiltin*, int); + +static int LispGetLine(LispObj*); +#ifdef __GNUC__ +#define PRINTF_FORMAT __attribute__ ((format (printf, 3, 4))) +#else +#define PRINTF_FORMAT /**/ +#endif +static void LispReadError(LispObj*, int, char*, ...); +#undef PRINTF_FORMAT +static void LispReadFixCircle(LispObj*, read_info*); +static LispObj *LispReadLabelCircle(LispObj*, read_info*); +static int LispReadCheckCircle(LispObj*, read_info*); +static LispObj *LispDoRead(read_info*); +static int LispSkipWhiteSpace(void); +static LispObj *LispReadList(read_info*); +static LispObj *LispReadQuote(read_info*); +static LispObj *LispReadBackquote(read_info*); +static LispObj *LispReadCommaquote(read_info*); +static LispObj *LispReadObject(int, read_info*); +static LispObj *LispParseAtom(char*, char*, int, int, LispObj*, int); +static LispObj *LispParseNumber(char*, int, LispObj*, int); +static int StringInRadix(char*, int, int); +static int AtomSeparator(int, int, int); +static LispObj *LispReadVector(read_info*); +static LispObj *LispReadMacro(read_info*); +static LispObj *LispReadFunction(read_info*); +static LispObj *LispReadRational(int, read_info*); +static LispObj *LispReadCharacter(read_info*); +static void LispSkipComment(void); +static LispObj *LispReadEval(read_info*); +static LispObj *LispReadComplex(read_info*); +static LispObj *LispReadPathname(read_info*); +static LispObj *LispReadStruct(read_info*); +static LispObj *LispReadMacroArg(read_info*); +static LispObj *LispReadArray(long, read_info*); +static LispObj *LispReadFeature(int, read_info*); +static LispObj *LispEvalFeature(LispObj*); + +/* + * Initialization + */ +static char *Char_Nul[] = {"Null", "Nul", NULL}; +static char *Char_Soh[] = {"Soh", NULL}; +static char *Char_Stx[] = {"Stx", NULL}; +static char *Char_Etx[] = {"Etx", NULL}; +static char *Char_Eot[] = {"Eot", NULL}; +static char *Char_Enq[] = {"Enq", NULL}; +static char *Char_Ack[] = {"Ack", NULL}; +static char *Char_Bel[] = {"Bell", "Bel", NULL}; +static char *Char_Bs[] = {"Backspace", "Bs", NULL}; +static char *Char_Tab[] = {"Tab", NULL}; +static char *Char_Nl[] = {"Newline", "Nl", "Lf", "Linefeed", NULL}; +static char *Char_Vt[] = {"Vt", NULL}; +static char *Char_Np[] = {"Page", "Np", NULL}; +static char *Char_Cr[] = {"Return", "Cr", NULL}; +static char *Char_Ff[] = {"So", "Ff", NULL}; +static char *Char_Si[] = {"Si", NULL}; +static char *Char_Dle[] = {"Dle", NULL}; +static char *Char_Dc1[] = {"Dc1", NULL}; +static char *Char_Dc2[] = {"Dc2", NULL}; +static char *Char_Dc3[] = {"Dc3", NULL}; +static char *Char_Dc4[] = {"Dc4", NULL}; +static char *Char_Nak[] = {"Nak", NULL}; +static char *Char_Syn[] = {"Syn", NULL}; +static char *Char_Etb[] = {"Etb", NULL}; +static char *Char_Can[] = {"Can", NULL}; +static char *Char_Em[] = {"Em", NULL}; +static char *Char_Sub[] = {"Sub", NULL}; +static char *Char_Esc[] = {"Escape", "Esc", NULL}; +static char *Char_Fs[] = {"Fs", NULL}; +static char *Char_Gs[] = {"Gs", NULL}; +static char *Char_Rs[] = {"Rs", NULL}; +static char *Char_Us[] = {"Us", NULL}; +static char *Char_Sp[] = {"Space", "Sp", NULL}; +static char *Char_Del[] = {"Rubout", "Del", "Delete", NULL}; + +LispCharInfo LispChars[256] = { + {Char_Nul}, + {Char_Soh}, + {Char_Stx}, + {Char_Etx}, + {Char_Eot}, + {Char_Enq}, + {Char_Ack}, + {Char_Bel}, + {Char_Bs}, + {Char_Tab}, + {Char_Nl}, + {Char_Vt}, + {Char_Np}, + {Char_Cr}, + {Char_Ff}, + {Char_Si}, + {Char_Dle}, + {Char_Dc1}, + {Char_Dc2}, + {Char_Dc3}, + {Char_Dc4}, + {Char_Nak}, + {Char_Syn}, + {Char_Etb}, + {Char_Can}, + {Char_Em}, + {Char_Sub}, + {Char_Esc}, + {Char_Fs}, + {Char_Gs}, + {Char_Rs}, + {Char_Us}, + {Char_Sp}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {Char_Del}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, + {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL} + +}; + +Atom_id Sand, Sor, Snot; + + +/* + * Implementation + */ +LispObj * +Lisp_Read(LispBuiltin *builtin) +/* + read &optional input-stream eof-error-p eof-value recursive-p + */ +{ + LispObj *result; + + LispObj *input_stream, *eof_error_p, *eof_value, *recursive_p; + + recursive_p = ARGUMENT(3); + eof_value = ARGUMENT(2); + eof_error_p = ARGUMENT(1); + input_stream = ARGUMENT(0); + + if (input_stream == UNSPEC) + input_stream = NIL; + else if (input_stream != NIL) { + CHECK_STREAM(input_stream); + else if (!input_stream->data.stream.readable) + LispDestroy("%s: stream %s is not readable", + STRFUN(builtin), STROBJ(input_stream)); + LispPushInput(input_stream); + } + else if (CONSP(lisp__data.input_list)) { + input_stream = STANDARD_INPUT; + LispPushInput(input_stream); + } + + if (eof_value == UNSPEC) + eof_value = NIL; + + result = LispRead(); + if (input_stream != NIL) + LispPopInput(input_stream); + + if (result == NULL) { + if (eof_error_p != NIL) + LispDestroy("%s: EOF reading stream %s", + STRFUN(builtin), STROBJ(input_stream)); + else + result = eof_value; + } + + return (result); +} + +static LispObj * +LispReadChar(LispBuiltin *builtin, int nohang) +{ + int character; + LispObj *result; + + LispObj *input_stream, *eof_error_p, *eof_value, *recursive_p; + + recursive_p = ARGUMENT(3); + eof_value = ARGUMENT(2); + eof_error_p = ARGUMENT(1); + input_stream = ARGUMENT(0); + + if (input_stream == UNSPEC) + input_stream = NIL; + else if (input_stream != NIL) { + CHECK_STREAM(input_stream); + } + else + input_stream = lisp__data.input; + + if (eof_value == UNSPEC) + eof_value = NIL; + + result = NIL; + character = EOF; + + if (input_stream->data.stream.readable) { + LispFile *file = NULL; + + switch (input_stream->data.stream.type) { + case LispStreamStandard: + case LispStreamFile: + file = FSTREAMP(input_stream); + break; + case LispStreamPipe: + file = IPSTREAMP(input_stream); + break; + case LispStreamString: + character = LispSgetc(SSTREAMP(input_stream)); + break; + default: + break; + } + if (file != NULL) { + if (file->available || file->offset < file->length) + character = LispFgetc(file); + else { + if (nohang && !file->nonblock) { + if (fcntl(file->descriptor, F_SETFL, O_NONBLOCK) < 0) + LispDestroy("%s: fcntl(%d): %s", + STRFUN(builtin), file->descriptor, + strerror(errno)); + file->nonblock = 1; + } + else if (!nohang && file->nonblock) { + if (fcntl(file->descriptor, F_SETFL, 0) < 0) + LispDestroy("%s: fcntl(%d): %s", + STRFUN(builtin), file->descriptor, + strerror(errno)); + file->nonblock = 0; + } + if (nohang) { + unsigned char ch; + + if (read(file->descriptor, &ch, 1) == 1) + character = ch; + else if (errno == EAGAIN) + return (NIL); /* XXX no character available */ + else + character = EOF; + } + else + character = LispFgetc(file); + } + } + } + else + LispDestroy("%s: stream %s is unreadable", + STRFUN(builtin), STROBJ(input_stream)); + + if (character == EOF) { + if (eof_error_p != NIL) + LispDestroy("%s: EOF reading stream %s", + STRFUN(builtin), STROBJ(input_stream)); + + return (eof_value); + } + + return (SCHAR(character)); +} + +LispObj * +Lisp_ReadChar(LispBuiltin *builtin) +/* + read-char &optional input-stream eof-error-p eof-value recursive-p + */ +{ + return (LispReadChar(builtin, 0)); +} + +LispObj * +Lisp_ReadCharNoHang(LispBuiltin *builtin) +/* + read-char-no-hang &optional input-stream eof-error-p eof-value recursive-p + */ +{ + return (LispReadChar(builtin, 1)); +} + +LispObj * +Lisp_ReadLine(LispBuiltin *builtin) +/* + read-line &optional input-stream eof-error-p eof-value recursive-p + */ +{ + char *string; + int ch, length; + LispObj *result, *status = NIL; + + LispObj *input_stream, *eof_error_p, *eof_value, *recursive_p; + + recursive_p = ARGUMENT(3); + eof_value = ARGUMENT(2); + eof_error_p = ARGUMENT(1); + input_stream = ARGUMENT(0); + + if (input_stream == UNSPEC) + input_stream = NIL; + else if (input_stream == NIL) + input_stream = STANDARD_INPUT; + else { + CHECK_STREAM(input_stream); + } + + if (eof_value == UNSPEC) + eof_value = NIL; + + result = NIL; + string = NULL; + length = 0; + + if (!input_stream->data.stream.readable) + LispDestroy("%s: stream %s is unreadable", + STRFUN(builtin), STROBJ(input_stream)); + if (input_stream->data.stream.type == LispStreamString) { + char *start, *end, *ptr; + + if (SSTREAMP(input_stream)->input >= + SSTREAMP(input_stream)->length) { + if (eof_error_p != NIL) + LispDestroy("%s: EOS found reading %s", + STRFUN(builtin), STROBJ(input_stream)); + + status = T; + result = eof_value; + goto read_line_done; + } + + start = SSTREAMP(input_stream)->string + + SSTREAMP(input_stream)->input; + end = SSTREAMP(input_stream)->string + + SSTREAMP(input_stream)->length; + /* Search for a newline */ + for (ptr = start; *ptr != '\n' && ptr < end; ptr++) + ; + if (ptr == end) + status = T; + else if (!SSTREAMP(input_stream)->binary) + ++SSTREAMP(input_stream)->line; + length = ptr - start; + string = LispMalloc(length + 1); + memcpy(string, start, length); + string[length] = '\0'; + result = LSTRING2(string, length); + /* macro LSTRING2 does not make a copy of it's arguments, and + * calls LispMused on it. */ + SSTREAMP(input_stream)->input += length + (status == NIL); + } + else /*if (input_stream->data.stream.type == LispStreamFile || + input_stream->data.stream.type == LispStreamStandard || + input_stream->data.stream.type == LispStreamPipe)*/ { + LispFile *file; + + if (input_stream->data.stream.type == LispStreamPipe) + file = IPSTREAMP(input_stream); + else + file = FSTREAMP(input_stream); + + if (file->nonblock) { + if (fcntl(file->descriptor, F_SETFL, 0) < 0) + LispDestroy("%s: fcntl: %s", + STRFUN(builtin), strerror(errno)); + file->nonblock = 0; + } + + while (1) { + ch = LispFgetc(file); + if (ch == EOF) { + if (length) + break; + if (eof_error_p != NIL) + LispDestroy("%s: EOF found reading %s", + STRFUN(builtin), STROBJ(input_stream)); + if (string) + LispFree(string); + + status = T; + result = eof_value; + goto read_line_done; + } + else if (ch == '\n') + break; + else if ((length % 64) == 0) + string = LispRealloc(string, length + 64); + string[length++] = ch; + } + if (string) { + if ((length % 64) == 0) + string = LispRealloc(string, length + 1); + string[length] = '\0'; + result = LSTRING2(string, length); + } + else + result = STRING(""); + } + +read_line_done: + RETURN(0) = status; + RETURN_COUNT = 1; + + return (result); +} + +LispObj * +LispRead(void) +{ + READ_ENTER(); + read_info info; + LispObj *result, *code = COD; + + info.level = info.nodot = info.discard = 0; + info.circle_count = 0; + info.objects = NULL; + info.num_objects = 0; + + result = LispDoRead(&info); + + /* fix circular/shared lists, note that this is done when returning to + * the toplevel, so, if some circular/shared reference was evaluated, + * it should have generated an expected error */ + if (info.num_objects) { + if (info.circle_count) { + info.circles = NULL; + info.num_circles = 0; + LispReadFixCircle(result, &info); + if (info.num_circles) + LispFree(info.circles); + } + LispFree(info.objects); + } + + if (result == EOLIST) + READ_ERROR0("object cannot start with #\\)"); + else if (result == DOT) + READ_ERROR0("dot allowed only on lists"); + + if (result != NULL && POINTERP(result)) { + if (code == NIL) + COD = result; + else + COD = CONS(COD, result); + } + + return (result); +} + +static int +LispGetLine(LispObj *stream) +{ + int line = -1; + + if (STREAMP(stream)) { + switch (stream->data.stream.type) { + case LispStreamStandard: + case LispStreamFile: + if (!FSTREAMP(stream)->binary) + line = FSTREAMP(stream)->line; + break; + case LispStreamPipe: + if (!IPSTREAMP(stream)->binary) + line = IPSTREAMP(stream)->line; + break; + case LispStreamString: + if (!SSTREAMP(stream)->binary) + line = SSTREAMP(stream)->line; + break; + default: + break; + } + } + else if (stream == NIL && !Stdin->binary) + line = Stdin->line; + + return (line); +} + +static void +LispReadError(LispObj *stream, int line, char *fmt, ...) +{ + char string[128], *buffer_string; + LispObj *buffer = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); + int length; + va_list ap; + + va_start(ap, fmt); + vsnprintf(string, sizeof(string), fmt, ap); + va_end(ap); + + LispFwrite(Stderr, "*** Reading ", 12); + LispWriteObject(buffer, stream); + buffer_string = LispGetSstring(SSTREAMP(buffer), &length); + LispFwrite(Stderr, buffer_string, length); + LispFwrite(Stderr, " at line ", 9); + if (line < 0) + LispFwrite(Stderr, "?\n", 2); + else { + char str[32]; + + sprintf(str, "%d\n", line); + LispFputs(Stderr, str); + } + + LispDestroy("READ: %s", string); +} + +static void +LispReadFixCircle(LispObj *object, read_info *info) +{ + LispObj *cons; + +fix_again: + switch (OBJECT_TYPE(object)) { + case LispCons_t: + for (cons = object; + CONSP(object); + cons = object, object = CDR(object)) { + if (READLABELP(CAR(object))) + CAR(object) = LispReadLabelCircle(CAR(object), info); + else if (LispReadCheckCircle(object, info)) + return; + else + LispReadFixCircle(CAR(object), info); + } + if (READLABELP(object)) + CDR(cons) = LispReadLabelCircle(object, info); + else + goto fix_again; + break; + case LispArray_t: + if (READLABELP(object->data.array.list)) + object->data.array.list = + LispReadLabelCircle(object->data.array.list, info); + else if (!LispReadCheckCircle(object, info)) { + object = object->data.array.list; + goto fix_again; + } + break; + case LispStruct_t: + if (READLABELP(object->data.struc.fields)) + object->data.struc.fields = + LispReadLabelCircle(object->data.struc.fields, info); + else if (!LispReadCheckCircle(object, info)) { + object = object->data.struc.fields; + goto fix_again; + } + break; + case LispQuote_t: + case LispBackquote_t: + case LispFunctionQuote_t: + if (READLABELP(object->data.quote)) + object->data.quote = + LispReadLabelCircle(object->data.quote, info); + else { + object = object->data.quote; + goto fix_again; + } + break; + case LispComma_t: + if (READLABELP(object->data.comma.eval)) + object->data.comma.eval = + LispReadLabelCircle(object->data.comma.eval, info); + else { + object = object->data.comma.eval; + goto fix_again; + } + break; + case LispLambda_t: + if (READLABELP(object->data.lambda.code)) + object->data.lambda.code = + LispReadLabelCircle(object->data.lambda.code, info); + else if (!LispReadCheckCircle(object, info)) { + object = object->data.lambda.code; + goto fix_again; + } + break; + default: + break; + } +} + +static LispObj * +LispReadLabelCircle(LispObj *label, read_info *info) +{ + long i, value = READLABEL_VALUE(label); + + for (i = 0; i < info->num_objects; i++) + if (info->objects[i].label == value) + return (info->objects[i].object); + + LispDestroy("READ: internal error"); + /*NOTREACHED*/ + return (label); +} + +static int +LispReadCheckCircle(LispObj *object, read_info *info) +{ + long i; + + for (i = 0; i < info->num_circles; i++) + if (info->circles[i] == object) + return (1); + + if ((info->num_circles % 16) == 0) + info->circles = LispRealloc(info->circles, sizeof(LispObj*) * + (info->num_circles + 16)); + info->circles[info->num_circles++] = object; + + return (0); +} + +static LispObj * +LispDoRead(read_info *info) +{ + LispObj *object; + int ch = LispSkipWhiteSpace(); + + switch (ch) { + case '(': + object = LispReadList(info); + break; + case ')': + for (ch = LispGet(); ch != EOF && ch != '\n'; ch = LispGet()) { + if (!isspace(ch)) { + LispUnget(ch); + break; + } + } + return (EOLIST); + case EOF: + return (NULL); + case '\'': + object = LispReadQuote(info); + break; + case '`': + object = LispReadBackquote(info); + break; + case ',': + object = LispReadCommaquote(info); + break; + case '#': + object = LispReadMacro(info); + break; + default: + LispUnget(ch); + object = LispReadObject(0, info); + break; + } + + return (object); +} + +static LispObj * +LispReadMacro(read_info *info) +{ + READ_ENTER(); + LispObj *result = NULL; + int ch = LispGet(); + + switch (ch) { + case '(': + result = LispReadVector(info); + break; + case '\'': + result = LispReadFunction(info); + break; + case 'b': + case 'B': + result = LispReadRational(2, info); + break; + case 'o': + case 'O': + result = LispReadRational(8, info); + break; + case 'x': + case 'X': + result = LispReadRational(16, info); + break; + case '\\': + result = LispReadCharacter(info); + break; + case '|': + LispSkipComment(); + result = LispDoRead(info); + break; + case '.': /* eval when compiling */ + case ',': /* eval when loading */ + result = LispReadEval(info); + break; + case 'c': + case 'C': + result = LispReadComplex(info); + break; + case 'p': + case 'P': + result = LispReadPathname(info); + break; + case 's': + case 'S': + result = LispReadStruct(info); + break; + case '+': + result = LispReadFeature(1, info); + break; + case '-': + result = LispReadFeature(0, info); + break; + case ':': + /* Uninterned symbol */ + result = LispReadObject(1, info); + break; + default: + if (isdigit(ch)) { + LispUnget(ch); + result = LispReadMacroArg(info); + } + else if (!info->discard) + READ_ERROR1("undefined dispatch macro character #%c", ch); + break; + } + + return (result); +} + +static LispObj * +LispReadMacroArg(read_info *info) +{ + READ_ENTER(); + LispObj *result = NIL; + long i, integer; + int ch; + + /* skip leading zeros */ + while (ch = LispGet(), ch != EOF && isdigit(ch) && ch == '0') + ; + + if (ch == EOF) + READ_ERROR_EOF(); + + /* if ch is not a number the argument was zero */ + if (isdigit(ch)) { + char stk[32], *str; + int len = 1; + + stk[0] = ch; + for (;;) { + ch = LispGet(); + if (!isdigit(ch)) + break; + if (len + 1 >= sizeof(stk)) + READ_ERROR_FIXNUM(); + stk[len++] = ch; + } + stk[len] = '\0'; + errno = 0; + integer = strtol(stk, &str, 10); + /* number is positive because sign is not processed here */ + if (*str || errno == ERANGE || integer > MOST_POSITIVE_FIXNUM) + READ_ERROR_FIXNUM(); + } + else + integer = 0; + + switch (ch) { + case 'a': + case 'A': + if (integer == 1) { + /* LispReadArray and LispReadList expect + * the '(' being already read */ + if ((ch = LispSkipWhiteSpace()) != '(') { + if (info->discard) + return (ch == EOF ? NULL : NIL); + READ_ERROR0("bad array specification"); + } + result = LispReadVector(info); + } + else + result = LispReadArray(integer, info); + break; + case 'r': + case 'R': + result = LispReadRational(integer, info); + break; + case '=': + if (integer > MAX_LABEL_VALUE) + READ_ERROR_FIXNUM(); + if (!info->discard) { + long num_objects = info->num_objects; + + /* check for duplicated label */ + for (i = 0; i < info->num_objects; i++) { + if (info->objects[i].label == integer) + READ_ERROR1("label #%ld# defined more than once", + integer); + } + info->objects = LispRealloc(info->objects, + sizeof(object_info) * + (num_objects + 1)); + /* if this label is referenced it is a shared/circular object */ + info->objects[num_objects].label = integer; + info->objects[num_objects].object = NULL; + info->objects[num_objects].num_circles = 0; + ++info->num_objects; + result = LispDoRead(info); + if (READLABELP(result) && READLABEL_VALUE(result) == integer) + READ_ERROR2("incorrect syntax #%ld= #%ld#", + integer, integer); + /* any reference to it now is not shared/circular */ + info->objects[num_objects].object = result; + } + else + result = LispDoRead(info); + break; + case '#': + if (integer > MAX_LABEL_VALUE) + READ_ERROR_FIXNUM(); + if (!info->discard) { + /* search object */ + for (i = 0; i < info->num_objects; i++) { + if (info->objects[i].label == integer) { + result = info->objects[i].object; + if (result == NULL) { + ++info->objects[i].num_circles; + ++info->circle_count; + result = READLABEL(integer); + } + break; + } + } + if (i == info->num_objects) + READ_ERROR1("undefined label #%ld#", integer); + } + break; + default: + if (!info->discard) + READ_ERROR1("undefined dispatch macro character #%c", ch); + break; + } + + return (result); +} + +static int +LispSkipWhiteSpace(void) +{ + int ch; + + for (;;) { + while (ch = LispGet(), isspace(ch) && ch != EOF) + ; + if (ch == ';') { + while (ch = LispGet(), ch != '\n' && ch != EOF) + ; + if (ch == EOF) + return (EOF); + } + else + break; + } + + return (ch); +} + +/* any data in the format '(' FORM ')' is read here */ +static LispObj * +LispReadList(read_info *info) +{ + READ_ENTER(); + GC_ENTER(); + LispObj *result, *cons, *object; + int dot = 0; + + ++info->level; + /* check for () */ + object = LispDoRead(info); + if (object == EOLIST) { + --info->level; + + return (NIL); + } + + if (object == DOT) + READ_ERROR0("illegal start of dotted list"); + + result = cons = CONS(object, NIL); + + /* make sure GC will not release data being read */ + GC_PROTECT(result); + + while ((object = LispDoRead(info)) != EOLIST) { + if (object == NULL) + READ_ERROR_EOF(); + if (object == DOT) { + if (info->nodot == info->level) + READ_ERROR0("dotted list not allowed"); + /* this is a dotted list */ + if (dot) + READ_ERROR0("more than one . in list"); + dot = 1; + } + else { + if (dot) { + /* only one object after a dot */ + if (++dot > 2) + READ_ERROR0("more than one object after . in list"); + RPLACD(cons, object); + } + else { + RPLACD(cons, CONS(object, NIL)); + cons = CDR(cons); + } + } + } + + /* this will happen if last list element was a dot */ + if (dot == 1) + READ_ERROR0("illegal end of dotted list"); + + --info->level; + GC_LEAVE(); + + return (result); +} + +static LispObj * +LispReadQuote(read_info *info) +{ + READ_ENTER(); + LispObj *quote = LispDoRead(info), *result; + + if (INVALIDP(quote)) + READ_ERROR_INVARG(); + + result = QUOTE(quote); + + return (result); +} + +static LispObj * +LispReadBackquote(read_info *info) +{ + READ_ENTER(); + LispObj *backquote = LispDoRead(info), *result; + + if (INVALIDP(backquote)) + READ_ERROR_INVARG(); + + result = BACKQUOTE(backquote); + + return (result); +} + +static LispObj * +LispReadCommaquote(read_info *info) +{ + READ_ENTER(); + LispObj *comma, *result; + int atlist = LispGet(); + + if (atlist == EOF) + READ_ERROR_EOF(); + else if (atlist != '@' && atlist != '.') + LispUnget(atlist); + + comma = LispDoRead(info); + if (comma == DOT) { + atlist = '@'; + comma = LispDoRead(info); + } + if (INVALIDP(comma)) + READ_ERROR_INVARG(); + + result = COMMA(comma, atlist == '@' || atlist == '.'); + + return (result); +} + +/* + * Read anything that is not readily identifiable by it's first character + * and also put the code for reading atoms, numbers and strings together. + */ +static LispObj * +LispReadObject(int unintern, read_info *info) +{ + READ_ENTER(); + LispObj *object; + char stk[128], *string, *package, *symbol; + int ch, length, backslash, size, quote, unreadable, collon; + + package = symbol = string = stk; + size = sizeof(stk); + backslash = quote = unreadable = collon = 0; + length = 0; + + ch = LispGet(); + if (unintern && (ch == ':' || ch == '"')) + READ_ERROR0("syntax error after #:"); + else if (ch == '"' || ch == '|') + quote = ch; + else if (ch == '\\') { + unreadable = backslash = 1; + string[length++] = ch; + } + else if (ch == ':') { + collon = 1; + string[length++] = ch; + symbol = string + 1; + } + else if (ch) { + if (islower(ch)) + ch = toupper(ch); + string[length++] = ch; + } + else + unreadable = 1; + + /* read remaining data */ + for (; ch;) { + ch = LispGet(); + + if (ch == EOF) { + if (quote) { + /* if quote, file ended with an open quoted object */ + if (string != stk) + LispFree(string); + return (NULL); + } + break; + } + else if (ch == '\0') + break; + + if (ch == '\\') { + backslash = !backslash; + if (quote == '"') { + /* only remove backslashs from strings */ + if (backslash) + continue; + } + else + unreadable = 1; + } + else if (backslash) + backslash = 0; + else if (ch == quote) + break; + else if (!quote && !backslash) { + if (islower(ch)) + ch = toupper(ch); + else if (isspace(ch)) + break; + else if (AtomSeparator(ch, 0, 0)) { + LispUnget(ch); + break; + } + else if (ch == ':') { + if (collon == 0 || + (collon == (1 - unintern) && symbol == string + length)) { + ++collon; + symbol = string + length + 1; + } + else + READ_ERROR0("too many collons"); + } + } + + if (length + 2 >= size) { + if (string == stk) { + size = 1024; + string = LispMalloc(size); + strcpy(string, stk); + } + else { + size += 1024; + string = LispRealloc(string, size); + } + symbol = string + (symbol - package); + package = string; + } + string[length++] = ch; + } + + if (info->discard) { + if (string != stk) + LispFree(string); + + return (ch == EOF ? NULL : NIL); + } + + string[length] = '\0'; + + if (unintern) { + if (length == 0) + READ_ERROR0("syntax error after #:"); + object = UNINTERNED_ATOM(string); + } + + else if (quote == '"') + object = LSTRING(string, length); + + else if (quote == '|' || (unreadable && !collon)) { + /* Set unreadable field, this atom needs quoting to be read back */ + object = ATOM(string); + object->data.atom->unreadable = 1; + } + + else if (collon) { + /* Package specified in object name */ + symbol[-1] = '\0'; + if (collon > 1) + symbol[-2] = '\0'; + object = LispParseAtom(package, symbol, + collon == 2, unreadable, + read__stream, read__line); + } + + /* Check some common symbols */ + else if (length == 1 && string[0] == 'T') + /* The T */ + object = T; + + else if (length == 1 && string[0] == '.') + /* The dot */ + object = DOT; + + else if (length == 3 && + string[0] == 'N' && string[1] == 'I' && string[2] == 'L') + /* The NIL */ + object = NIL; + + else if (isdigit(string[0]) || string[0] == '.' || + ((string[0] == '-' || string[0] == '+') && string[1])) + /* Looks like a number */ + object = LispParseNumber(string, 10, read__stream, read__line); + + else + /* A normal atom */ + object = ATOM(string); + + if (string != stk) + LispFree(string); + + return (object); +} + +static LispObj * +LispParseAtom(char *package, char *symbol, int intern, int unreadable, + LispObj *read__stream, int read__line) +{ + LispObj *object = NULL, *thepackage = NULL; + LispPackage *pack = NULL; + + if (!unreadable) { + /* Until NIL and T be treated as normal symbols */ + if (symbol[0] == 'N' && symbol[1] == 'I' && + symbol[2] == 'L' && symbol[3] == '\0') + return (NIL); + if (symbol[0] == 'T' && symbol[1] == '\0') + return (T); + unreadable = !LispCheckAtomString(symbol); + } + + /* If package is empty, it is a keyword */ + if (package[0] == '\0') { + thepackage = lisp__data.keyword; + pack = lisp__data.key; + } + + else { + /* Else, search it in the package list */ + thepackage = LispFindPackageFromString(package); + + if (thepackage == NIL) + READ_ERROR1("the package %s is not available", package); + + pack = thepackage->data.package.package; + } + + if (pack == lisp__data.pack && intern) { + /* Redundant package specification, since requesting a + * intern symbol, create it if does not exist */ + + object = ATOM(symbol); + if (unreadable) + object->data.atom->unreadable = 1; + } + + else if (intern || pack == lisp__data.key) { + /* Symbol is created, or just fetched from the specified package */ + + LispPackage *savepack; + LispObj *savepackage = PACKAGE; + + /* Remember curent package */ + savepack = lisp__data.pack; + + /* Temporarily set another package */ + lisp__data.pack = pack; + PACKAGE = thepackage; + + /* Get the object pointer */ + if (pack == lisp__data.key) + object = KEYWORD(LispDoGetAtom(symbol, 0)->string); + else + object = ATOM(symbol); + if (unreadable) + object->data.atom->unreadable = 1; + + /* Restore current package */ + lisp__data.pack = savepack; + PACKAGE = savepackage; + } + + else { + /* Symbol must exist (and be extern) in the specified package */ + + int i; + LispAtom *atom; + + i = STRHASH(symbol); + atom = pack->atoms[i]; + while (atom) { + if (strcmp(atom->string, symbol) == 0) { + object = atom->object; + break; + } + + atom = atom->next; + } + + /* No object found */ + if (object == NULL || object->data.atom->ext == 0) + READ_ERROR2("no extern symbol %s in package %s", symbol, package); + } + + return (object); +} + +static LispObj * +LispParseNumber(char *str, int radix, LispObj *read__stream, int read__line) +{ + int len; + long integer; + double dfloat; + char *ratio, *ptr; + LispObj *number; + mpi *bignum; + mpr *bigratio; + + if (radix < 2 || radix > 36) + READ_ERROR1("radix %d is not in the range 2 to 36", radix); + + if (*str == '\0') + return (NULL); + + ratio = strchr(str, '/'); + if (ratio) { + /* check if looks like a correctly specified ratio */ + if (ratio[1] == '\0' || strchr(ratio + 1, '/') != NULL) + return (ATOM(str)); + + /* ratio must point to an integer in radix base */ + *ratio++ = '\0'; + } + else if (radix == 10) { + int dot = 0; + int type = 0; + + /* check if it is a floating point number */ + ptr = str; + if (*ptr == '-' || *ptr == '+') + ++ptr; + else if (*ptr == '.') { + dot = 1; + ++ptr; + } + while (*ptr) { + if (*ptr == '.') { + if (dot) + return (ATOM(str)); + /* ignore it if last char is a dot */ + if (ptr[1] == '\0') { + *ptr = '\0'; + break; + } + dot = 1; + } + else if (!isdigit(*ptr)) + break; + ++ptr; + } + + switch (*ptr) { + case '\0': + if (dot) /* if dot, it is default float */ + type = 'E'; + break; + case 'E': case 'S': case 'F': case 'D': case 'L': + type = *ptr; + *ptr = 'E'; + break; + default: + return (ATOM(str)); /* syntax error */ + } + + /* if type set, it is not an integer specification */ + if (type) { + if (*ptr) { + int itype = *ptr; + char *ptype = ptr; + + ++ptr; + if (*ptr == '+' || *ptr == '-') + ++ptr; + while (*ptr && isdigit(*ptr)) + ++ptr; + if (*ptr) { + *ptype = itype; + + return (ATOM(str)); + } + } + + dfloat = strtod(str, NULL); + if (!finite(dfloat)) + READ_ERROR0("floating point overflow"); + + return (DFLOAT(dfloat)); + } + } + + /* check if correctly specified in the given radix */ + len = strlen(str) - 1; + if (!ratio && radix != 10 && str[len] == '.') + str[len] = '\0'; + + if (ratio || radix != 10) { + if (!StringInRadix(str, radix, 1)) { + if (ratio) + ratio[-1] = '/'; + return (ATOM(str)); + } + if (ratio && !StringInRadix(ratio, radix, 0)) { + ratio[-1] = '/'; + return (ATOM(str)); + } + } + + bignum = NULL; + bigratio = NULL; + + errno = 0; + integer = strtol(str, NULL, radix); + + /* if does not fit in a long */ + if (errno == ERANGE && + ((*str == '-' && integer == LONG_MIN) || + (*str != '-' && integer == LONG_MAX))) { + bignum = LispMalloc(sizeof(mpi)); + mpi_init(bignum); + mpi_setstr(bignum, str, radix); + } + + + if (ratio && integer != 0) { + long denominator; + + errno = 0; + denominator = strtol(ratio, NULL, radix); + if (denominator == 0) + READ_ERROR0("divide by zero"); + + if (bignum == NULL) { + if (integer == MINSLONG || + (denominator == LONG_MAX && errno == ERANGE)) { + bigratio = LispMalloc(sizeof(mpr)); + mpr_init(bigratio); + mpi_seti(mpr_num(bigratio), integer); + mpi_setstr(mpr_den(bigratio), ratio, radix); + } + } + else { + bigratio = LispMalloc(sizeof(mpr)); + mpr_init(bigratio); + mpi_set(mpr_num(bigratio), bignum); + mpi_clear(bignum); + LispFree(bignum); + mpi_setstr(mpr_den(bigratio), ratio, radix); + } + + if (bigratio) { + mpr_canonicalize(bigratio); + if (mpi_fiti(mpr_num(bigratio)) && + mpi_fiti(mpr_den(bigratio))) { + integer = mpi_geti(mpr_num(bigratio)); + denominator = mpi_geti(mpr_den(bigratio)); + mpr_clear(bigratio); + LispFree(bigratio); + if (denominator == 1) + number = INTEGER(integer); + else + number = RATIO(integer, denominator); + } + else + number = BIGRATIO(bigratio); + } + else { + long num = integer, den = denominator, rest; + + if (num < 0) + num = -num; + for (;;) { + if ((rest = den % num) == 0) + break; + den = num; + num = rest; + } + if (den != 1) { + denominator /= num; + integer /= num; + } + if (denominator < 0) { + integer = -integer; + denominator = -denominator; + } + if (denominator == 1) + number = INTEGER(integer); + else + number = RATIO(integer, denominator); + } + } + else if (bignum) + number = BIGNUM(bignum); + else + number = INTEGER(integer); + + return (number); +} + +static int +StringInRadix(char *str, int radix, int skip_sign) +{ + if (skip_sign && (*str == '-' || *str == '+')) + ++str; + while (*str) { + if (*str >= '0' && *str <= '9') { + if (*str - '0' >= radix) + return (0); + } + else if (*str >= 'A' && *str <= 'Z') { + if (radix <= 10 || *str - 'A' + 10 >= radix) + return (0); + } + else + return (0); + str++; + } + + return (1); +} + +static int +AtomSeparator(int ch, int check_space, int check_backslash) +{ + if (check_space && isspace(ch)) + return (1); + if (check_backslash && ch == '\\') + return (1); + return (strchr("(),\";'`#|,", ch) != NULL); +} + +static LispObj * +LispReadVector(read_info *info) +{ + LispObj *objects; + int nodot = info->nodot; + + info->nodot = info->level + 1; + objects = LispReadList(info); + info->nodot = nodot; + + if (info->discard) + return (objects); + + return (VECTOR(objects)); +} + +static LispObj * +LispReadFunction(read_info *info) +{ + READ_ENTER(); + int nodot = info->nodot; + LispObj *function; + + info->nodot = info->level + 1; + function = LispDoRead(info); + info->nodot = nodot; + + if (info->discard) + return (function); + + if (INVALIDP(function)) + READ_ERROR_INVARG(); + else if (CONSP(function)) { + if (CAR(function) != Olambda) + READ_ERROR_INVARG(); + + return (FUNCTION_QUOTE(function)); + } + else if (!SYMBOLP(function)) + READ_ERROR_INVARG(); + + return (FUNCTION_QUOTE(function)); +} + +static LispObj * +LispReadRational(int radix, read_info *info) +{ + READ_ENTER(); + LispObj *number; + int ch, len, size; + char stk[128], *str; + + len = 0; + str = stk; + size = sizeof(stk); + + for (;;) { + ch = LispGet(); + if (ch == EOF || isspace(ch)) + break; + else if (AtomSeparator(ch, 0, 1)) { + LispUnget(ch); + break; + } + else if (islower(ch)) + ch = toupper(ch); + if ((ch < '0' || ch > '9') && (ch < 'A' || ch > 'Z') && + ch != '+' && ch != '-' && ch != '/') { + if (str != stk) + LispFree(str); + if (!info->discard) + READ_ERROR1("bad character %c for rational number", ch); + } + if (len + 1 >= size) { + if (str == stk) { + size = 512; + str = LispMalloc(size); + strcpy(str + 1, stk + 1); + } + else { + size += 512; + str = LispRealloc(str, size); + } + } + str[len++] = ch; + } + + if (info->discard) { + if (str != stk) + LispFree(str); + + return (ch == EOF ? NULL : NIL); + } + + str[len] = '\0'; + + number = LispParseNumber(str, radix, read__stream, read__line); + if (str != stk) + LispFree(str); + + if (!RATIONALP(number)) + READ_ERROR0("bad rational number specification"); + + return (number); +} + +static LispObj * +LispReadCharacter(read_info *info) +{ + READ_ENTER(); + long c; + int ch, len; + char stk[64]; + + ch = LispGet(); + if (ch == EOF) + return (NULL); + + stk[0] = ch; + len = 1; + + for (;;) { + ch = LispGet(); + if (ch == EOF) + break; + else if (ch != '-' && !isalnum(ch)) { + LispUnget(ch); + break; + } + if (len + 1 < sizeof(stk)) + stk[len++] = ch; + } + if (len > 1) { + char **names; + int found = 0; + stk[len] = '\0'; + + for (c = ch = 0; ch <= ' ' && !found; ch++) { + for (names = LispChars[ch].names; *names; names++) + if (strcasecmp(*names, stk) == 0) { + c = ch; + found = 1; + break; + } + } + if (!found) { + for (names = LispChars[0177].names; *names; names++) + if (strcasecmp(*names, stk) == 0) { + c = 0177; + found = 1; + break; + } + } + + if (!found) { + if (info->discard) + return (NIL); + READ_ERROR1("unkwnown character %s", stk); + } + } + else + c = stk[0]; + + return (SCHAR(c)); +} + +static void +LispSkipComment(void) +{ + READ_ENTER(); + int ch, comm = 1; + + for (;;) { + ch = LispGet(); + if (ch == '#') { + ch = LispGet(); + if (ch == '|') + ++comm; + continue; + } + while (ch == '|') { + ch = LispGet(); + if (ch == '#' && --comm == 0) + return; + } + if (ch == EOF) + READ_ERROR_EOF(); + } +} + +static LispObj * +LispReadEval(read_info *info) +{ + READ_ENTER(); + int nodot = info->nodot; + LispObj *code; + + info->nodot = info->level + 1; + code = LispDoRead(info); + info->nodot = nodot; + + if (info->discard) + return (code); + + if (INVALIDP(code)) + READ_ERROR_INVARG(); + + return (EVAL(code)); +} + +static LispObj * +LispReadComplex(read_info *info) +{ + READ_ENTER(); + GC_ENTER(); + int nodot = info->nodot; + LispObj *number, *arguments; + + info->nodot = info->level + 1; + arguments = LispDoRead(info); + info->nodot = nodot; + + /* form read */ + if (info->discard) + return (arguments); + + if (INVALIDP(arguments) || !CONSP(arguments)) + READ_ERROR_INVARG(); + + GC_PROTECT(arguments); + number = APPLY(Ocomplex, arguments); + GC_LEAVE(); + + return (number); +} + +static LispObj * +LispReadPathname(read_info *info) +{ + READ_ENTER(); + GC_ENTER(); + int nodot = info->nodot; + LispObj *path, *arguments; + + info->nodot = info->level + 1; + arguments = LispDoRead(info); + info->nodot = nodot; + + /* form read */ + if (info->discard) + return (arguments); + + if (INVALIDP(arguments)) + READ_ERROR_INVARG(); + + GC_PROTECT(arguments); + path = APPLY1(Oparse_namestring, arguments); + GC_LEAVE(); + + return (path); +} + +static LispObj * +LispReadStruct(read_info *info) +{ + READ_ENTER(); + GC_ENTER(); + int len, nodot = info->nodot; + char stk[128], *str; + LispObj *struc, *fields; + + info->nodot = info->level + 1; + fields = LispDoRead(info); + info->nodot = nodot; + + /* form read */ + if (info->discard) + return (fields); + + if (INVALIDP(fields) || !CONSP(fields) || !SYMBOLP(CAR(fields))) + READ_ERROR_INVARG(); + + GC_PROTECT(fields); + + len = strlen(ATOMID(CAR(fields))); + /* MAKE- */ + if (len + 6 > sizeof(stk)) + str = LispMalloc(len + 6); + else + str = stk; + sprintf(str, "MAKE-%s", ATOMID(CAR(fields))); + RPLACA(fields, ATOM(str)); + if (str != stk) + LispFree(str); + struc = APPLY(Omake_struct, fields); + GC_LEAVE(); + + return (struc); +} + +/* XXX This is broken, needs a rewritten as soon as true vector/arrays be + * implemented. */ +static LispObj * +LispReadArray(long dimensions, read_info *info) +{ + READ_ENTER(); + GC_ENTER(); + long count; + int nodot = info->nodot; + LispObj *arguments, *initial, *dim, *cons, *array, *data; + + info->nodot = info->level + 1; + data = LispDoRead(info); + info->nodot = nodot; + + /* form read */ + if (info->discard) + return (data); + + if (INVALIDP(data)) + READ_ERROR_INVARG(); + + initial = Kinitial_contents; + + dim = cons = NIL; + if (dimensions) { + LispObj *array; + + for (count = 0, array = data; count < dimensions; count++) { + long length; + LispObj *item; + + if (!CONSP(array)) + READ_ERROR0("bad array for given dimension"); + item = array; + array = CAR(array); + + for (length = 0; CONSP(item); item = CDR(item), length++) + ; + + if (dim == NIL) { + dim = cons = CONS(FIXNUM(length), NIL); + GC_PROTECT(dim); + } + else { + RPLACD(cons, CONS(FIXNUM(length), NIL)); + cons = CDR(cons); + } + } + } + + arguments = CONS(dim, CONS(initial, CONS(data, NIL))); + GC_PROTECT(arguments); + array = APPLY(Omake_array, arguments); + GC_LEAVE(); + + return (array); +} + +static LispObj * +LispReadFeature(int with, read_info *info) +{ + READ_ENTER(); + LispObj *status; + LispObj *feature = LispDoRead(info); + + /* form read */ + if (info->discard) + return (feature); + + if (INVALIDP(feature)) + READ_ERROR_INVARG(); + + /* paranoia check, features must be a list, possibly empty */ + if (!CONSP(FEATURES) && FEATURES != NIL) + READ_ERROR1("%s is not a list", STROBJ(FEATURES)); + + status = LispEvalFeature(feature); + + if (with) { + if (status == T) + return (LispDoRead(info)); + + /* need to use the field discard because the following expression + * may be #.FORM or #,FORM or any other form that may generate + * side effects */ + info->discard = 1; + LispDoRead(info); + info->discard = 0; + + return (LispDoRead(info)); + } + + if (status == NIL) + return (LispDoRead(info)); + + info->discard = 1; + LispDoRead(info); + info->discard = 0; + + return (LispDoRead(info)); +} + +/* + * A very simple eval loop with AND, NOT, and OR functions for testing + * the available features. + */ +static LispObj * +LispEvalFeature(LispObj *feature) +{ + READ_ENTER(); + Atom_id test; + LispObj *object; + + if (CONSP(feature)) { + LispObj *function = CAR(feature), *arguments = CDR(feature); + + if (!SYMBOLP(function)) + READ_ERROR1("bad feature test function %s", STROBJ(function)); + if (!CONSP(arguments)) + READ_ERROR1("bad feature test arguments %s", STROBJ(arguments)); + test = ATOMID(function); + if (test == Sand) { + for (; CONSP(arguments); arguments = CDR(arguments)) { + if (LispEvalFeature(CAR(arguments)) == NIL) + return (NIL); + } + return (T); + } + else if (test == Sor) { + for (; CONSP(arguments); arguments = CDR(arguments)) { + if (LispEvalFeature(CAR(arguments)) == T) + return (T); + } + return (NIL); + } + else if (test == Snot) { + if (CONSP(CDR(arguments))) + READ_ERROR0("too many arguments to NOT"); + + return (LispEvalFeature(CAR(arguments)) == NIL ? T : NIL); + } + else + READ_ERROR1("unimplemented feature test function %s", test); + } + + if (KEYWORDP(feature)) + feature = feature->data.quote; + else if (!SYMBOLP(feature)) + READ_ERROR1("bad feature specification %s", STROBJ(feature)); + + test = ATOMID(feature); + + for (object = FEATURES; CONSP(object); object = CDR(object)) { + /* paranoia check, elements in the feature list must ge keywords */ + if (!KEYWORDP(CAR(object))) + READ_ERROR1("%s is not a keyword", STROBJ(CAR(object))); + if (ATOMID(CAR(object)) == test) + return (T); + } + + /* unknown feature */ + return (NIL); +} diff --git a/lisp/read.h b/lisp/read.h new file mode 100644 index 0000000..229ced5 --- /dev/null +++ b/lisp/read.h @@ -0,0 +1,47 @@ +/* + * Copyright (c) 2002 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/read.h,v 1.3 2002/11/15 07:01:30 paulo Exp $ */ + +#ifndef Lisp_read_h +#define Lisp_read_h + +#include "io.h" + +/* + * Prototypes + */ +LispObj *LispRead(void); + +LispObj *Lisp_Read(LispBuiltin*); +LispObj *Lisp_ReadChar(LispBuiltin*); +LispObj *Lisp_ReadCharNoHang(LispBuiltin*); +LispObj *Lisp_ReadLine(LispBuiltin*); + +#endif /* Lisp_read_h */ diff --git a/lisp/regex.c b/lisp/regex.c new file mode 100644 index 0000000..bf3390d --- /dev/null +++ b/lisp/regex.c @@ -0,0 +1,223 @@ +/* + * Copyright (c) 2002 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/regex.c,v 1.10 2002/12/11 04:44:28 paulo Exp $ */ + +#include "regex.h" +#include "private.h" +#include "helper.h" + +/* + * Prototypes + */ +static re_cod *LispRecomp(LispBuiltin*, char*, int); + +/* + * Initialization + */ +LispObj *Knomatch; + +/* + * Implementation + */ +static re_cod * +LispRecomp(LispBuiltin *builtin, char *pattern, int cflags) +{ + int code; + re_cod *regex = LispMalloc(sizeof(re_cod)); + + if ((code = recomp(regex, pattern, cflags)) != 0) { + char buffer[256]; + + reerror(code, regex, buffer, sizeof(buffer)); + refree(regex); + LispFree(regex); + LispDestroy("%s: recomp(\"%s\"): %s", STRFUN(builtin), pattern, buffer); + } + + return (regex); +} + +void +LispRegexInit(void) +{ + Knomatch = KEYWORD("NOMATCH"); +} + +LispObj * +Lisp_Recomp(LispBuiltin *builtin) +/* + re-comp pattern &key nospec icase nosub newline + */ +{ + re_cod *regex; + int cflags = 0; + + LispObj *result; + + LispObj *pattern, *nospec, *icase, *nosub, *newline; + + newline = ARGUMENT(4); + nosub = ARGUMENT(3); + icase = ARGUMENT(2); + nospec = ARGUMENT(1); + pattern = ARGUMENT(0); + + /* Don't generate an error if it is already a compiled regex. */ + if (REGEXP(pattern)) + return (pattern); + + CHECK_STRING(pattern); + + if (nospec != UNSPEC && nospec != NIL) + cflags |= RE_NOSPEC; + if (icase != UNSPEC && icase != NIL) + cflags |= RE_ICASE; + if (nosub != UNSPEC && nosub != NIL) + cflags |= RE_NOSUB; + if (newline != UNSPEC && newline != NIL) + cflags |= RE_NEWLINE; + + regex = LispRecomp(builtin, THESTR(pattern), cflags); + result = LispNew(pattern, NIL); + result->type = LispRegex_t; + result->data.regex.regex = regex; + result->data.regex.pattern = pattern; + result->data.regex.options = cflags; + LispMused(regex); + + return (result); +} + +LispObj * +Lisp_Reexec(LispBuiltin *builtin) +/* + re-exec regex string &key count start end notbol noteol + */ +{ + size_t nmatch; + re_mat match[10]; + long start, end, length; + int code, cflags, eflags; + char *string; + LispObj *result; + re_cod *regexp; + + LispObj *regex, *ostring, *count, *ostart, *oend, *notbol, *noteol; + + noteol = ARGUMENT(6); + notbol = ARGUMENT(5); + oend = ARGUMENT(4); + ostart = ARGUMENT(3); + count = ARGUMENT(2); + ostring = ARGUMENT(1); + regex = ARGUMENT(0); + + if (STRINGP(regex)) + regexp = LispRecomp(builtin, THESTR(regex), cflags = 0); + else { + CHECK_REGEX(regex); + regexp = regex->data.regex.regex; + cflags = regex->data.regex.options; + } + + CHECK_STRING(ostring); + + if (count == UNSPEC) + nmatch = 1; + else { + CHECK_INDEX(count); + nmatch = FIXNUM_VALUE(count); + if (nmatch > 10) + LispDestroy("%s: COUNT cannot be larger than 10", STRFUN(builtin)); + } + if (nmatch && (cflags & RE_NOSUB)) + nmatch = 1; + + eflags = RE_STARTEND; + if (notbol != UNSPEC && notbol != NIL) + eflags |= RE_NOTBOL; + if (noteol != UNSPEC && noteol != NIL) + eflags |= RE_NOTEOL; + + string = THESTR(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &length); + + match[0].rm_so = start; + match[0].rm_eo = end; + code = reexec(regexp, string, nmatch, &match[0], eflags); + + if (code == 0) { + if (nmatch && match[0].rm_eo >= match[0].rm_so) { + result = CONS(CONS(FIXNUM(match[0].rm_so), + FIXNUM(match[0].rm_eo)), NIL); + if (nmatch > 1 && match[1].rm_eo >= match[1].rm_so) { + int i; + GC_ENTER(); + LispObj *cons = result; + + GC_PROTECT(result); + for (i = 1; + i < nmatch && match[i].rm_eo >= match[i].rm_so; + i++) { + RPLACD(cons, CONS(CONS(FIXNUM(match[i].rm_so), + FIXNUM(match[i].rm_eo)), NIL)); + cons = CDR(cons); + } + GC_LEAVE(); + } + } + else + result = NIL; + } + else + result = Knomatch; + + /* Maybe shoud cache compiled regex, but better the caller do it */ + if (!XREGEXP(regex)) { + refree(regexp); + LispFree(regexp); + } + + return (result); +} + +LispObj * +Lisp_Rep(LispBuiltin *builtin) +/* + re-p object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (REGEXP(object) ? T : NIL); +} diff --git a/lisp/regex.h b/lisp/regex.h new file mode 100644 index 0000000..cc4d7e6 --- /dev/null +++ b/lisp/regex.h @@ -0,0 +1,46 @@ +/* + * Copyright (c) 2002 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/regex.h,v 1.3 2002/11/08 08:00:57 paulo Exp $ */ + +#ifndef Lisp_regex_h +#define Lisp_regex_h + +#include "internal.h" + +/* + * Prototypes + */ +void LispRegexInit(void); + +LispObj *Lisp_Recomp(LispBuiltin*); +LispObj *Lisp_Reexec(LispBuiltin*); +LispObj *Lisp_Rep(LispBuiltin*); + +#endif /* Lisp_regex_h */ diff --git a/lisp/require.c b/lisp/require.c new file mode 100644 index 0000000..7f80c3f --- /dev/null +++ b/lisp/require.c @@ -0,0 +1,159 @@ +/* + * 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/require.c,v 1.16 2002/11/23 08:26:50 paulo Exp $ */ + +#include "require.h" + +/* + * Implementation + */ +LispObj * +Lisp_Load(LispBuiltin *builtin) +/* + load filename &key verbose print if-does-not-exist + */ +{ + LispObj *filename, *verbose, *print, *if_does_not_exist; + + if_does_not_exist = ARGUMENT(3); + print = ARGUMENT(2); + verbose = ARGUMENT(1); + filename = ARGUMENT(0); + + if (PATHNAMEP(filename)) + filename = CAR(filename->data.pathname); + else { + CHECK_STRING(filename); + } + + return (LispLoadFile(filename, + verbose != UNSPEC && verbose != NIL, + print != UNSPEC && print != NIL, + if_does_not_exist != UNSPEC && + if_does_not_exist != NIL)); +} + +LispObj * +Lisp_Require(LispBuiltin *builtin) +/* + require module &optional pathname + */ +{ + char filename[1024], *ext; + int len; + + LispObj *obj, *module, *pathname; + + pathname = ARGUMENT(1); + module = ARGUMENT(0); + + CHECK_STRING(module); + if (pathname != UNSPEC) { + if (PATHNAMEP(pathname)) + pathname = CAR(pathname->data.pathname); + else { + CHECK_STRING(pathname); + } + } + else + pathname = module; + + for (obj = MOD; CONSP(obj); obj = CDR(obj)) { + if (strcmp(THESTR(CAR(obj)), THESTR(module)) == 0) + return (module); + } + + if (THESTR(pathname)[0] != '/') { +#ifdef LISPDIR + snprintf(filename, sizeof(filename), "%s", LISPDIR); +#else + getcwd(filename, sizeof(filename)); +#endif + } + else + filename[0] = '\0'; + *(filename + sizeof(filename) - 5) = '\0'; /* make sure there is place for ext */ + len = strlen(filename); + if (!len || filename[len - 1] != '/') { + strcat(filename, "/"); + ++len; + } + + snprintf(filename + len, sizeof(filename) - len - 5, "%s", THESTR(pathname)); + + ext = filename + strlen(filename); + +#ifdef SHARED_MODULES + strcpy(ext, ".so"); + if (access(filename, R_OK) == 0) { + LispModule *lisp_module; + char data[64]; + int len; + + if (lisp__data.module == NULL) { + /* export our own symbols */ + if (dlopen(NULL, RTLD_LAZY | RTLD_GLOBAL) == NULL) + LispDestroy(mac, "%s: ", STRFUN(builtin), dlerror()); + } + + lisp_module = (LispModule*)LispMalloc(sizeof(LispModule)); + if ((lisp_module->handle = + dlopen(filename, RTLD_LAZY | RTLD_GLOBAL)) == NULL) + LispDestroy(mac, "%s: dlopen: %s", STRFUN(builtin), dlerror()); + snprintf(data, sizeof(data), "%sLispModuleData", THESTR(module)); + if ((lisp_module->data = + (LispModuleData*)dlsym(lisp_module->handle, data)) == NULL) { + dlclose(lisp_module->handle); + LispDestroy("%s: cannot find LispModuleData for %s", + STRFUN(builtin), STROBJ(module)); + } + LispMused(lisp_module); + lisp_module->next = lisp__data.module; + lisp__data.module = lisp_module; + if (lisp_module->data->load) + (lisp_module->data->load)(); + + if (MOD == NIL) + MOD = CONS(module, NIL); + else { + RPLACD(MOD, CONS(CAR(MOD), CDR(MOD))); + RPLACA(MOD, module); + } + LispSetVar(lisp__data.modules, MOD); + + return (module); + } +#endif + + strcpy(ext, ".lsp"); + (void)LispLoadFile(STRING(filename), 0, 0, 0); + + return (module); +} diff --git a/lisp/require.h b/lisp/require.h new file mode 100644 index 0000000..42c2064 --- /dev/null +++ b/lisp/require.h @@ -0,0 +1,44 @@ +/* + * 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/require.h,v 1.4 2002/11/08 08:00:57 paulo Exp $ */ + +#ifndef Lisp_require_h +#define Lisp_require_h + +#include "private.h" +#include "helper.h" +#ifdef SHARED_MODULES +#include <dlfcn.h> +#endif + +LispObj *Lisp_Load(LispBuiltin*); +LispObj *Lisp_Require(LispBuiltin*); + +#endif /* Lisp_require_h */ diff --git a/lisp/stream.c b/lisp/stream.c new file mode 100644 index 0000000..be0f44d --- /dev/null +++ b/lisp/stream.c @@ -0,0 +1,866 @@ +/* + * 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/stream.c,v 1.21 2002/12/10 03:59:03 paulo Exp $ */ + +#include "read.h" +#include "stream.h" +#include "pathname.h" +#include "write.h" +#include "private.h" +#include <errno.h> +#include <fcntl.h> +#include <signal.h> +#include <string.h> +#include <sys/wait.h> + +/* + * Initialization + */ +#define DIR_PROBE 0 +#define DIR_INPUT 1 +#define DIR_OUTPUT 2 +#define DIR_IO 3 + +#define EXT_NIL 0 +#define EXT_ERROR 1 +#define EXT_NEW_VERSION 2 +#define EXT_RENAME 3 +#define EXT_RENAME_DELETE 4 +#define EXT_OVERWRITE 5 +#define EXT_APPEND 6 +#define EXT_SUPERSEDE 7 + +#define NOEXT_NIL 0 +#define NOEXT_ERROR 1 +#define NOEXT_CREATE 2 +#define NOEXT_NOTHING 3 + +extern char **environ; + +LispObj *Oopen, *Oclose, *Otruename; + +LispObj *Kif_does_not_exist, *Kprobe, *Kinput, *Koutput, *Kio, + *Knew_version, *Krename, *Krename_and_delete, *Koverwrite, + *Kappend, *Ksupersede, *Kcreate; + +/* + * Implementation + */ +void +LispStreamInit(void) +{ + Oopen = STATIC_ATOM("OPEN"); + Oclose = STATIC_ATOM("CLOSE"); + Otruename = STATIC_ATOM("TRUENAME"); + + Kif_does_not_exist = KEYWORD("IF-DOES-NOT-EXIST"); + Kprobe = KEYWORD("PROBE"); + Kinput = KEYWORD("INPUT"); + Koutput = KEYWORD("OUTPUT"); + Kio = KEYWORD("IO"); + Knew_version = KEYWORD("NEW-VERSION"); + Krename = KEYWORD("RENAME"); + Krename_and_delete = KEYWORD("RENAME-AND-DELETE"); + Koverwrite = KEYWORD("OVERWRITE"); + Kappend = KEYWORD("APPEND"); + Ksupersede = KEYWORD("SUPERSEDE"); + Kcreate = KEYWORD("CREATE"); +} + +LispObj * +Lisp_DeleteFile(LispBuiltin *builtin) +/* + delete-file filename + */ +{ + GC_ENTER(); + LispObj *filename; + + filename = ARGUMENT(0); + + if (STRINGP(filename)) { + filename = APPLY1(Oparse_namestring, filename); + GC_PROTECT(filename); + } + else if (STREAMP(filename)) { + if (filename->data.stream.type != LispStreamFile) + LispDestroy("%s: %s is not a FILE-STREAM", + STRFUN(builtin), STROBJ(filename)); + filename = filename->data.stream.pathname; + } + else { + CHECK_PATHNAME(filename); + } + GC_LEAVE(); + + return (LispUnlink(THESTR(CAR(filename->data.pathname))) ? NIL : T); +} + +LispObj * +Lisp_RenameFile(LispBuiltin *builtin) +/* + rename-file filename new-name + */ +{ + int code; + GC_ENTER(); + char *from, *to; + LispObj *old_truename, *new_truename; + + LispObj *filename, *new_name; + + new_name = ARGUMENT(1); + filename = ARGUMENT(0); + + if (STRINGP(filename)) { + filename = APPLY1(Oparse_namestring, filename); + GC_PROTECT(filename); + } + else if (STREAMP(filename)) { + if (filename->data.stream.type != LispStreamFile) + LispDestroy("%s: %s is not a FILE-STREAM", + STRFUN(builtin), STROBJ(filename)); + filename = filename->data.stream.pathname; + } + else { + CHECK_PATHNAME(filename); + } + old_truename = APPLY1(Otruename, filename); + GC_PROTECT(old_truename); + + if (STRINGP(new_name)) { + new_name = APPLY3(Oparse_namestring, new_name, NIL, filename); + GC_PROTECT(new_name); + } + else { + CHECK_PATHNAME(new_name); + } + + from = THESTR(CAR(filename->data.pathname)); + to = THESTR(CAR(new_name->data.pathname)); + code = LispRename(from, to); + if (code) + LispDestroy("%s: rename(%s, %s): %s", + STRFUN(builtin), from, to, strerror(errno)); + GC_LEAVE(); + + new_truename = APPLY1(Otruename, new_name); + RETURN_COUNT = 2; + RETURN(0) = old_truename; + RETURN(1) = new_truename; + + return (new_name); +} + +LispObj * +Lisp_Streamp(LispBuiltin *builtin) +/* + streamp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (STREAMP(object) ? T : NIL); +} + +LispObj * +Lisp_InputStreamP(LispBuiltin *builtin) +/* + input-stream-p stream + */ +{ + LispObj *stream; + + stream = ARGUMENT(0); + + CHECK_STREAM(stream); + + return (stream->data.stream.readable ? T : NIL); +} + +LispObj * +Lisp_OpenStreamP(LispBuiltin *builtin) +/* + open-stream-p stream + */ +{ + LispObj *stream; + + stream = ARGUMENT(0); + + CHECK_STREAM(stream); + + return (stream->data.stream.readable || stream->data.stream.writable ? + T : NIL); +} + +LispObj * +Lisp_OutputStreamP(LispBuiltin *builtin) +/* + output-stream-p stream + */ +{ + LispObj *stream; + + stream = ARGUMENT(0); + + CHECK_STREAM(stream); + + return (stream->data.stream.writable ? T : NIL); +} + +LispObj * +Lisp_Open(LispBuiltin *builtin) +/* + open filename &key direction element-type if-exists if-does-not-exist external-format + */ +{ + GC_ENTER(); + char *string; + LispObj *stream = NIL; + int mode, flags, direction, exist, noexist, file_exist; + LispFile *file; + + LispObj *filename, *odirection, *element_type, *if_exists, + *if_does_not_exist, *external_format; + + external_format = ARGUMENT(5); + if_does_not_exist = ARGUMENT(4); + if_exists = ARGUMENT(3); + element_type = ARGUMENT(2); + odirection = ARGUMENT(1); + filename = ARGUMENT(0); + + if (STRINGP(filename)) { + filename = APPLY1(Oparse_namestring, filename); + GC_PROTECT(filename); + } + else if (STREAMP(filename)) { + if (filename->data.stream.type != LispStreamFile) + LispDestroy("%s: %s is not a FILE-STREAM", + STRFUN(builtin), STROBJ(filename)); + filename = filename->data.stream.pathname; + } + else { + CHECK_PATHNAME(filename); + } + + if (odirection != UNSPEC) { + direction = -1; + if (KEYWORDP(odirection)) { + if (odirection == Kprobe) + direction = DIR_PROBE; + else if (odirection == Kinput) + direction = DIR_INPUT; + else if (odirection == Koutput) + direction = DIR_OUTPUT; + else if (odirection == Kio) + direction = DIR_IO; + } + if (direction == -1) + LispDestroy("%s: bad :DIRECTION %s", + STRFUN(builtin), STROBJ(odirection)); + } + else + direction = DIR_INPUT; + + if (element_type != UNSPEC) { + /* just check argument... */ + if (SYMBOLP(element_type) && + ATOMID(element_type) == Scharacter) + ; /* do nothing */ + else if (KEYWORDP(element_type) && + ATOMID(element_type) == Sdefault) + ; /* do nothing */ + else + LispDestroy("%s: only :%s and %s supported for :ELEMENT-TYPE, not %s", + STRFUN(builtin), Sdefault, Scharacter, STROBJ(element_type)); + } + + if (if_exists != UNSPEC) { + exist = -1; + if (if_exists == NIL) + exist = EXT_NIL; + else if (KEYWORDP(if_exists)) { + if (if_exists == Kerror) + exist = EXT_ERROR; + else if (if_exists == Knew_version) + exist = EXT_NEW_VERSION; + else if (if_exists == Krename) + exist = EXT_RENAME; + else if (if_exists == Krename_and_delete) + exist = EXT_RENAME_DELETE; + else if (if_exists == Koverwrite) + exist = EXT_OVERWRITE; + else if (if_exists == Kappend) + exist = EXT_APPEND; + else if (if_exists == Ksupersede) + exist = EXT_SUPERSEDE; + } + if (exist == -1) + LispDestroy("%s: bad :IF-EXISTS %s", + STRFUN(builtin), STROBJ(if_exists)); + } + else + exist = EXT_ERROR; + + if (if_does_not_exist != UNSPEC) { + noexist = -1; + if (if_does_not_exist == NIL) + noexist = NOEXT_NIL; + if (KEYWORDP(if_does_not_exist)) { + if (if_does_not_exist == Kerror) + noexist = NOEXT_ERROR; + else if (if_does_not_exist == Kcreate) + noexist = NOEXT_CREATE; + } + if (noexist == -1) + LispDestroy("%s: bad :IF-DOES-NO-EXISTS %s", + STRFUN(builtin), STROBJ(if_does_not_exist)); + } + else + noexist = direction != DIR_INPUT ? NOEXT_NOTHING : NOEXT_ERROR; + + if (external_format != UNSPEC) { + /* just check argument... */ + if (SYMBOLP(external_format) && + ATOMID(external_format) == Scharacter) + ; /* do nothing */ + else if (KEYWORDP(external_format) && + ATOMID(external_format) == Sdefault) + ; /* do nothing */ + else + LispDestroy("%s: only :%s and %s supported for :EXTERNAL-FORMAT, not %s", + STRFUN(builtin), Sdefault, Scharacter, STROBJ(external_format)); + } + + /* string representation of pathname */ + string = THESTR(CAR(filename->data.pathname)); + mode = 0; + + file_exist = access(string, F_OK) == 0; + if (file_exist) { + if (exist == EXT_NIL) { + GC_LEAVE(); + return (NIL); + } + } + else { + if (noexist == NOEXT_NIL) { + GC_LEAVE(); + return (NIL); + } + if (noexist == NOEXT_ERROR) + LispDestroy("%s: file %s does not exist", + STRFUN(builtin), STROBJ(CAR(filename->data.quote))); + else if (noexist == NOEXT_CREATE) { + LispFile *tmp = LispFopen(string, FILE_WRITE); + + if (tmp) + LispFclose(tmp); + else + LispDestroy("%s: cannot create file %s", + STRFUN(builtin), + STROBJ(CAR(filename->data.quote))); + } + } + + if (direction == DIR_OUTPUT || direction == DIR_IO) { + if (file_exist) { + if (exist == EXT_ERROR) + LispDestroy("%s: file %s already exists", + STRFUN(builtin), STROBJ(CAR(filename->data.quote))); + if (exist == EXT_RENAME) { + /* Add an ending '~' at the end of the backup file */ + char tmp[PATH_MAX + 1]; + + strcpy(tmp, string); + if (strlen(tmp) + 1 > PATH_MAX) + LispDestroy("%s: backup name for %s too long", + STRFUN(builtin), + STROBJ(CAR(filename->data.quote))); + strcat(tmp, "~"); + if (rename(string, tmp)) + LispDestroy("%s: rename: %s", + STRFUN(builtin), strerror(errno)); + mode |= FILE_WRITE; + } + else if (exist == EXT_OVERWRITE) + mode |= FILE_WRITE; + else if (exist == EXT_APPEND) + mode |= FILE_APPEND; + } + else + mode |= FILE_WRITE; + if (direction == DIR_IO) + mode |= FILE_IO; + } + else + mode |= FILE_READ; + + file = LispFopen(string, mode); + if (file == NULL) + LispDestroy("%s: open: %s", STRFUN(builtin), strerror(errno)); + + flags = 0; + if (direction == DIR_PROBE) { + LispFclose(file); + file = NULL; + } + else { + if (direction == DIR_INPUT || direction == DIR_IO) + flags |= STREAM_READ; + if (direction == DIR_OUTPUT || direction == DIR_IO) + flags |= STREAM_WRITE; + } + stream = FILESTREAM(file, filename, flags); + GC_LEAVE(); + + return (stream); +} + +LispObj * +Lisp_Close(LispBuiltin *builtin) +/* + close stream &key abort + */ +{ + LispObj *stream, *oabort; + + oabort = ARGUMENT(1); + stream = ARGUMENT(0); + + CHECK_STREAM(stream); + + if (stream->data.stream.readable || stream->data.stream.writable) { + stream->data.stream.readable = stream->data.stream.writable = 0; + if (stream->data.stream.type == LispStreamFile) { + LispFclose(stream->data.stream.source.file); + stream->data.stream.source.file = NULL; + } + else if (stream->data.stream.type == LispStreamPipe) { + if (IPSTREAMP(stream)) { + LispFclose(IPSTREAMP(stream)); + IPSTREAMP(stream) = NULL; + } + if (OPSTREAMP(stream)) { + LispFclose(OPSTREAMP(stream)); + OPSTREAMP(stream) = NULL; + } + if (EPSTREAMP(stream)) { + LispFclose(EPSTREAMP(stream)); + EPSTREAMP(stream) = NULL; + } + if (PIDPSTREAMP(stream) > 0) { + kill(PIDPSTREAMP(stream), + oabort == UNSPEC || oabort == NIL ? SIGTERM : SIGKILL); + waitpid(PIDPSTREAMP(stream), NULL, 0); + } + } + return (T); + } + + return (NIL); +} + +LispObj * +Lisp_Listen(LispBuiltin *builtin) +/* + listen &optional input-stream + */ +{ + LispFile *file = NULL; + LispObj *result = NIL; + + LispObj *stream; + + stream = ARGUMENT(0); + + if (stream == UNSPEC) + stream = NIL; + else if (stream != NIL) { + CHECK_STREAM(stream); + } + else + stream = lisp__data.standard_input; + + if (stream->data.stream.readable) { + switch (stream->data.stream.type) { + case LispStreamString: + if (SSTREAMP(stream)->input < SSTREAMP(stream)->length) + result = T; + break; + case LispStreamFile: + file = FSTREAMP(stream); + break; + case LispStreamStandard: + file = FSTREAMP(stream); + break; + case LispStreamPipe: + file = IPSTREAMP(stream); + break; + } + + if (file != NULL) { + if (file->available || file->offset < file->length) + result = T; + else { + unsigned char c; + + if (!file->nonblock) { + if (fcntl(file->descriptor, F_SETFL, O_NONBLOCK) < 0) + LispDestroy("%s: fcntl: %s", + STRFUN(builtin), strerror(errno)); + file->nonblock = 1; + } + if (read(file->descriptor, &c, 1) == 1) { + LispFungetc(file, c); + result = T; + } + } + } + } + + return (result); +} + +LispObj * +Lisp_MakeStringInputStream(LispBuiltin *builtin) +/* + make-string-input-stream string &optional start end + */ +{ + char *string; + long start, end, length; + + LispObj *ostring, *ostart, *oend, *result; + + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + ostring = ARGUMENT(0); + + start = end = 0; + CHECK_STRING(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &length); + string = THESTR(ostring); + + if (end - start != length) + length = end - start; + result = LSTRINGSTREAM(string + start, STREAM_READ, length); + + return (result); +} + +LispObj * +Lisp_MakeStringOutputStream(LispBuiltin *builtin) +/* + make-string-output-stream &key element-type + */ +{ + LispObj *element_type; + + element_type = ARGUMENT(0); + + if (element_type != UNSPEC) { + /* just check argument... */ + if (SYMBOLP(element_type) && ATOMID(element_type) == Scharacter) + ; /* do nothing */ + else if (KEYWORDP(element_type) && + ATOMID(element_type) == Sdefault) + ; /* do nothing */ + else + LispDestroy("%s: only :%s and %s supported for :ELEMENT-TYPE, not %s", + STRFUN(builtin), Sdefault, Scharacter, STROBJ(element_type)); + } + + return (LSTRINGSTREAM("", STREAM_WRITE, 1)); +} + +LispObj * +Lisp_GetOutputStreamString(LispBuiltin *builtin) +/* + get-output-stream-string string-output-stream + */ +{ + int length; + char *string; + LispObj *string_output_stream, *result; + + string_output_stream = ARGUMENT(0); + + if (!STREAMP(string_output_stream) || + string_output_stream->data.stream.type != LispStreamString || + string_output_stream->data.stream.readable || + !string_output_stream->data.stream.writable) + LispDestroy("%s: %s is not an output string stream", + STRFUN(builtin), STROBJ(string_output_stream)); + + string = LispGetSstring(SSTREAMP(string_output_stream), &length); + result = LSTRING(string, length); + + /* reset string */ + SSTREAMP(string_output_stream)->output = + SSTREAMP(string_output_stream)->length = + SSTREAMP(string_output_stream)->column = 0; + + return (result); +} + + +/* XXX Non standard functions below + */ +LispObj * +Lisp_MakePipe(LispBuiltin *builtin) +/* + make-pipe command-line &key :direction :element-type :external-format + */ +{ + char *string; + LispObj *stream = NIL; + int flags, direction; + LispFile *error_file; + LispPipe *program; + int ifd[2]; + int ofd[2]; + int efd[2]; + char *argv[4]; + + LispObj *command_line, *odirection, *element_type, *external_format; + + external_format = ARGUMENT(3); + element_type = ARGUMENT(2); + odirection = ARGUMENT(1); + command_line = ARGUMENT(0); + + if (PATHNAMEP(command_line)) + command_line = CAR(command_line->data.quote); + else if (!STRINGP(command_line)) + LispDestroy("%s: %s is a bad pathname", + STRFUN(builtin), STROBJ(command_line)); + + if (odirection != UNSPEC) { + direction = -1; + if (KEYWORDP(odirection)) { + if (odirection == Kprobe) + direction = DIR_PROBE; + else if (odirection == Kinput) + direction = DIR_INPUT; + else if (odirection == Koutput) + direction = DIR_OUTPUT; + else if (odirection == Kio) + direction = DIR_IO; + } + if (direction == -1) + LispDestroy("%s: bad :DIRECTION %s", + STRFUN(builtin), STROBJ(odirection)); + } + else + direction = DIR_INPUT; + + if (element_type != UNSPEC) { + /* just check argument... */ + if (SYMBOLP(element_type) && ATOMID(element_type) == Scharacter) + ; /* do nothing */ + else if (KEYWORDP(element_type) && ATOMID(element_type) == Sdefault) + ; /* do nothing */ + else + LispDestroy("%s: only :%s and %s supported for :ELEMENT-TYPE, not %s", + STRFUN(builtin), Sdefault, Scharacter, STROBJ(element_type)); + } + + if (external_format != UNSPEC) { + /* just check argument... */ + if (SYMBOLP(external_format) && ATOMID(external_format) == Scharacter) + ; /* do nothing */ + else if (KEYWORDP(external_format) && + ATOMID(external_format) == Sdefault) + ; /* do nothing */ + else + LispDestroy("%s: only :%s and %s supported for :EXTERNAL-FORMAT, not %s", + STRFUN(builtin), Sdefault, Scharacter, STROBJ(external_format)); + } + + string = THESTR(command_line); + program = LispMalloc(sizeof(LispPipe)); + if (direction != DIR_PROBE) { + argv[0] = "sh"; + argv[1] = "-c"; + argv[2] = string; + argv[3] = NULL; + pipe(ifd); + pipe(ofd); + pipe(efd); + if ((program->pid = fork()) == 0) { + close(0); + close(1); + close(2); + dup2(ofd[0], 0); + dup2(ifd[1], 1); + dup2(efd[1], 2); + close(ifd[0]); + close(ifd[1]); + close(ofd[0]); + close(ofd[1]); + close(efd[0]); + close(efd[1]); + execve("/bin/sh", argv, environ); + exit(-1); + } + else if (program->pid < 0) + LispDestroy("%s: fork: %s", STRFUN(builtin), strerror(errno)); + + program->input = LispFdopen(ifd[0], FILE_READ | FILE_UNBUFFERED); + close(ifd[1]); + program->output = LispFdopen(ofd[1], FILE_WRITE | FILE_UNBUFFERED); + close(ofd[0]); + error_file = LispFdopen(efd[0], FILE_READ | FILE_UNBUFFERED); + close(efd[1]); + } + else { + program->pid = -1; + program->input = program->output = error_file = NULL; + } + + flags = direction == DIR_PROBE ? 0 : STREAM_READ; + program->errorp = FILESTREAM(error_file, command_line, flags); + + flags = 0; + if (direction != DIR_PROBE) { + if (direction == DIR_INPUT || direction == DIR_IO) + flags |= STREAM_READ; + if (direction == DIR_OUTPUT || direction == DIR_IO) + flags |= STREAM_WRITE; + } + stream = PIPESTREAM(program, command_line, flags); + LispMused(program); + + return (stream); +} + +/* Helper function, primarily for use with the xt module + */ +LispObj * +Lisp_PipeBroken(LispBuiltin *builtin) +/* + pipe-broken pipe-stream + */ +{ + int pid, status, retval; + LispObj *result = NIL; + + LispObj *pipe_stream; + + pipe_stream = ARGUMENT(0); + + if (!STREAMP(pipe_stream) || + pipe_stream->data.stream.type != LispStreamPipe) + LispDestroy("%s: %s is not a pipe stream", + STRFUN(builtin), STROBJ(pipe_stream)); + + if ((pid = PIDPSTREAMP(pipe_stream)) > 0) { + retval = waitpid(pid, &status, WNOHANG | WUNTRACED); + if (retval == pid || (retval == -1 && errno == ECHILD)) + result = T; + } + + return (result); +} + +/* + Helper function, so that it is not required to redirect error output + */ +LispObj * +Lisp_PipeErrorStream(LispBuiltin *builtin) +/* + pipe-error-stream pipe-stream + */ +{ + LispObj *pipe_stream; + + pipe_stream = ARGUMENT(0); + + if (!STREAMP(pipe_stream) || + pipe_stream->data.stream.type != LispStreamPipe) + LispDestroy("%s: %s is not a pipe stream", + STRFUN(builtin), STROBJ(pipe_stream)); + + return (pipe_stream->data.stream.source.program->errorp); +} + +/* + Helper function, primarily for use with the xt module + */ +LispObj * +Lisp_PipeInputDescriptor(LispBuiltin *builtin) +/* + pipe-input-descriptor pipe-stream + */ +{ + LispObj *pipe_stream; + + pipe_stream = ARGUMENT(0); + + if (!STREAMP(pipe_stream) || + pipe_stream->data.stream.type != LispStreamPipe) + LispDestroy("%s: %s is not a pipe stream", + STRFUN(builtin), STROBJ(pipe_stream)); + if (!IPSTREAMP(pipe_stream)) + LispDestroy("%s: pipe %s is unreadable", + STRFUN(builtin), STROBJ(pipe_stream)); + + return (INTEGER(LispFileno(IPSTREAMP(pipe_stream)))); +} + +/* + Helper function, primarily for use with the xt module + */ +LispObj * +Lisp_PipeErrorDescriptor(LispBuiltin *builtin) +/* + pipe-error-descriptor pipe-stream + */ +{ + LispObj *pipe_stream; + + pipe_stream = ARGUMENT(0); + + if (!STREAMP(pipe_stream) || + pipe_stream->data.stream.type != LispStreamPipe) + LispDestroy("%s: %s is not a pipe stream", + STRFUN(builtin), STROBJ(pipe_stream)); + if (!EPSTREAMP(pipe_stream)) + LispDestroy("%s: pipe %s is closed", + STRFUN(builtin), STROBJ(pipe_stream)); + + return (INTEGER(LispFileno(EPSTREAMP(pipe_stream)))); +} diff --git a/lisp/stream.h b/lisp/stream.h new file mode 100644 index 0000000..c510224 --- /dev/null +++ b/lisp/stream.h @@ -0,0 +1,58 @@ +/* + * 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/stream.h,v 1.8 2002/12/06 03:25:27 paulo Exp $ */ + +#ifndef Lisp_stream_h +#define Lisp_stream_h + +#include "io.h" +#include "internal.h" + +void LispStreamInit(void); + +LispObj *Lisp_DeleteFile(LispBuiltin*); +LispObj *Lisp_RenameFile(LispBuiltin*); +LispObj *Lisp_InputStreamP(LispBuiltin*); +LispObj *Lisp_OpenStreamP(LispBuiltin*); +LispObj *Lisp_OutputStreamP(LispBuiltin*); +LispObj *Lisp_Open(LispBuiltin*); +LispObj *Lisp_MakePipe(LispBuiltin*); +LispObj *Lisp_PipeBroken(LispBuiltin*); +LispObj *Lisp_PipeErrorStream(LispBuiltin*); +LispObj *Lisp_PipeInputDescriptor(LispBuiltin*); +LispObj *Lisp_PipeErrorDescriptor(LispBuiltin*); +LispObj *Lisp_Close(LispBuiltin*); +LispObj *Lisp_Listen(LispBuiltin*); +LispObj *Lisp_Streamp(LispBuiltin*); +LispObj *Lisp_MakeStringInputStream(LispBuiltin*); +LispObj *Lisp_MakeStringOutputStream(LispBuiltin*); +LispObj *Lisp_GetOutputStreamString(LispBuiltin*); + +#endif /* Lisp_stream_h */ diff --git a/lisp/string.c b/lisp/string.c new file mode 100644 index 0000000..95952bd --- /dev/null +++ b/lisp/string.c @@ -0,0 +1,1383 @@ +/* + * 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/string.c,v 1.22 2002/12/04 05:27:58 paulo Exp $ */ + +#include "helper.h" +#include "read.h" +#include "string.h" +#include "private.h" +#include <ctype.h> + +#define CHAR_LESS 1 +#define CHAR_LESS_EQUAL 2 +#define CHAR_EQUAL 3 +#define CHAR_GREATER_EQUAL 4 +#define CHAR_GREATER 5 +#define CHAR_NOT_EQUAL 6 + +#define CHAR_ALPHAP 1 +#define CHAR_DOWNCASE 2 +#define CHAR_UPCASE 3 +#define CHAR_INT 4 +#define CHAR_BOTHP 5 +#define CHAR_UPPERP 6 +#define CHAR_LOWERP 7 +#define CHAR_GRAPHICP 8 + +#ifndef MIN +#define MIN(a, b) ((a) < (b) ? (a) : (b)) +#endif + +/* + * Prototypes + */ +static LispObj *LispCharCompare(LispBuiltin*, int, int); +static LispObj *LispStringCompare(LispBuiltin*, int, int); +static LispObj *LispCharOp(LispBuiltin*, int); +static LispObj *LispStringTrim(LispBuiltin*, int, int, int); +static LispObj *LispStringUpcase(LispBuiltin*, int); +static LispObj *LispStringDowncase(LispBuiltin*, int); +static LispObj *LispStringCapitalize(LispBuiltin*, int); + +/* + * Implementation + */ +static LispObj * +LispCharCompare(LispBuiltin *builtin, int operation, int ignore_case) +{ + LispObj *object; + int cmp, value, next_value; + + LispObj *character, *more_characters; + + more_characters = ARGUMENT(1); + character = ARGUMENT(0); + + CHECK_SCHAR(character); + value = SCHAR_VALUE(character); + if (ignore_case && islower(value)) + value = toupper(value); + + if (!CONSP(more_characters)) + return (T); + + /* First check if all parameters are characters */ + for (object = more_characters; CONSP(object); object = CDR(object)) + CHECK_SCHAR(CAR(object)); + + /* All characters in list must be different */ + if (operation == CHAR_NOT_EQUAL) { + /* Compare all characters */ + do { + for (object = more_characters; CONSP(object); object = CDR(object)) { + character = CAR(object); + next_value = SCHAR_VALUE(character); + if (ignore_case && islower(next_value)) + next_value = toupper(next_value); + if (value == next_value) + return (NIL); + } + value = SCHAR_VALUE(CAR(more_characters)); + if (ignore_case && islower(value)) + value = toupper(value); + more_characters = CDR(more_characters); + } while (CONSP(more_characters)); + + return (T); + } + + /* Linearly compare characters */ + for (; CONSP(more_characters); more_characters = CDR(more_characters)) { + character = CAR(more_characters); + next_value = SCHAR_VALUE(character); + if (ignore_case && islower(next_value)) + next_value = toupper(next_value); + + switch (operation) { + case CHAR_LESS: cmp = value < next_value; break; + case CHAR_LESS_EQUAL: cmp = value <= next_value; break; + case CHAR_EQUAL: cmp = value == next_value; break; + case CHAR_GREATER_EQUAL: cmp = value >= next_value; break; + case CHAR_GREATER: cmp = value > next_value; break; + default: cmp = 0; break; + } + + if (!cmp) + return (NIL); + value = next_value; + } + + return (T); +} + +LispObj * +Lisp_CharLess(LispBuiltin *builtin) +/* + char< character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_LESS, 0)); +} + +LispObj * +Lisp_CharLessEqual(LispBuiltin *builtin) +/* + char<= character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_LESS_EQUAL, 0)); +} + +LispObj * +Lisp_CharEqual_(LispBuiltin *builtin) +/* + char= character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_EQUAL, 0)); +} + +LispObj * +Lisp_CharGreater(LispBuiltin *builtin) +/* + char> character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_GREATER, 0)); +} + +LispObj * +Lisp_CharGreaterEqual(LispBuiltin *builtin) +/* + char>= character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_GREATER_EQUAL, 0)); +} + +LispObj * +Lisp_CharNotEqual_(LispBuiltin *builtin) +/* + char/= character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_NOT_EQUAL, 0)); +} + +LispObj * +Lisp_CharLessp(LispBuiltin *builtin) +/* + char-lessp character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_LESS, 1)); +} + +LispObj * +Lisp_CharNotGreaterp(LispBuiltin *builtin) +/* + char-not-greaterp character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_LESS_EQUAL, 1)); +} + +LispObj * +Lisp_CharEqual(LispBuiltin *builtin) +/* + char-equalp character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_EQUAL, 1)); +} + +LispObj * +Lisp_CharGreaterp(LispBuiltin *builtin) +/* + char-greaterp character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_GREATER, 1)); +} + +LispObj * +Lisp_CharNotLessp(LispBuiltin *builtin) +/* + char-not-lessp &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_GREATER_EQUAL, 1)); +} + +LispObj * +Lisp_CharNotEqual(LispBuiltin *builtin) +/* + char-not-equal character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_NOT_EQUAL, 1)); +} + +static LispObj * +LispCharOp(LispBuiltin *builtin, int operation) +{ + int value; + LispObj *result, *character; + + character = ARGUMENT(0); + CHECK_SCHAR(character); + value = (int)SCHAR_VALUE(character); + + switch (operation) { + case CHAR_ALPHAP: + result = isalpha(value) ? T : NIL; + break; + case CHAR_DOWNCASE: + result = SCHAR(tolower(value)); + break; + case CHAR_UPCASE: + result = SCHAR(toupper(value)); + break; + case CHAR_INT: + result = FIXNUM(value); + break; + case CHAR_BOTHP: + result = isupper(value) || islower(value) ? T : NIL; + break; + case CHAR_UPPERP: + result = isupper(value) ? T : NIL; + break; + case CHAR_LOWERP: + result = islower(value) ? T : NIL; + break; + case CHAR_GRAPHICP: + result = value == ' ' || isgraph(value) ? T : NIL; + break; + default: + result = NIL; + break; + } + + return (result); +} + +LispObj * +Lisp_AlphaCharP(LispBuiltin *builtin) +/* + alpha-char-p char + */ +{ + return (LispCharOp(builtin, CHAR_ALPHAP)); +} + +LispObj * +Lisp_CharDowncase(LispBuiltin *builtin) +/* + char-downcase character + */ +{ + return (LispCharOp(builtin, CHAR_DOWNCASE)); +} + +LispObj * +Lisp_CharInt(LispBuiltin *builtin) +/* + char-int character + char-code character + */ +{ + return (LispCharOp(builtin, CHAR_INT)); +} + +LispObj * +Lisp_CharUpcase(LispBuiltin *builtin) +/* + char-upcase character + */ +{ + return (LispCharOp(builtin, CHAR_UPCASE)); +} + +LispObj * +Lisp_BothCaseP(LispBuiltin *builtin) +/* + both-case-p character + */ +{ + return (LispCharOp(builtin, CHAR_BOTHP)); +} + +LispObj * +Lisp_UpperCaseP(LispBuiltin *builtin) +/* + upper-case-p character + */ +{ + return (LispCharOp(builtin, CHAR_UPPERP)); +} + +LispObj * +Lisp_LowerCaseP(LispBuiltin *builtin) +/* + upper-case-p character + */ +{ + return (LispCharOp(builtin, CHAR_LOWERP)); +} + +LispObj * +Lisp_GraphicCharP(LispBuiltin *builtin) +/* + graphic-char-p char + */ +{ + return (LispCharOp(builtin, CHAR_GRAPHICP)); +} + +LispObj * +Lisp_Char(LispBuiltin *builtin) +/* + char string index + schar simple-string index + */ +{ + char *string; + long offset, length; + + LispObj *ostring, *oindex; + + oindex = ARGUMENT(1); + ostring = ARGUMENT(0); + + CHECK_STRING(ostring); + CHECK_INDEX(oindex); + offset = FIXNUM_VALUE(oindex); + string = THESTR(ostring); + length = STRLEN(ostring); + + if (offset >= length) + LispDestroy("%s: index %ld too large for string length %ld", + STRFUN(builtin), offset, length); + + return (SCHAR(string[offset])); +} + +/* helper function for setf + * DONT explicitly call. Non standard function + */ +LispObj * +Lisp_XeditCharStore(LispBuiltin *builtin) +/* + xedit::char-store string index value + */ +{ + int character; + long offset, length; + LispObj *ostring, *oindex, *ovalue; + + ovalue = ARGUMENT(2); + oindex = ARGUMENT(1); + ostring = ARGUMENT(0); + + CHECK_STRING(ostring); + CHECK_INDEX(oindex); + length = STRLEN(ostring); + offset = FIXNUM_VALUE(oindex); + if (offset >= length) + LispDestroy("%s: index %ld too large for string length %ld", + STRFUN(builtin), offset, length); + CHECK_SCHAR(ovalue); + CHECK_STRING_WRITABLE(ostring); + + character = SCHAR_VALUE(ovalue); + + if (character < 0 || character > 255) + LispDestroy("%s: cannot represent character %d", + STRFUN(builtin), character); + + THESTR(ostring)[offset] = character; + + return (ovalue); +} + +LispObj * +Lisp_Character(LispBuiltin *builtin) +/* + character object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (LispCharacterCoerce(builtin, object)); +} + +LispObj * +Lisp_Characterp(LispBuiltin *builtin) +/* + characterp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (SCHARP(object) ? T : NIL); +} + +LispObj * +Lisp_DigitChar(LispBuiltin *builtin) +/* + digit-char weight &optional radix + */ +{ + long radix = 10, weight; + LispObj *oweight, *oradix, *result = NIL; + + oradix = ARGUMENT(1); + oweight = ARGUMENT(0); + + CHECK_FIXNUM(oweight); + weight = FIXNUM_VALUE(oweight); + + if (oradix != UNSPEC) { + CHECK_INDEX(oradix); + radix = FIXNUM_VALUE(oradix); + } + if (radix < 2 || radix > 36) + LispDestroy("%s: radix must be >= 2 and <= 36, not %ld", + STRFUN(builtin), radix); + + if (weight >= 0 && weight < radix) { + if (weight < 9) + weight += '0'; + else + weight += 'A' - 10; + result = SCHAR(weight); + } + + return (result); +} + +LispObj * +Lisp_DigitCharP(LispBuiltin *builtin) +/* + digit-char-p character &optional radix + */ +{ + long radix = 10, character; + LispObj *ochar, *oradix, *result = NIL; + + oradix = ARGUMENT(1); + ochar = ARGUMENT(0); + + CHECK_SCHAR(ochar); + character = SCHAR_VALUE(ochar); + if (oradix != UNSPEC) { + CHECK_INDEX(oradix); + radix = FIXNUM_VALUE(oradix); + } + if (radix < 2 || radix > 36) + LispDestroy("%s: radix must be >= 2 and <= 36, not %ld", + STRFUN(builtin), radix); + + if (character >= '0' && character <= '9') + character -= '0'; + else if (character >= 'A' && character <= 'Z') + character -= 'A' - 10; + else if (character >= 'a' && character <= 'z') + character -= 'a' - 10; + if (character < radix) + result = FIXNUM(character); + + return (result); +} + +LispObj * +Lisp_IntChar(LispBuiltin *builtin) +/* + int-char integer + code-char integer + */ +{ + long character = 0; + LispObj *integer; + + integer = ARGUMENT(0); + + CHECK_FIXNUM(integer); + character = FIXNUM_VALUE(integer); + + return (character >= 0 && character < 0xff ? SCHAR(character) : NIL); +} + +/* XXX ignoring element-type */ +LispObj * +Lisp_MakeString(LispBuiltin *builtin) +/* + make-string size &key initial-element element-type + */ +{ + long length; + char *string, initial; + + LispObj *size, *initial_element, *element_type; + + element_type = ARGUMENT(2); + initial_element = ARGUMENT(1); + size = ARGUMENT(0); + + CHECK_INDEX(size); + length = FIXNUM_VALUE(size); + if (initial_element != UNSPEC) { + CHECK_SCHAR(initial_element); + initial = SCHAR_VALUE(initial_element); + } + else + initial = 0; + + string = LispMalloc(length + 1); + memset(string, initial, length); + string[length] = '\0'; + + return (LSTRING2(string, length)); +} + +LispObj * +Lisp_ParseInteger(LispBuiltin *builtin) +/* + parse-integer string &key start end radix junk-allowed + */ +{ + GC_ENTER(); + char *ptr, *string; + int character, junk, sign, overflow; + long i, start, end, radix, length, integer, check; + LispObj *result; + + LispObj *ostring, *ostart, *oend, *oradix, *junk_allowed; + + junk_allowed = ARGUMENT(4); + oradix = ARGUMENT(3); + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + ostring = ARGUMENT(0); + + start = end = radix = 0; + result = NIL; + + CHECK_STRING(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &length); + string = THESTR(ostring); + if (radix < 2 || radix > 36) + LispDestroy("%s: :RADIX %ld must be in the range 2 to 36", + STRFUN(builtin), radix); + + integer = check = 0; + ptr = string + start; + sign = overflow = 0; + + /* Skip leading white spaces */ + for (i = start; i < end && *ptr && isspace(*ptr); ptr++, i++) + ; + + /* Check for sign specification */ + if (i < end && (*ptr == '-' || *ptr == '+')) { + sign = *ptr == '-'; + ++ptr; + ++i; + } + + for (junk = 0; i < end; i++, ptr++) { + character = *ptr; + if (islower(character)) + character = toupper(character); + if (character >= '0' && character <= '9') { + if (character - '0' >= radix) + junk = 1; + else { + check = integer; + integer = integer * radix + character - '0'; + } + } + else if (character >= 'A' && character <= 'Z') { + if (character - 'A' + 10 >= radix) + junk = 1; + else { + check = integer; + integer = integer * radix + character - 'A' + 10; + } + } + else { + if (isspace(character)) + break; + junk = 1; + } + + if (junk) + break; + + if (!overflow && check > integer) + overflow = 1; + /* keep looping just to count read bytes */ + } + + if (!junk) + /* Skip white spaces */ + for (; i < end && *ptr && isspace(*ptr); ptr++, i++) + ; + + if ((junk || ptr == string) && + (junk_allowed == UNSPEC || junk_allowed == NIL)) + LispDestroy("%s: %s has a bad integer representation", + STRFUN(builtin), STROBJ(ostring)); + else if (ptr == string) + result = NIL; + else if (overflow) { + mpi *bigi = LispMalloc(sizeof(mpi)); + char *str; + + length = end - start + sign; + str = LispMalloc(length + 1); + + strncpy(str, string - sign, length + sign); + str[length + sign] = '\0'; + mpi_init(bigi); + mpi_setstr(bigi, str, radix); + LispFree(str); + result = BIGNUM(bigi); + } + else + result = INTEGER(sign ? -integer : integer); + + GC_PROTECT(result); + RETURN(0) = FIXNUM(i); + RETURN_COUNT = 1; + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_String(LispBuiltin *builtin) +/* + string object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (LispStringCoerce(builtin, object)); +} + +LispObj * +Lisp_Stringp(LispBuiltin *builtin) +/* + stringp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (STRINGP(object) ? T : NIL); +} + +/* XXX preserve-whitespace is being ignored */ +LispObj * +Lisp_ReadFromString(LispBuiltin *builtin) +/* + read-from-string string &optional eof-error-p eof-value &key start end preserve-whitespace + */ +{ + GC_ENTER(); + char *string; + LispObj *stream, *result; + long length, start, end, bytes_read; + + LispObj *ostring, *eof_error_p, *eof_value, + *ostart, *oend, *preserve_white_space; + + preserve_white_space = ARGUMENT(5); + oend = ARGUMENT(4); + ostart = ARGUMENT(3); + eof_value = ARGUMENT(2); + eof_error_p = ARGUMENT(1); + ostring = ARGUMENT(0); + + CHECK_STRING(ostring); + string = THESTR(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &length); + + if (start > 0 || end < length) + length = end - start; + stream = LSTRINGSTREAM(string + start, STREAM_READ, length); + + if (eof_value == UNSPEC) + eof_value = NIL; + + LispPushInput(stream); + result = LispRead(); + /* stream->data.stream.source.string->input is + * the offset of the last byte read in string */ + bytes_read = stream->data.stream.source.string->input; + LispPopInput(stream); + + if (result == NULL) { + if (eof_error_p == NIL) + result = eof_value; + else + LispDestroy("%s: unexpected end of input", STRFUN(builtin)); + } + + GC_PROTECT(result); + RETURN(0) = FIXNUM(start + bytes_read); + RETURN_COUNT = 1; + GC_LEAVE(); + + return (result); +} + +static LispObj * +LispStringTrim(LispBuiltin *builtin, int left, int right, int inplace) +/* + string-{,left-,right-}trim character-bag string +*/ +{ + unsigned char *string; + long start, end, length; + + LispObj *ochars, *ostring; + + ostring = ARGUMENT(1); + ochars = ARGUMENT(0); + + if (!POINTERP(ochars) || !(XSTRINGP(ochars) || XCONSP(ochars))) { + if (ARRAYP(ochars) && ochars->data.array.rank == 1) + ochars = ochars->data.array.list; + else + LispDestroy("%s: %s is not a sequence", + STRFUN(builtin), STROBJ(ochars)); + } + CHECK_STRING(ostring); + + string = (unsigned char*)THESTR(ostring); + length = STRLEN(ostring); + + start = 0; + end = length; + + if (XSTRINGP(ochars)) { + unsigned char *chars = (unsigned char*)THESTR(ochars); + long i, clength = STRLEN(ochars); + + if (left) { + for (; start < end; start++) { + for (i = 0; i < clength; i++) + if (string[start] == chars[i]) + break; + if (i >= clength) + break; + } + } + if (right) { + for (--end; end >= 0; end--) { + for (i = 0; i < clength; i++) + if (string[end] == chars[i]) + break; + if (i >= clength) + break; + } + ++end; + } + } + else { + LispObj *ochar, *list; + + if (left) { + for (; start < end; start++) { + for (list = ochars; CONSP(list); list = CDR(list)) { + ochar = CAR(list); + if (SCHARP(ochar) && string[start] == SCHAR_VALUE(ochar)) + break; + } + if (!CONSP(list)) + break; + } + } + if (right) { + for (--end; end >= 0; end--) { + for (list = ochars; CONSP(list); list = CDR(list)) { + ochar = CAR(list); + if (SCHARP(ochar) && string[end] == SCHAR_VALUE(ochar)) + break; + } + if (!CONSP(list)) + break; + } + ++end; + } + } + + if (start == 0 && end == length) + return (ostring); + + length = end - start; + + if (inplace) { + CHECK_STRING_WRITABLE(ostring); + memmove(string, string + start, length); + string[length] = '\0'; + STRLEN(ostring) = length; + } + else { + string = LispMalloc(length + 1); + memcpy(string, THESTR(ostring) + start, length); + string[length] = '\0'; + ostring = LSTRING2((char*)string, length); + } + + return (ostring); +} + +LispObj * +Lisp_StringTrim(LispBuiltin *builtin) +/* + string-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 1, 1, 0)); +} + +LispObj * +Lisp_NstringTrim(LispBuiltin *builtin) +/* + ext::nstring-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 1, 1, 1)); +} + +LispObj * +Lisp_StringLeftTrim(LispBuiltin *builtin) +/* + string-left-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 1, 0, 0)); +} + +LispObj * +Lisp_NstringLeftTrim(LispBuiltin *builtin) +/* + ext::nstring-left-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 1, 0, 1)); +} + +LispObj * +Lisp_StringRightTrim(LispBuiltin *builtin) +/* + string-right-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 0, 1, 0)); +} + +LispObj * +Lisp_NstringRightTrim(LispBuiltin *builtin) +/* + ext::nstring-right-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 0, 1, 1)); +} + +static LispObj * +LispStringCompare(LispBuiltin *builtin, int function, int ignore_case) +{ + int cmp1, cmp2; + LispObj *fixnum; + unsigned char *string1, *string2; + long start1, end1, start2, end2, offset, length; + + LispGetStringArgs(builtin, (char**)&string1, (char**)&string2, + &start1, &end1, &start2, &end2); + + string1 += start1; + string2 += start2; + + if (function == CHAR_EQUAL) { + length = end1 - start1; + + if (length != (end2 - start2)) + return (NIL); + + if (!ignore_case) + return (memcmp(string1, string2, length) ? NIL : T); + + for (; length; length--, string1++, string2++) + if (toupper(*string1) != toupper(*string2)) + return (NIL); + return (T); + } + + end1 -= start1; + end2 -= start2; + length = MIN(end1, end2); + for (offset = 0; + offset < length; + string1++, string2++, offset++, start1++, start2++) { + cmp1 = *string1; + cmp2 = *string2; + if (ignore_case) { + cmp1 = toupper(cmp1); + cmp2 = toupper(cmp2); + } + if (cmp1 != cmp2) { + fixnum = FIXNUM(start1); + switch (function) { + case CHAR_LESS: + return ((cmp1 < cmp2) ? fixnum : NIL); + case CHAR_LESS_EQUAL: + return ((cmp1 <= cmp2) ? fixnum : NIL); + case CHAR_NOT_EQUAL: + return (fixnum); + case CHAR_GREATER_EQUAL: + return ((cmp1 >= cmp2) ? fixnum : NIL); + case CHAR_GREATER: + return ((cmp1 > cmp2) ? fixnum : NIL); + } + } + } + + fixnum = FIXNUM(start1); + switch (function) { + case CHAR_LESS: + return (start1 >= end1 && start2 < end2 ? fixnum : NIL); + case CHAR_LESS_EQUAL: + return (start1 >= end1 ? fixnum : NIL); + case CHAR_NOT_EQUAL: + return (start1 >= end1 && start2 >= end2 ? NIL : fixnum); + case CHAR_GREATER_EQUAL: + return (start2 >= end2 ? fixnum : NIL); + case CHAR_GREATER: + return (start2 >= end2 && start1 < end1 ? fixnum : NIL); + } + + return (NIL); +} + +LispObj * +Lisp_StringEqual_(LispBuiltin *builtin) +/* + string= string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_EQUAL, 0)); +} + +LispObj * +Lisp_StringLess(LispBuiltin *builtin) +/* + string< string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_LESS, 0)); +} + +LispObj * +Lisp_StringGreater(LispBuiltin *builtin) +/* + string> string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_GREATER, 0)); +} + +LispObj * +Lisp_StringLessEqual(LispBuiltin *builtin) +/* + string<= string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_LESS_EQUAL, 0)); +} + +LispObj * +Lisp_StringGreaterEqual(LispBuiltin *builtin) +/* + string>= string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_GREATER_EQUAL, 0)); +} + +LispObj * +Lisp_StringNotEqual_(LispBuiltin *builtin) +/* + string/= string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_NOT_EQUAL, 0)); +} + +LispObj * +Lisp_StringEqual(LispBuiltin *builtin) +/* + string-equal string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_EQUAL, 1)); +} + +LispObj * +Lisp_StringLessp(LispBuiltin *builtin) +/* + string-lessp string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_LESS, 1)); +} + +LispObj * +Lisp_StringGreaterp(LispBuiltin *builtin) +/* + string-greaterp string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_GREATER, 1)); +} + +LispObj * +Lisp_StringNotGreaterp(LispBuiltin *builtin) +/* + string-not-greaterp string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_LESS_EQUAL, 1)); +} + +LispObj * +Lisp_StringNotLessp(LispBuiltin *builtin) +/* + string-not-lessp string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_GREATER_EQUAL, 1)); +} + +LispObj * +Lisp_StringNotEqual(LispBuiltin *builtin) +/* + string-not-equal string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_NOT_EQUAL, 1)); +} + +LispObj * +LispStringUpcase(LispBuiltin *builtin, int inplace) +/* + string-upcase string &key start end + nstring-upcase string &key start end + */ +{ + LispObj *result; + char *string, *newstring; + long start, end, length, offset; + + LispObj *ostring, *ostart, *oend; + + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + ostring = ARGUMENT(0); + CHECK_STRING(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &offset); + result = ostring; + string = THESTR(ostring); + length = STRLEN(ostring); + + /* first check if something need to be done */ + for (offset = start; offset < end; offset++) + if (string[offset] != toupper(string[offset])) + break; + + if (offset >= end) + return (result); + + if (inplace) { + CHECK_STRING_WRITABLE(ostring); + newstring = string; + } + else { + /* upcase a copy of argument */ + newstring = LispMalloc(length + 1); + if (offset) + memcpy(newstring, string, offset); + if (length > end) + memcpy(newstring + end, string + end, length - end); + newstring[length] = '\0'; + } + + for (; offset < end; offset++) + newstring[offset] = toupper(string[offset]); + + if (!inplace) + result = LSTRING2(newstring, length); + + return (result); +} + +LispObj * +Lisp_StringUpcase(LispBuiltin *builtin) +/* + string-upcase string &key start end + */ +{ + return (LispStringUpcase(builtin, 0)); +} + +LispObj * +Lisp_NstringUpcase(LispBuiltin *builtin) +/* + nstring-upcase string &key start end + */ +{ + return (LispStringUpcase(builtin, 1)); +} + +LispObj * +LispStringDowncase(LispBuiltin *builtin, int inplace) +/* + string-downcase string &key start end + nstring-downcase string &key start end + */ +{ + LispObj *result; + char *string, *newstring; + long start, end, length, offset; + + LispObj *ostring, *ostart, *oend; + + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + ostring = ARGUMENT(0); + CHECK_STRING(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &offset); + result = ostring; + string = THESTR(ostring); + length = STRLEN(ostring); + + /* first check if something need to be done */ + for (offset = start; offset < end; offset++) + if (string[offset] != tolower(string[offset])) + break; + + if (offset >= end) + return (result); + + if (inplace) { + CHECK_STRING_WRITABLE(ostring); + newstring = string; + } + else { + /* downcase a copy of argument */ + newstring = LispMalloc(length + 1); + if (offset) + memcpy(newstring, string, offset); + if (length > end) + memcpy(newstring + end, string + end, length - end); + newstring[length] = '\0'; + } + for (; offset < end; offset++) + newstring[offset] = tolower(string[offset]); + + if (!inplace) + result = LSTRING2(newstring, length); + + return (result); +} + +LispObj * +Lisp_StringDowncase(LispBuiltin *builtin) +/* + string-downcase string &key start end + */ +{ + return (LispStringDowncase(builtin, 0)); +} + +LispObj * +Lisp_NstringDowncase(LispBuiltin *builtin) +/* + nstring-downcase string &key start end + */ +{ + return (LispStringDowncase(builtin, 1)); +} + +LispObj * +LispStringCapitalize(LispBuiltin *builtin, int inplace) +/* + string-capitalize string &key start end + nstring-capitalize string &key start end + */ +{ + LispObj *result; + char *string, *newstring; + long start, end, length, offset, upcase; + + LispObj *ostring, *ostart, *oend; + + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + ostring = ARGUMENT(0); + CHECK_STRING(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &offset); + result = ostring; + string = THESTR(ostring); + length = STRLEN(ostring); + + /* first check if something need to be done */ + for (upcase = 1, offset = start; offset < end; offset++) { + if (upcase) { + if (!isalnum(string[offset])) + continue; + if (string[offset] != toupper(string[offset])) + break; + upcase = 0; + } + else { + if (isalnum(string[offset])) { + if (string[offset] != tolower(string[offset])) + break; + } + else + upcase = 1; + } + } + + if (offset >= end) + return (result); + + if (inplace) { + CHECK_STRING_WRITABLE(ostring); + newstring = string; + } + else { + /* capitalize a copy of argument */ + newstring = LispMalloc(length + 1); + memcpy(newstring, string, length); + newstring[length] = '\0'; + } + for (; offset < end; offset++) { + if (upcase) { + if (!isalnum(string[offset])) + continue; + newstring[offset] = toupper(string[offset]); + upcase = 0; + } + else { + if (isalnum(newstring[offset])) + newstring[offset] = tolower(string[offset]); + else + upcase = 1; + } + } + + if (!inplace) + result = LSTRING2(newstring, length); + + return (result); +} + +LispObj * +Lisp_StringCapitalize(LispBuiltin *builtin) +/* + string-capitalize string &key start end + */ +{ + return (LispStringCapitalize(builtin, 0)); +} + +LispObj * +Lisp_NstringCapitalize(LispBuiltin *builtin) +/* + nstring-capitalize string &key start end + */ +{ + return (LispStringCapitalize(builtin, 1)); +} + +LispObj * +Lisp_StringConcat(LispBuiltin *builtin) +/* + string-concat &rest strings + */ +{ + char *buffer; + long size, length; + LispObj *object, *string; + + LispObj *strings; + + strings = ARGUMENT(0); + + if (strings == NIL) + return (STRING("")); + + for (length = 1, object = strings; CONSP(object); object = CDR(object)) { + string = CAR(object); + CHECK_STRING(string); + length += STRLEN(string); + } + + buffer = LispMalloc(length); + + for (length = 0, object = strings; CONSP(object); object = CDR(object)) { + string = CAR(object); + size = STRLEN(string); + memcpy(buffer + length, THESTR(string), size); + length += size; + } + buffer[length] = '\0'; + object = LSTRING2(buffer, length); + + return (object); +} diff --git a/lisp/string.h b/lisp/string.h new file mode 100644 index 0000000..02b416b --- /dev/null +++ b/lisp/string.h @@ -0,0 +1,95 @@ +/* + * 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/string.h,v 1.11 2002/11/25 02:35:30 paulo Exp $ */ + +#ifndef Lisp_string_h +#define Lisp_string_h + +#include "internal.h" + +LispObj *Lisp_AlphaCharP(LispBuiltin*); +LispObj *Lisp_BothCaseP(LispBuiltin*); +LispObj *Lisp_Char(LispBuiltin*); +LispObj *Lisp_CharLess(LispBuiltin*); +LispObj *Lisp_CharLessEqual(LispBuiltin*); +LispObj *Lisp_CharEqual_(LispBuiltin*); +LispObj *Lisp_CharGreater(LispBuiltin*); +LispObj *Lisp_CharGreaterEqual(LispBuiltin*); +LispObj *Lisp_CharNotEqual_(LispBuiltin*); +LispObj *Lisp_CharLessp(LispBuiltin*); +LispObj *Lisp_CharNotGreaterp(LispBuiltin*); +LispObj *Lisp_CharEqual(LispBuiltin*); +LispObj *Lisp_CharGreaterp(LispBuiltin*); +LispObj *Lisp_CharNotLessp(LispBuiltin*); +LispObj *Lisp_CharNotEqual(LispBuiltin*); +LispObj *Lisp_Character(LispBuiltin*); +LispObj *Lisp_Characterp(LispBuiltin*); +LispObj *Lisp_CharDowncase(LispBuiltin*); +LispObj *Lisp_CharInt(LispBuiltin*); +LispObj *Lisp_CharUpcase(LispBuiltin*); +LispObj *Lisp_DigitChar(LispBuiltin*); +LispObj *Lisp_DigitCharP(LispBuiltin*); +LispObj *Lisp_IntChar(LispBuiltin*); +LispObj *Lisp_GraphicCharP(LispBuiltin*); +LispObj *Lisp_LowerCaseP(LispBuiltin*); +LispObj *Lisp_MakeString(LispBuiltin*); +LispObj *Lisp_ParseInteger(LispBuiltin*); +LispObj *Lisp_ReadFromString(LispBuiltin*); +LispObj *Lisp_String(LispBuiltin*); +LispObj *Lisp_Stringp(LispBuiltin*); +LispObj *Lisp_StringTrim(LispBuiltin*); +LispObj *Lisp_StringLeftTrim(LispBuiltin*); +LispObj *Lisp_StringRightTrim(LispBuiltin*); +LispObj *Lisp_NstringTrim(LispBuiltin*); +LispObj *Lisp_NstringLeftTrim(LispBuiltin*); +LispObj *Lisp_NstringRightTrim(LispBuiltin*); +LispObj *Lisp_StringEqual_(LispBuiltin*); +LispObj *Lisp_StringLess(LispBuiltin*); +LispObj *Lisp_StringGreater(LispBuiltin*); +LispObj *Lisp_StringLessEqual(LispBuiltin*); +LispObj *Lisp_StringGreaterEqual(LispBuiltin*); +LispObj *Lisp_StringNotEqual_(LispBuiltin*); +LispObj *Lisp_StringEqual(LispBuiltin*); +LispObj *Lisp_StringGreaterp(LispBuiltin*); +LispObj *Lisp_StringLessp(LispBuiltin*); +LispObj *Lisp_StringNotLessp(LispBuiltin*); +LispObj *Lisp_StringNotGreaterp(LispBuiltin*); +LispObj *Lisp_StringNotEqual(LispBuiltin*); +LispObj *Lisp_NstringUpcase(LispBuiltin*); +LispObj *Lisp_StringUpcase(LispBuiltin*); +LispObj *Lisp_StringDowncase(LispBuiltin*); +LispObj *Lisp_NstringDowncase(LispBuiltin*); +LispObj *Lisp_StringCapitalize(LispBuiltin*); +LispObj *Lisp_NstringCapitalize(LispBuiltin*); +LispObj *Lisp_StringConcat(LispBuiltin*); +LispObj *Lisp_UpperCaseP(LispBuiltin*); +LispObj *Lisp_XeditCharStore(LispBuiltin*); + +#endif /* Lisp_string_h */ diff --git a/lisp/struct.c b/lisp/struct.c new file mode 100644 index 0000000..0d2a768 --- /dev/null +++ b/lisp/struct.c @@ -0,0 +1,371 @@ +/* + * 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/struct.c,v 1.22 2002/11/23 08:26:50 paulo Exp $ */ + +#include "struct.h" + +/* + * Prototypes + */ +static LispObj *LispStructAccessOrStore(LispBuiltin*, int); + +/* + * Initialization + */ +LispObj *Omake_struct, *Ostruct_access, *Ostruct_store, *Ostruct_type; + +Atom_id Smake_struct, Sstruct_access, Sstruct_store, Sstruct_type; + +/* + * Implementation + */ +LispObj * +Lisp_Defstruct(LispBuiltin *builtin) +/* + defstruct name &rest description + */ +{ + int intern; + LispAtom *atom; + int i, size, length, slength; + char *name, *strname, *sname; + LispObj *list, *cons, *object, *definition, *documentation; + + LispObj *oname, *description; + + description = ARGUMENT(1); + oname = ARGUMENT(0); + + CHECK_SYMBOL(oname); + + strname = ATOMID(oname); + length = strlen(strname); + + /* MAKE- */ + size = length + 6; + name = LispMalloc(size); + + sprintf(name, "MAKE-%s", strname); + atom = (object = ATOM(name))->data.atom; + + if (atom->a_builtin) + LispDestroy("%s: %s cannot be a structure name", + STRFUN(builtin), STROBJ(oname)); + + intern = !atom->ext; + + if (CONSP(description) && STRINGP(CAR(description))) { + documentation = CAR(description); + description = CDR(description); + } + else + documentation = NIL; + + /* get structure fields and default values */ + for (list = description; CONSP(list); list = CDR(list)) { + object = CAR(list); + + cons = list; + if (CONSP(object)) { + if ((CONSP(CDR(object)) && CDR(CDR(object)) != NIL) || + (!CONSP(CDR(object)) && CDR(object) != NIL)) + LispDestroy("%s: bad initialization %s", + STRFUN(builtin), STROBJ(object)); + cons = object; + object = CAR(object); + } + if (!SYMBOLP(object) || strcmp(ATOMID(object), "P") == 0) + /* p is invalid as a field name due to `type'-p */ + LispDestroy("%s: %s cannot be a field for %s", + STRFUN(builtin), STROBJ(object), ATOMID(oname)); + + if (!KEYWORDP(object)) + CAR(cons) = KEYWORD(ATOMID(object)); + + /* check for repeated field names */ + for (object = description; object != list; object = CDR(object)) { + LispObj *left = CAR(object), *right = CAR(list); + + if (CONSP(left)) + left = CAR(left); + if (CONSP(right)) + right = CAR(right); + + if (ATOMID(left) == ATOMID(right)) + LispDestroy("%s: only one slot named %s allowed", + STRFUN(builtin), STROBJ(left)); + } + } + + /* atom should not have been modified */ + definition = CONS(oname, description); + LispSetAtomStructProperty(atom, definition, STRUCT_CONSTRUCTOR); + if (!intern) + LispExportSymbol(object); + + atom = oname->data.atom; + if (atom->a_defstruct) + LispWarning("%s: structure %s is being redefined", + STRFUN(builtin), strname); + LispSetAtomStructProperty(atom, definition, STRUCT_NAME); + + sprintf(name, "%s-P", strname); + atom = (object = ATOM(name))->data.atom; + LispSetAtomStructProperty(atom, definition, STRUCT_CHECK); + if (!intern) + LispExportSymbol(object); + + for (i = 0, list = description; CONSP(list); i++, list = CDR(list)) { + if (CONSP(CAR(list))) + sname = ATOMID(CAR(CAR(list))); + else + sname = ATOMID(CAR(list)); + slength = strlen(sname); + if (length + slength + 2 > size) { + size = length + slength + 2; + name = LispRealloc(name, size); + } + sprintf(name, "%s-%s", strname, sname); + atom = (object = ATOM(name))->data.atom; + LispSetAtomStructProperty(atom, definition, i); + if (!intern) + LispExportSymbol(object); + } + + LispFree(name); + + if (documentation != NIL) + LispAddDocumentation(oname, documentation, LispDocStructure); + + return (oname); +} + +/* helper functions + * DONT explicitly call them. Non standard functions. + */ +LispObj * +Lisp_XeditMakeStruct(LispBuiltin *builtin) +/* + lisp::make-struct atom &rest init + */ +{ + int nfld, ncvt, length = lisp__data.protect.length; + LispAtom *atom = NULL; + + LispObj *definition, *object, *field, *fields, *value = NIL, *cons, *list; + LispObj *struc, *init; + + init = ARGUMENT(1); + struc = ARGUMENT(0); + + field = cons = NIL; + if (!POINTERP(struc) || + !(XSYMBOLP(struc) || XFUNCTIONP(struc)) || + (atom = struc->data.atom)->a_defstruct == 0 || + atom->property->structure.function != STRUCT_CONSTRUCTOR) + LispDestroy("%s: invalid constructor %s", + STRFUN(builtin), STROBJ(struc)); + definition = atom->property->structure.definition; + + ncvt = nfld = 0; + fields = NIL; + + /* check for errors in argument list */ + for (list = init, nfld = 0; CONSP(list); list = CDR(list)) { + CHECK_KEYWORD(CAR(list)); + if (!CONSP(CDR(list))) + LispDestroy("%s: values must be provided as pairs", + ATOMID(struc)); + nfld++; + list = CDR(list); + } + + /* create structure, CAR(definition) is structure name */ + for (list = CDR(definition); CONSP(list); list = CDR(list)) { + Atom_id id; + LispObj *defvalue = NIL; + + ++nfld; + field = CAR(list); + if (CONSP(field)) { + /* if default value provided */ + if (CONSP(CDR(field))) + defvalue = CAR(CDR(field)); + field = CAR(field); + } + id = ATOMID(field); + + for (object = init; CONSP(object); object = CDR(object)) { + /* field is a keyword, test above checked it */ + field = CAR(object); + if (id == ATOMID(field)) { + /* value provided */ + value = CAR(CDR(object)); + ncvt++; + break; + } + object = CDR(object); + } + + /* if no initialization given */ + if (!CONSP(object)) { + /* if default value in structure definition */ + if (defvalue != NIL) + value = EVAL(defvalue); + else + value = NIL; + } + + if (fields == NIL) { + fields = cons = CONS(value, NIL); + if (length + 1 >= lisp__data.protect.space) + LispMoreProtects(); + lisp__data.protect.objects[lisp__data.protect.length++] = fields; + } + else { + RPLACD(cons, CONS(value, NIL)); + cons = CDR(cons); + } + } + + /* if not enough arguments were converted, need to check because + * it is acceptable to set a field more than once, but in that case, + * only the first value will be used. */ + if (nfld > ncvt) { + for (list = init; CONSP(list); list = CDR(list)) { + Atom_id id = ATOMID(CAR(list)); + + for (object = CDR(definition); CONSP(object); + object = CDR(object)) { + field = CAR(object); + if (CONSP(field)) + field = CAR(field); + if (ATOMID(field) == id) + break; + } + if (!CONSP(object)) + LispDestroy("%s: %s is not a field for %s", + ATOMID(struc), STROBJ(CAR(list)), + ATOMID(CAR(definition))); + list = CDR(list); + } + } + + lisp__data.protect.length = length; + + return (STRUCT(fields, definition)); +} + +static LispObj * +LispStructAccessOrStore(LispBuiltin *builtin, int store) +/* + lisp::struct-access atom struct + lisp::struct-store atom struct value + */ +{ + long offset; + LispAtom *atom; + LispObj *definition, *list; + + LispObj *name, *struc, *value = NIL; + + if (store) + value = ARGUMENT(2); + struc = ARGUMENT(1); + name = ARGUMENT(0); + + if (!POINTERP(name) || + !(XSYMBOLP(name) || XFUNCTIONP(name)) || + (atom = name->data.atom)->a_defstruct == 0 || + (offset = atom->property->structure.function) < 0) { + LispDestroy("%s: invalid argument %s", + STRFUN(builtin), STROBJ(name)); + /*NOTREACHED*/ + offset = 0; + atom = NULL; + } + definition = atom->property->structure.definition; + + /* check if the object is of the required type */ + if (!STRUCTP(struc) || struc->data.struc.def != definition) + LispDestroy("%s: %s is not a %s", + ATOMID(name), STROBJ(struc), ATOMID(CAR(definition))); + + for (list = struc->data.struc.fields; offset; list = CDR(list), offset--) + ; + + return (store ? RPLACA(list, value) : CAR(list)); +} + +LispObj * +Lisp_XeditStructAccess(LispBuiltin *builtin) +/* + lisp::struct-access atom struct + */ +{ + return (LispStructAccessOrStore(builtin, 0)); +} + +LispObj * +Lisp_XeditStructStore(LispBuiltin *builtin) +/* + lisp::struct-store atom struct value + */ +{ + return (LispStructAccessOrStore(builtin, 1)); +} + +LispObj * +Lisp_XeditStructType(LispBuiltin *builtin) +/* + lisp::struct-type atom struct + */ +{ + LispAtom *atom = NULL; + + LispObj *definition, *struc, *name; + + struc = ARGUMENT(1); + name = ARGUMENT(0); + + if (!POINTERP(name) || + !(XSYMBOLP(name) || XFUNCTIONP(name)) || + (atom = name->data.atom)->a_defstruct == 0 || + (atom->property->structure.function != STRUCT_CHECK)) + LispDestroy("%s: invalid argument %s", + STRFUN(builtin), STROBJ(name)); + definition = atom->property->structure.definition; + + /* check if the object is of the required type */ + if (STRUCTP(struc) && struc->data.struc.def == definition) + return (T); + + return (NIL); +} diff --git a/lisp/struct.h b/lisp/struct.h new file mode 100644 index 0000000..7559a02 --- /dev/null +++ b/lisp/struct.h @@ -0,0 +1,53 @@ +/* + * 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/struct.h,v 1.6 2002/11/10 16:29:07 paulo Exp $ */ + +#ifndef Lisp_struct_h +#define Lisp_struct_h + +#include "private.h" + +/* + * Defines + */ +#define XSTRUCTP(object) ((object)->type == LispStruct_t) +#define STRUCTP(object) (POINTERP(object) && XSTRUCTP(object)) +#define STRUCT(fields, def) LispNewStruct(fields, def) + +/* + * Prototypes + */ +LispObj *Lisp_Defstruct(LispBuiltin*); +LispObj *Lisp_XeditMakeStruct(LispBuiltin*); +LispObj *Lisp_XeditStructAccess(LispBuiltin*); +LispObj *Lisp_XeditStructStore(LispBuiltin*); +LispObj *Lisp_XeditStructType(LispBuiltin*); + +#endif /* Lisp_struct_h */ diff --git a/lisp/test/hello.lsp b/lisp/test/hello.lsp new file mode 100644 index 0000000..5446919 --- /dev/null +++ b/lisp/test/hello.lsp @@ -0,0 +1,72 @@ +;; +;; 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/test/hello.lsp,v 1.3 2002/11/08 08:01:01 paulo Exp $ +;; +(require "xaw") +(require "xt") + +(defun quit-callback (widget user call) (quit)) + +(defun fix-shell-size (shell) + (let ((size (xt-get-values shell '("width" "height")))) + (xt-set-values shell + (list (cons "minWidth" (cdar size)) + (cons "maxWidth" (cdar size)) + (cons "minHeight" (cdadr size)) + (cons "maxHeight" (cdadr size))) + ) + ) +) + +(setq toplevel + (xt-app-initialize 'appcontext "Hello" + '(("title" . "Hello World!")))) + +(setq form + (xt-create-managed-widget "form" form-widget-class toplevel + '(("background" . "gray85") + ("displayList" . "foreground rgb:7/9/7;lines 1,-1,-1,-1,-1,1;foreground gray90;lines -1,0,0,0,0,-1") + ))) + +(setq button + (xt-create-managed-widget "button" command-widget-class form + '(("label" . "Goodbye world!") + ("tip" . "This sample uses some customizations") + ("foreground" . "gray10") + ("background" . "gray80") + ("displayList" . "foreground rgb:7/9/7;lines 1,-1,-1,-1,-1,1;foreground gray90;lines -1,0,0,0,0,-1") + ))) +(xt-add-callback button "callback" 'quit-callback) + +(xt-realize-widget toplevel) + +(fix-shell-size toplevel) + +(xt-app-main-loop appcontext) diff --git a/lisp/test/list.lsp b/lisp/test/list.lsp new file mode 100644 index 0000000..23f4496 --- /dev/null +++ b/lisp/test/list.lsp @@ -0,0 +1,1895 @@ +;; +;; Copyright (c) 2002 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/test/list.lsp,v 1.6 2002/12/06 03:25:29 paulo Exp $ +;; + +;; basic lisp function tests + +;; Most of the tests are just the examples from the +;; +;; Common Lisp HyperSpec (TM) +;; Copyright 1996-2001, Xanalys Inc. All rights reserved. +;; +;; Some tests are hand crafted, to test how the interpreter treats +;; uncommon arguments or special conditions + + +#| + MAJOR PROBLEMS: + + o NIL and T should be always treated as symbols, actually it is + legal to say (defun nil (...) ...) + o There aren't true uninterned symbols, there are only symbols that + did not yet establish the home package, but once one is created, an + interned symbol is always returned. +|# + +(defun compare-test (test expect function arguments + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value) + (or (funcall test result expect) + (format t "(~S~{ ~S~}) => should be ~S not ~S~%" + function arguments expect result + ) + ) + ) +) + +(defun compare-eval (test expect form + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: ~S => ~S~%" form error-value) + (or (funcall test result expect) + (format t "~S => should be ~S not ~S~%" + form expect result + ) + ) + ) +) + +(defun error-test (function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + (or error + (format t "ERROR: no error for (~S~{ ~S~}), result was ~S~%" + function arguments result) + ) +) + +(defun error-eval (form &aux result (error t)) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + (or error + (format t "ERROR: no error for ~S, result was ~S~%" form result) + ) +) + +(defun eq-test (expect function &rest arguments) + (compare-test #'eq expect function arguments)) + +(defun eql-test (expect function &rest arguments) + (compare-test #'eql expect function arguments)) + +(defun equal-test (expect function &rest arguments) + (compare-test #'equal expect function arguments)) + +(defun equalp-test (expect function &rest arguments) + (compare-test #'equalp expect function arguments)) + + +(defun eq-eval (expect form) + (compare-eval #'eq expect form)) + +(defun eql-eval (expect form) + (compare-eval #'eql expect form)) + +(defun equal-eval (expect form) + (compare-eval #'equal expect form)) + +(defun equalp-eval (expect form) + (compare-eval #'equalp expect form)) + +;; clisp treats strings loaded from a file as constants +(defun xseq (sequence) + #+clisp (if *load-pathname* (copy-seq sequence) sequence) + #-clisp sequence +) + +;; apply - function +(equal-test '((+ 2 3) . 4) #'apply 'cons '((+ 2 3) 4)) +(eql-test -1 #'apply #'- '(1 2)) +(eql-test 7 #'apply #'max 3 5 '(2 7 3)) +(error-test #'apply #'+ 1) +(error-test #'apply #'+ 1 2) +(error-test #'apply #'+ 1 . 2) +(error-test #'apply #'+ 1 2 3) +(error-test #'apply #'+ 1 2 . 3) +(eql-test 6 #'apply #'+ 1 2 3 ()) + +;; eq - function +(eq-eval t '(let* ((a #\a) (b a)) (eq a b))) +(eq-test t #'eq 'a 'a) +(eq-test nil #'eq 'a 'b) +(eq-eval t '(eq #1=1 #1#)) +(eq-test nil #'eq "abc" "abc") +(setq a '('x #c(1 2) #\z)) +(eq-test nil #'eq a (copy-seq a)) + +;; eql - function +(eq-test t #'eql 1 1) +(eq-test t #'eql 1.3d0 1.3d0) +(eq-test nil #'eql 1 1d0) +(eq-test t #'eql #c(1 -5) #c(1 -5)) +(eq-test t #'eql 'a 'a) +(eq-test nil #'eql :a 'a) +(eq-test t #'eql #c(5d0 0) 5d0) +(eq-test nil #'eql #c(5d0 0d0) 5d0) +(eq-test nil #'eql "abc" "abc") +(equal-eval '(1 5/6 #p"test" #\#) '(setq a '(1 5/6 #p"test" #\#))) +(eq-test nil #'eql a (copy-seq a)) + +(setf + hash0 (make-hash-table) + hash1 (make-hash-table) + (gethash 1 hash0) 2 + (gethash 1 hash1) 2 + (gethash :foo hash0) :bar + (gethash :foo hash1) :bar +) +(defstruct test a b c) +(setq + struc0 (make-test :a 1 :b 2 :c #\c) + struc1 (make-test :a 1 :b 2 :c #\c) +) + +;; equal - function +(eq-test t #'equal "abc" "abc") +(eq-test t #'equal 1 1) +(eq-test t #'equal #c(1 2) #c(1 2)) +(eq-test nil #'equal #c(1 2) #c(1 2d0)) +(eq-test t #'equal #\A #\A) +(eq-test nil #'equal #\A #\a) +(eq-test nil #'equal "abc" "Abc") +(equal-eval '(1 2 3/5 #\a) '(setq a '(1 2 3/5 #\a))) +(eq-test t #'equal a (copy-seq a)) +(eq-test nil #'equal hash0 hash1) +(eq-test nil #'equal struc0 struc1) +(eq-test nil #'equal #(1 2 3 4) #(1 2 3 4)) + +;; equalp - function +(eq-test t #'equalp hash0 hash1) +(setf + (gethash 2 hash0) "FoObAr" + (gethash 2 hash1) "fOoBaR" +) +(eq-test t #'equalp hash0 hash1) +(setf + (gethash 3 hash0) 3 + (gethash 3d0 hash1) 3 +) +(eq-test nil #'equalp hash0 hash1) +(eq-test t #'equalp struc0 struc1) +(setf + (test-a struc0) #\a + (test-a struc1) #\A +) +(eq-test t #'equalp struc0 struc1) +(setf + (test-b struc0) 'test + (test-b struc1) :test +) +(eq-test nil #'equalp struc0 struc1) +(eq-test t #'equalp #c(1/2 1d0) #c(0.5d0 1)) +(eq-test t #'equalp 1 1d0) +(eq-test t #'equalp #(1 2 3 4) #(1 2 3 4)) +(eq-test t #'equalp #(1 #\a 3 4d0) #(1 #\A 3 4)) + +;; acons - function +(equal-test '((1 . "one")) #'acons 1 "one" nil) +(equal-test '((2 . "two") (1 . "one")) #'acons 2 "two" '((1 . "one"))) + +;; adjoin - function +(equal-test '(nil) #'adjoin nil nil) +(equal-test '(a) #'adjoin 'a nil) +(equal-test '(1 2 3) #'adjoin 1 '(1 2 3)) +(equal-test '(1 2 3) #'adjoin 2 '(1 2 3)) +(equal-test '((1) (1) (2) (3)) #'adjoin '(1) '((1) (2) (3))) +(equal-test '((1) (2) (3)) #'adjoin '(1) '((1) (2) (3)) :key #'car) +(error-test #'adjoin nil 1) + +;; alpha-char-p - function +(eq-test t #'alpha-char-p #\a) +(eq-test nil #'alpha-char-p #\5) +(error-test #'alpha-char-p 'a) + +;; alphanumericp - function +(eq-test t #'alphanumericp #\Z) +(eq-test t #'alphanumericp #\8) +(eq-test nil #'alphanumericp #\#) + +;; and - macro +(eql-eval 1 '(setq temp1 1 temp2 1 temp3 1)) +(eql-eval 2 '(and (incf temp1) (incf temp2) (incf temp3))) +(eq-eval t '(and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3))) +(eql-eval 1 '(decf temp3)) +(eq-eval nil '(and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3))) +(eq-eval t '(and (eql temp1 temp2) (eql temp2 temp3))) +(eq-eval t '(and)) +(equal-eval '(1 2 3) '(multiple-value-list (and (values 'a) (values 1 2 3)))) +(equal-eval nil '(and (values) t)) + +;; append - function +(equal-test '(a b c d e f g) #'append '(a b c) '(d e f) '() '(g)) +(equal-test '(a b c . d) #'append '(a b c) 'd) +(eq-test nil #'append) +(eql-test 'a #'append nil 'a) +(error-test #'append 1 2) + +;; assoc - function +(equal-test '(1 . "one") #'assoc 1 '((2 . "two") (1 . "one"))) +(equal-test '(2 . "two") #'assoc 2 '((1 . "one") (2 . "two"))) +(eq-test nil #'assoc 1 nil) +(equal-test '(2 . "two") #'assoc-if #'evenp '((1 . "one") (2 . "two"))) +(equal-test '(3 . "three") #'assoc-if-not #'(lambda(x) (< x 3)) + '((1 . "one") (2 . "two") (3 . "three"))) +(equal-test '("two" . 2) #'assoc #\o '(("one" . 1) ("two" . 2) ("three" . 3)) + :key #'(lambda (x) (char x 2))) +(equal-test '(a . b) #'assoc 'a '((x . a) (y . b) (a . b) (a . c))) + +;; atom - function +(eq-test t #'atom 1) +(eq-test t #'atom '()) +(eq-test nil #'atom '(1)) +(eq-test t #'atom 'a) + +;; block - special operator +(eq-eval nil '(block empty)) +(eql-eval 2 '(let ((x 1)) + (block stop (setq x 2) (return-from stop) (setq x 3)) x)) +(eql-eval 2 '(block twin (block twin (return-from twin 1)) 2)) + +;; both-case-p - function +(eq-test t #'both-case-p #\a) +(eq-test nil #'both-case-p #\1) + +;; boundp - function +(eql-eval 1 '(setq x 1)) +(eq-test t #'boundp 'x) +(makunbound 'x) +(eq-test nil #'boundp 'x) +(eq-eval nil '(let ((x 1)) (boundp 'x))) +(error-test #'boundp 1) + +;; butlast, nbutlast - function +(setq x '(1 2 3 4 5 6 7 8 9)) +(equal-test '(1 2 3 4 5 6 7 8) #'butlast x) +(equal-eval '(1 2 3 4 5 6 7 8 9) 'x) +(eq-eval nil '(nbutlast x 9)) +(equal-test '(1) #'nbutlast x 8) +(equal-eval '(1) 'x) +(eq-test nil #'butlast nil) +(eq-test nil #'nbutlast '()) +(error-test #'butlast 1 2) +(error-test #'butlast -1 '(1 2)) + +;; car, cdr, caar ... - function +(eql-test 1 #'car '(1 2)) +(eql-test 2 #'cdr '(1 . 2)) +(eql-test 1 #'caar '((1 2))) +(eql-test 2 #'cadr '(1 2)) +(eql-test 2 #'cdar '((1 . 2))) +(eql-test 3 #'cddr '(1 2 . 3)) +(eql-test 1 #'caaar '(((1 2)))) +(eql-test 2 #'caadr '(1 (2 3))) +(eql-test 2 #'cadar '((1 2) 2 3)) +(eql-test 3 #'caddr '(1 2 3 4)) +(eql-test 2 #'cdaar '(((1 . 2)) 3)) +(eql-test 3 #'cdadr '(1 (2 . 3) 4)) +(eql-test 3 #'cddar '((1 2 . 3) 3)) +(eql-test 4 #'cdddr '(1 2 3 . 4)) +(eql-test 1 #'caaaar '((((1 2))))) +(eql-test 2 #'caaadr '(1 ((2)))) +(eql-test 2 #'caadar '((1 (2)) 3)) +(eql-test 3 #'caaddr '(1 2 (3 4))) +(eql-test 2 #'cadaar '(((1 2)) 3)) +(eql-test 3 #'cadadr '(1 (2 3) 4)) +(eql-test 3 #'caddar '((1 2 3) 4)) +(eql-test 4 #'cadddr '(1 2 3 4 5)) +(eql-test 2 #'cdaaar '((((1 . 2))) 3)) +(eql-test 3 #'cdaadr '(1 ((2 . 3)) 4)) +(eql-test 3 #'cdadar '((1 (2 . 3)) 4)) +(eql-test 4 #'cdaddr '(1 2 (3 . 4) 5)) +(eql-test 3 #'cddaar '(((1 2 . 3)) 4)) +(eql-test 4 #'cddadr '(1 (2 3 . 4) 5)) +(eql-test 4 #'cdddar '((1 2 3 . 4) 5)) +(eql-test 5 #'cddddr '(1 2 3 4 . 5)) + +;; first ... tenth, rest - function +(eql-test 2 #'rest '(1 . 2)) +(eql-test 1 #'first '(1 2)) +(eql-test 2 #'second '(1 2 3)) +(eql-test 2 #'second '(1 2 3)) +(eql-test 3 #'third '(1 2 3 4)) +(eql-test 4 #'fourth '(1 2 3 4 5)) +(eql-test 5 #'fifth '(1 2 3 4 5 6)) +(eql-test 6 #'sixth '(1 2 3 4 5 6 7)) +(eql-test 7 #'seventh '(1 2 3 4 5 6 7 8)) +(eql-test 8 #'eighth '(1 2 3 4 5 6 7 8 9)) +(eql-test 9 #'ninth '(1 2 3 4 5 6 7 8 9 10)) +(eql-test 10 #'tenth '(1 2 3 4 5 6 7 8 9 10 11)) +(error-test #'car 1) +(error-test #'car #c(1 2)) +(error-test #'car #(1 2)) + +;; case - macro +(eql-eval t '(let ((a 1)) (case a ((4 5 6) nil) ((3 2 1) t) (otherwise :error)))) +(eql-eval t '(let ((a 1)) (case a ((3 2) nil) (1 t) (t :error)))) +(error-eval '(let ((a 1)) (case a (2 :error) (t nil) (otherwise t)))) +(error-eval '(let ((a 1)) (case a (2 :error) (otherwise t) (t nil)))) + +;; catch - special operator +(eql-eval 3 '(catch 'dummy-tag 1 2 (throw 'dummy-tag 3) 4)) +(eql-eval 4 '(catch 'dummy-tag 1 2 3 4)) +(eq-eval 'throw-back '(defun throw-back (tag) (throw tag t))) +(eq-eval t '(catch 'dummy-tag (throw-back 'dummy-tag) 2)) + +;; char - function +(eql-test #\a #'char "abc" 0) +(eql-test #\b #'char "abc" 1) +(error-test #'char "abc" 3) + +;; char-* - function +(eq-test nil #'alpha-char-p #\3) +(eq-test t #'alpha-char-p #\y) +(eql-test #\a #'char-downcase #\a) +(eql-test #\a #'char-downcase #\a) +(eql-test #\1 #'char-downcase #\1) +(error-test #'char-downcase 1) +(eql-test #\A #'char-upcase #\a) +(eql-test #\A #'char-upcase #\A) +(eql-test #\1 #'char-upcase #\1) +(error-test #'char-upcase 1) +(eq-test t #'lower-case-p #\a) +(eq-test nil #'lower-case-p #\A) +(eq-test t #'upper-case-p #\W) +(eq-test nil #'upper-case-p #\w) +(eq-test t #'both-case-p #\x) +(eq-test nil #'both-case-p #\%) +(eq-test t #'char= #\d #\d) +(eq-test t #'char-equal #\d #\d) +(eq-test nil #'char= #\A #\a) +(eq-test t #'char-equal #\A #\a) +(eq-test nil #'char= #\d #\x) +(eq-test nil #'char-equal #\d #\x) +(eq-test nil #'char= #\d #\D) +(eq-test t #'char-equal #\d #\D) +(eq-test nil #'char/= #\d #\d) +(eq-test nil #'char-not-equal #\d #\d) +(eq-test nil #'char/= #\d #\d) +(eq-test nil #'char-not-equal #\d #\d) +(eq-test t #'char/= #\d #\x) +(eq-test t #'char-not-equal #\d #\x) +(eq-test t #'char/= #\d #\D) +(eq-test nil #'char-not-equal #\d #\D) +(eq-test t #'char= #\d #\d #\d #\d) +(eq-test t #'char-equal #\d #\d #\d #\d) +(eq-test nil #'char= #\d #\D #\d #\d) +(eq-test t #'char-equal #\d #\D #\d #\d) +(eq-test nil #'char/= #\d #\d #\d #\d) +(eq-test nil #'char-not-equal #\d #\d #\d #\d) +(eq-test nil #'char/= #\d #\d #\D #\d) +(eq-test nil #'char-not-equal #\d #\d #\D #\d) +(eq-test nil #'char= #\d #\d #\x #\d) +(eq-test nil #'char-equal #\d #\d #\x #\d) +(eq-test nil #'char/= #\d #\d #\x #\d) +(eq-test nil #'char-not-equal #\d #\d #\x #\d) +(eq-test nil #'char= #\d #\y #\x #\c) +(eq-test nil #'char-equal #\d #\y #\x #\c) +(eq-test t #'char/= #\d #\y #\x #\c) +(eq-test t #'char-not-equal #\d #\y #\x #\c) +(eq-test nil #'char= #\d #\c #\d) +(eq-test nil #'char-equal #\d #\c #\d) +(eq-test nil #'char/= #\d #\c #\d) +(eq-test nil #'char-not-equal #\d #\c #\d) +(eq-test t #'char< #\d #\x) +(eq-test t #'char-lessp #\d #\x) +(eq-test t #'char-lessp #\d #\X) +(eq-test t #'char-lessp #\D #\x) +(eq-test t #'char-lessp #\D #\X) +(eq-test t #'char<= #\d #\x) +(eq-test t #'char-not-greaterp #\d #\x) +(eq-test t #'char-not-greaterp #\d #\X) +(eq-test t #'char-not-greaterp #\D #\x) +(eq-test t #'char-not-greaterp #\D #\X) +(eq-test nil #'char< #\d #\d) +(eq-test nil #'char-lessp #\d #\d) +(eq-test nil #'char-lessp #\d #\D) +(eq-test nil #'char-lessp #\D #\d) +(eq-test nil #'char-lessp #\D #\D) +(eq-test t #'char<= #\d #\d) +(eq-test t #'char-not-greaterp #\d #\d) +(eq-test t #'char-not-greaterp #\d #\D) +(eq-test t #'char-not-greaterp #\D #\d) +(eq-test t #'char-not-greaterp #\D #\D) +(eq-test t #'char< #\a #\e #\y #\z) +(eq-test t #'char-lessp #\a #\e #\y #\z) +(eq-test t #'char-lessp #\a #\e #\y #\Z) +(eq-test t #'char-lessp #\a #\E #\y #\z) +(eq-test t #'char-lessp #\A #\e #\y #\Z) +(eq-test t #'char<= #\a #\e #\y #\z) +(eq-test t #'char-not-greaterp #\a #\e #\y #\z) +(eq-test t #'char-not-greaterp #\a #\e #\y #\Z) +(eq-test t #'char-not-greaterp #\A #\e #\y #\z) +(eq-test nil #'char< #\a #\e #\e #\y) +(eq-test nil #'char-lessp #\a #\e #\e #\y) +(eq-test nil #'char-lessp #\a #\e #\E #\y) +(eq-test nil #'char-lessp #\A #\e #\E #\y) +(eq-test t #'char<= #\a #\e #\e #\y) +(eq-test t #'char-not-greaterp #\a #\e #\e #\y) +(eq-test t #'char-not-greaterp #\a #\E #\e #\y) +(eq-test t #'char> #\e #\d) +(eq-test t #'char-greaterp #\e #\d) +(eq-test t #'char-greaterp #\e #\D) +(eq-test t #'char-greaterp #\E #\d) +(eq-test t #'char-greaterp #\E #\D) +(eq-test t #'char>= #\e #\d) +(eq-test t #'char-not-lessp #\e #\d) +(eq-test t #'char-not-lessp #\e #\D) +(eq-test t #'char-not-lessp #\E #\d) +(eq-test t #'char-not-lessp #\E #\D) +(eq-test t #'char> #\d #\c #\b #\a) +(eq-test t #'char-greaterp #\d #\c #\b #\a) +(eq-test t #'char-greaterp #\d #\c #\b #\A) +(eq-test t #'char-greaterp #\d #\c #\B #\a) +(eq-test t #'char-greaterp #\d #\C #\b #\a) +(eq-test t #'char-greaterp #\D #\C #\b #\a) +(eq-test t #'char>= #\d #\c #\b #\a) +(eq-test t #'char-not-lessp #\d #\c #\b #\a) +(eq-test t #'char-not-lessp #\d #\c #\b #\A) +(eq-test t #'char-not-lessp #\D #\c #\b #\a) +(eq-test t #'char-not-lessp #\d #\C #\B #\a) +(eq-test nil #'char> #\d #\d #\c #\a) +(eq-test nil #'char-greaterp #\d #\d #\c #\a) +(eq-test nil #'char-greaterp #\d #\d #\c #\A) +(eq-test nil #'char-greaterp #\d #\D #\c #\a) +(eq-test nil #'char-greaterp #\d #\D #\C #\a) +(eq-test t #'char>= #\d #\d #\c #\a) +(eq-test t #'char-not-lessp #\d #\d #\c #\a) +(eq-test t #'char-not-lessp #\d #\D #\c #\a) +(eq-test t #'char-not-lessp #\D #\d #\c #\a) +(eq-test t #'char-not-lessp #\D #\D #\c #\A) +(eq-test nil #'char> #\e #\d #\b #\c #\a) +(eq-test nil #'char-greaterp #\e #\d #\b #\c #\a) +(eq-test nil #'char-greaterp #\E #\d #\b #\c #\a) +(eq-test nil #'char-greaterp #\e #\D #\b #\c #\a) +(eq-test nil #'char-greaterp #\E #\d #\B #\c #\A) +(eq-test nil #'char>= #\e #\d #\b #\c #\a) +(eq-test nil #'char-not-lessp #\e #\d #\b #\c #\a) +(eq-test nil #'char-not-lessp #\e #\d #\b #\c #\A) +(eq-test nil #'char-not-lessp #\E #\d #\B #\c #\a) + +;; char-code - function +;; XXX assumes ASCII +(eql-test 49 #'char-code #\1) +(eql-test 90 #'char-code #\Z) +(eql-test 127 #'char-code #\Delete) +(eql-test 27 #'char-code #\Escape) +(eql-test 13 #'char-code #\Return) +(eql-test 0 #'char-code #\Null) +(eql-test 10 #'char-code #\Newline) +(error-test #'char-code 65) + +;; character - function +(eql-test #\a #'character #\a) +(eql-test #\a #'character "a") +(eql-test #\A #'character 'a) + +;; XXX assumes ASCII, and should be allowed to fail? +(eql-test #\A #'character 65) + +(error-test #'character 1/2) +(error-test #'character "abc") +(error-test #'character :test) +(eq-test #\T #'character t) +(error-test #'character nil) + +;; characterp - function +(eq-test t #'characterp #\a) +(eq-test nil #'characterp 1) +(eq-test nil #'characterp 1/2) +(eq-test nil #'characterp 'a) +(eq-test nil #'characterp '`a) + + + + +;; TODO coerce + + + + +;; cond - macro +(eql-eval 2 '(let ((a 1)) (cond ((= a 2) 1) ((= a 1) 2) ((= a 0) 1) (t nil)))) +(eql-eval nil '(let ((a 1)) (cond ((= a 2) 1) (t nil) ((= a 1) 2) ((= a 0) 1)))) + +;; consp - function (predicate) +(eq-test t #'consp '(1 2)) +(eq-test t #'consp '(1 . 2)) +(eq-test nil #'consp nil) +(eq-test nil #'consp 1) + +;; constantp - function (predicate) +(eq-test t #'constantp 1) +(eq-test t #'constantp #\x) +(eq-test t #'constantp :test) +(eq-test nil #'constantp 'test) +(eq-test t #'constantp ''1) +(eq-test t #'constantp '(quote 1)) +(eq-test t #'constantp "string") +(eq-test t #'constantp #c(1 2)) +(eq-test t #'constantp #(1 2)) +(eq-test nil #'constantp #p"test") +(eq-test nil #'constantp '(1 2)) +(eq-test nil #'constantp (make-hash-table)) +(eq-test nil #'constantp *package*) +(eq-test nil #'constantp *standard-input*) + +;; copy-list, copy-alist and copy-tree - function +(equal-test '(1 2) #'copy-list '(1 2)) +(equal-test '(1 . 2) #'copy-list '(1 . 2)) +(eq-test nil #'copy-list nil) +(error-test #'copy-list 1) +(equal-eval '(1 (2 3)) '(setq x '(1 (2 3)))) +(equal-eval x '(setq y (copy-list x))) +(equal-test '("one" (2 3)) #'rplaca x "one") +(eql-test 1 #'car y) +(equal-test '("two" 3) #'rplaca (cadr x) "two") +(eq-test (caadr x) #'caadr y) +(equal-eval '(1 (2 3) 4) '(setq a '(1 (2 3) 4) b (copy-list a))) +(eq-eval t '(eq (cadr a) (cadr b))) +(eq-eval t '(eq (car a) (car b))) +(setq a '(1 (2 3) 4) b (copy-alist a)) +(eq-eval nil '(eq (cadr a) (cadr b))) +(eq-eval t '(eq (car a) (car b))) +(eq-test nil #'copy-alist nil) +(eq-test nil #'copy-list nil) +(error-test #'copy-list 1) +(setq a '(1 (2 (3)))) +(setq as-list (copy-list a)) +(setq as-alist (copy-alist a)) +(setq as-tree (copy-tree a)) +(eq-eval t '(eq (cadadr a) (cadadr as-list))) +(eq-eval t '(eq (cadadr a) (cadadr as-alist))) +(eq-eval nil '(eq (cadadr a) (cadadr as-tree))) + +;; decf - macro +(setq n 2) +(eql-eval 1 '(decf n)) +(eql-eval 1 'n) +(setq n -2147483648) +(eql-eval -2147483649 '(decf n)) +(eql-eval -2147483649 'n) +(setq n 0) +(eql-eval -0.5d0 '(decf n 0.5d0)) +(eql-eval -0.5d0 'n) +(setq n 1) +(eql-eval 1/2 '(decf n 1/2)) +(eql-eval 1/2 'n) + +;; delete and remove - function +(setq a '(1 3 4 5 9) b a) +(equal-test '(1 3 5 9) #'remove 4 a) +(eq-eval t '(eq a b)) +(setq a (delete 4 a)) +(equal-eval '(1 3 5 9) 'a) +(setq a '(1 2 4 1 3 4 5) b a) +(equal-test '(1 2 1 3 5) #'remove 4 a) +(eq-eval t '(eq a b)) +(equal-test '(1 2 1 3 4 5) #'remove 4 a :count 1) +(eq-eval t '(eq a b)) +(equal-test '(1 2 4 1 3 5) #'remove 4 a :count 1 :from-end t) +(eq-eval t '(eq a b)) +(equal-test '(4 3 4 5) #'remove 3 a :test #'>) +(eq-eval t '(eq a b)) +(setq a (delete 4 '(1 2 4 1 3 4 5))) +(equal-eval '(1 2 1 3 5) 'a) +(setq a (delete 4 '(1 2 4 1 3 4 5) :count 1)) +(equal-eval '(1 2 1 3 4 5) 'a) +(setq a (delete 4 '(1 2 4 1 3 4 5) :count 1 :from-end t)) +(equal-eval '(1 2 4 1 3 5) 'a) +(equal-test "abc" #'delete-if #'digit-char-p "a1b2c3") +(equal-test "123" #'delete-if-not #'digit-char-p "a1b2c3") +(eq-test nil #'delete 1 nil) +(eq-test nil #'remove 1 nil) +(setq a '(1 2 3 4 :test 5 6 7 8) b a) +(equal-test '(1 2 :test 7 8) #'remove-if #'numberp a :start 2 :end 7) +(eq-eval t '(eq a b)) +(setq a (delete-if #'numberp a :start 2 :end 7)) +(equal-eval '(1 2 :test 7 8) 'a) + +;; digit-char - function +(eql-test #\0 #'digit-char 0) +(eql-test #\A #'digit-char 10 11) +(eq-test nil #'digit-char 10 10) +(eql-test 35 #'digit-char-p #\z 36) +(error-test #'digit-char #\a) +(error-test #'digit-char-p 1/2) + + + +;; TODO directory (known to have problems with parameters like "../*/../*/") + + + +;; elt - function +(eql-test #\a #'elt "xabc" 1) +(eql-test 3 #'elt '(0 1 2 3) 3) +(error-test #'elt nil 0) + +;; endp - function +(eql-test t #'endp nil) +(error-test #'endp t) +(eql-test nil #'endp '(1 . 2)) +(error-test #'endp #(1 2)) + +;; every - function +(eql-test t #'every 'not-used ()) +(eql-test t #'every #'characterp "abc") +(eql-test nil #'every #'< '(1 2 3) '(4 5 6) #(7 8 -1)) +(eql-test t #'every #'< '(1 2 3) '(4 5 6) #(7 8)) + +;; fboundp and fmakunbound - function +(eq-test t #'fboundp 'car) +(eq-eval 'test '(defun test ())) +(eq-test t #'fboundp 'test) +(eq-test 'test #'fmakunbound 'test) +(eq-test nil #'fboundp 'test) +(eq-eval 'test '(defmacro test (x) x)) +(eq-test t #'fboundp 'test) +(eq-test 'test #'fmakunbound 'test) + +;; fill - function +(setq x (list 1 2 3 4)) +(equal-test '((4 4 4 4) (4 4 4 4) (4 4 4 4) (4 4 4 4)) #'fill x '(4 4 4 4)) +(eq-eval t '(eq (car x) (cadr x))) +(equalp-test '#(a z z d e) #'fill '#(a b c d e) 'z :start 1 :end 3) +(equal-test "012ee" #'fill (xseq "01234") #\e :start 3) +(error-test #'fill 1 #\a) + +;; find - function +(eql-test #\Space #'find #\d "here are some letters that can be looked at" :test #'char>) +(eql-test 3 #'find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t) +(eq-test nil #'find-if-not #'complexp '#(3.5 2 #C(1.0 0.0) #C(0.0 1.0)) :start 2) +(eq-test nil #'find 1 "abc") +(error-test #'find 1 #c(1 2)) + +;; find-symbol - function +(equal-eval '(nil nil) + '(multiple-value-list (find-symbol "NEVER-BEFORE-USED"))) +(equal-eval '(nil nil) + '(multiple-value-list (find-symbol "NEVER-BEFORE-USED"))) +(setq test (multiple-value-list (intern "NEVER-BEFORE-USED"))) +(equal-eval test '(read-from-string "(never-before-used nil)")) +(equal-eval '(never-before-used :internal) + '(multiple-value-list (intern "NEVER-BEFORE-USED"))) +(equal-eval '(never-before-used :internal) + '(multiple-value-list (find-symbol "NEVER-BEFORE-USED"))) +(equal-eval '(nil nil) + '(multiple-value-list (find-symbol "never-before-used"))) +(equal-eval '(car :inherited) + '(multiple-value-list (find-symbol "CAR" 'common-lisp-user))) +(equal-eval '(car :external) + '(multiple-value-list (find-symbol "CAR" 'common-lisp))) +;; XXX these will generate wrong results, NIL is not really a symbol +;; currently in the interpreter +(equal-eval '(nil :inherited) + '(multiple-value-list (find-symbol "NIL" 'common-lisp-user))) +(equal-eval '(nil :external) + '(multiple-value-list (find-symbol "NIL" 'common-lisp))) +(setq test (multiple-value-list + (find-symbol "NIL" (prog1 (make-package "JUST-TESTING" :use '()) + (intern "NIL" "JUST-TESTING"))))) +(equal-eval (read-from-string "(just-testing::nil :internal)") 'test) +(eq-eval t '(export 'just-testing::nil 'just-testing)) +(equal-eval '(just-testing:nil :external) + '(multiple-value-list (find-symbol "NIL" 'just-testing))) + +#+xedit (equal-eval '(nil nil) + '(multiple-value-list (find-symbol "NIL" "KEYWORD"))) +#| +;; optional result of previous form: +(equal-eval '(:nil :external) + '(multiple-value-list (find-symbol "NIL" "KEYWORD"))) +|# + + + +;; funcall - function +(eql-test 6 #'funcall #'+ 1 2 3) +(eql-test 1 #'funcall #'car '(1 2 3)) +(equal-test '(1 2 3) #'funcall #'list 1 2 3) + + + +;; TODO properly implement ``function'' + + + +;; functionp - function (predicate) +(eq-test nil #'functionp 'append) +(eq-test t #'functionp #'append) +(eq-test nil #'functionp '(lambda (x) (* x x))) +(eq-test t #'functionp #'(lambda (x) (* x x))) +(eq-test t #'functionp (symbol-function 'append)) +(eq-test nil #'functionp 1) +(eq-test nil #'functionp nil) + +;; gensym - function +(setq sym1 (gensym)) +(eq-test nil #'symbol-package sym1) +(setq sym1 (gensym 100)) +(setq sym2 (gensym 100)) +(eq-test nil #'eq sym1 sym2) +(eq-test nil #'equalp (gensym) (gensym)) + +;; get - accessor +(defun make-person (first-name last-name) + (let ((person (gensym "PERSON"))) + (setf (get person 'first-name) first-name) + (setf (get person 'last-name) last-name) + person)) +(eq-eval '*john* '(defvar *john* (make-person "John" "Dow"))) +(eq-eval '*sally* '(defvar *sally* (make-person "Sally" "Jones"))) +(equal-eval "John" '(get *john* 'first-name)) +(equal-eval "Jones" '(get *sally* 'last-name)) +(defun marry (man woman married-name) + (setf (get man 'wife) woman) + (setf (get woman 'husband) man) + (setf (get man 'last-name) married-name) + (setf (get woman 'last-name) married-name) + married-name) +(equal-eval "Dow-Jones" '(marry *john* *sally* "Dow-Jones")) +(equal-eval "Dow-Jones" '(get *john* 'last-name)) +(equal-eval "Sally" '(get (get *john* 'wife) 'first-name)) +(equal-eval `(wife ,*sally* last-name "Dow-Jones" first-name "John") + '(symbol-plist *john*)) +(eq-eval 'age + '(defmacro age (person &optional (default ''thirty-something)) + `(get ,person 'age ,default))) +(eq-eval 'thirty-something '(age *john*)) +(eql-eval 20 '(age *john* 20)) +(eql-eval 25 '(setf (age *john*) 25)) +(eql-eval 25 '(age *john*)) +(eql-eval 25 '(age *john* 20)) + +;; graphic-char-p - function +(eq-test t #'graphic-char-p #\a) +(eq-test t #'graphic-char-p #\Space) +(eq-test nil #'graphic-char-p #\Newline) +(eq-test nil #'graphic-char-p #\Tab) +(eq-test nil #'graphic-char-p #\Rubout) + +;; if - special operator +(eq-eval nil '(if nil t)) +(eq-eval nil '(if t nil t)) +(eq-eval nil '(if nil t nil)) +(eq-eval nil '(if nil t (if nil (if nil t) nil))) + +;; incf - macro +(setq n 1) +(eql-eval 2 '(incf n)) +(eql-eval 2 'n) +(setq n 2147483647) +(eql-eval 2147483648 '(incf n)) +(eql-eval 2147483648 'n) +(setq n 0) +(eql-eval 0.5d0 '(incf n 0.5d0)) +(eql-eval 0.5d0 'n) +(setq n 1) +(eql-eval 3/2 '(incf n 1/2)) +(eql-eval 3/2 'n) + +;; intersection - function +(setq list1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d") + list2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D")) +(equal-test '(1 1 4 b c) #'intersection list1 list2) +(equal-test '(1 1 4 b c "B") #'intersection list1 list2 :test 'equal) +(equal-test '(1 1 4 b c "A" "B" "C" "d") + #'intersection list1 list2 :test #'equalp) +(setq list1 (nintersection list1 list2)) +(equal-eval '(1 1 4 b c) 'list1) +(setq list1 (copy-list '((1 . 2) (2 . 3) (3 . 4) (4 . 5)))) +(setq list2 (copy-list '((1 . 3) (2 . 4) (3 . 6) (4 . 8)))) +(equal-test '((2 . 3) (3 . 4)) #'nintersection list1 list2 :key #'cdr) + +;; keywordp - function (predicate) +(eq-test t #'keywordp :test) +(eq-test nil #'keywordp 'test) +(eq-test nil #'keywordp '#:test) +(eq-test nil #'keywordp 1) +(eq-test nil #'keywordp #'keywordp) +(eq-test nil #'keywordp nil) + +;; last - function +(equal-test '(3) #'last '(1 2 3)) +(equal-test '(2 . 3) #'last '(1 2 . 3)) +(eq-test nil #'last nil) +(eql-test () #'last '(1 2 3) 0) +(setq a '(1 . 2)) +(eql-test 2 #'last a 0) +(eq-test a #'last a 1) +(eq-test a #'last a 2) +(eq-test t #'last t) +(equal-test #c(1 2) #'last #c(1 2)) +(equalp-test #(1 2 3) #'last #(1 2 3)) + +;; length - function +(eql-test 3 #'length "abc") +(eql-test 0 #'length nil) +(eql-test 1 #'length '(1 . 2)) +(eql-test 2 #'length #(1 2)) +(error-test #'length #c(1 2)) +(error-test #'length t) + +;; let - special operator +(eql-eval 2 '(setq a 1 b 2)) +(eql-eval 2 '(let ((a 2)) a)) +(eql-eval 1 'a) +(eql-eval 1 '(let ((a 3) (b a)) b)) +(eql-eval 2 'b) + +;; let* - special operator +(setq a 1 b 2) +(eql-eval 2 '(let* ((a 2)) a)) +(eql-eval 1 'a) +(eql-eval 3 '(let* ((a 3) (b a)) b)) +(eql-eval 2 'b) + +;; list - function +(equal-test '(1) #'list 1) +(equal-test '(3 4 a b 4) #'list 3 4 'a (car '(b . c)) (+ 6 -2)) +(eq-test nil #'list) + +;; list-length - function +(eql-test 4 #'list-length '(a b c d)) +(eql-test 3 #'list-length '(a (b c) d)) +(eql-test 0 #'list-length '()) +(eql-test 0 #'list-length nil) +(defun circular-list (&rest elements) + (let ((cycle (copy-list elements))) + (nconc cycle cycle))) +(eq-test nil #'list-length (circular-list 'a 'b)) +(eq-test nil #'list-length (circular-list 'a)) +(eql-test 0 #'list-length (circular-list)) + +;; list* - function +(eql-test 1 #'list* 1) +(equal-test '(a b c . d) #'list* 'a 'b 'c 'd) +(error-test #'list*) +(setq a '(1 2)) +(eq-test a #'list* a) + +;; listp - function (predicate) +(eq-test t #'listp nil) +(eq-test t #'listp '(1 . 2)) +(eq-test nil #'listp t) +(eq-test nil #'listp #'listp) +(eq-test nil #'listp #(1 2)) +(eq-test nil #'listp #c(1 2)) + +;; lower-case-p - function +(eq-test t #'lower-case-p #\a) +(eq-test nil #'lower-case-p #\1) +(eq-test nil #'lower-case-p #\Newline) +(error-test #'lower-case-p 1) + + + +;; TODO make-array (will be rewritten) + + + +;; make-list - function +(equal-test '(nil nil nil) #'make-list 3) +(equal-test '((1 2) (1 2)) #'make-list 2 :initial-element '(1 2)) +(eq-test nil #'make-list 0) +(eq-test nil #'make-list 0 :initial-element 1) + +;; make-package - function +(setq pack1 (make-package "PACKAGE-1" :nicknames '("PACK-1" "PACK1"))) +(setq pack2 (make-package "PACKAGE-2" :nicknames '("PACK-2" "PACK2") :use '("PACK1"))) +(equal-test (list pack2) #'package-used-by-list pack1) +(equal-test (list pack1) #'package-use-list pack2) +(eq-test pack1 #'symbol-package 'pack1::test) +(eq-test pack2 #'symbol-package 'pack2::test) + +;; make-string - function +(equal-test "55555" #'make-string 5 :initial-element #\5) +(equal-test "" #'make-string 0) +(error-test #'make-string 10 :initial-element t) +(error-test #'make-string 10 :initial-element nil) +(error-test #'make-string 10 :initial-element 1) +(eql-test 10 #'length (make-string 10)) + +;; make-symbol - function +(setq a "TEST") +;; This will fail +(eq-test nil #'eq (make-symbol a) (make-symbol a)) +(equal-test a #'symbol-name (make-symbol a)) +(setq temp-string "temp") +(setq temp-symbol (make-symbol temp-string)) +(equal-test temp-string #'symbol-name temp-symbol) +(equal-eval '(nil nil) '(multiple-value-list (find-symbol temp-string))) + +;; makunbound - function +(eq-eval 1 '(setf (symbol-value 'a) 1)) +(eq-test t #'boundp 'a) +(eql-eval 1 'a) +(eq-test 'a #'makunbound 'a) +(eq-test nil #'boundp 'a) +(error-test #'makunbound 1) + +;; mapc - function +(setq dummy nil) +(equal-test '(1 2 3 4) + #'mapc #'(lambda (&rest x) (setq dummy (append dummy x))) + '(1 2 3 4) + '(a b c d e) + '(x y z)) +(equal-eval '(1 a x 2 b y 3 c z) 'dummy) + +;; mapcan - function +(equal-test '(d 4 e 5) + #'mapcan #'(lambda (x y) (if (null x) nil (list x y))) + '(nil nil nil d e) + '(1 2 3 4 5 6)) +(equal-test '(1 3 4 5) + #'mapcan #'(lambda (x) (and (numberp x) (list x))) + '(a 1 b c 3 4 d 5)) + +;; mapcar - function +(equal-test '(1 2 3) #'mapcar #'car '((1 a) (2 b) (3 c))) +(equal-test '(3 4 2 5 6) #'mapcar #'abs '(3 -4 2 -5 -6)) +(equal-test '((a . 1) (b . 2) (c . 3)) #'mapcar #'cons '(a b c) '(1 2 3)) +(equal-test '((1 3 5)) #'mapcar #'list* '(1 2) '(3 4) '((5))) +(equal-test '((1 3 5) (2 4 6)) #'mapcar #'list* '(1 2) '(3 4) '((5) (6))) + +;; mapcon - function +(equal-test '(1 a 2 b (3) c) #'mapcon #'car '((1 a) (2 b) ((3) c))) +(equal-test '((1 2 3 4) (2 3 4) (3 4) (4)) #'mapcon #'list '(1 2 3 4)) + +;; mapl - function +(setq dummy nil) +(equal-test '(1 2 3 4) #'mapl #'(lambda (x) (push x dummy)) '(1 2 3 4)) +(equal-eval '((4) (3 4) (2 3 4) (1 2 3 4)) 'dummy) + +;; maplist - function +(equal-test '((1 2 3 4 1 2 1 2 3) (2 3 4 2 2 3)) + #'maplist #'append '(1 2 3 4) '(1 2) '(1 2 3)) +(equal-test '((foo a b c d) (foo b c d) (foo c d) (foo d)) + #'maplist #'(lambda (x) (cons 'foo x)) '(a b c d)) +(equal-test '(0 0 1 0 1 1 1) + #'maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) '(a b a c d b c)) + +;; member - function +(setq a '(1 2 3)) +(eq-test (cdr a) #'member 2 a) +(setq a '((1 . 2) (3 . 4))) +(eq-test (cdr a) #'member 2 a :test-not #'= :key #'cdr) +(eq-test nil #'member 'e '(a b c d)) +(eq-test nil #'member 1 nil) +(error-test #'member 2 '(1 . 2)) +(setq a '(a b nil c d)) +(eq-test (cddr a) #'member-if #'listp a) +(setq a '(a #\Space 5/3 foo)) +(eq-test (cddr a) #'member-if #'numberp a) +(setq a '(3 6 9 11 . 12)) +(eq-test (cdddr a) #'member-if-not #'zerop a :key #'(lambda (x) (mod x 3))) + +;; multiple-value-bind - macro +(equal-eval '(11 9) '(multiple-value-bind (f r) (floor 130 11) (list f r))) + +;; multiple-value-call - special operator +(equal-eval '(1 / 2 3 / / 2 0.5) + '(multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5))) +(eql-eval 10 '(multiple-value-call #'+ (floor 5 3) (floor 19 4))) + +;; multiple-value-list - macro +(equal-eval '(-1 1) '(multiple-value-list (floor -3 4))) +(eql-eval nil '(multiple-value-list (values))) +(equal-eval '(nil) '(multiple-value-list (values nil))) + +;; multiple-value-prog1 - special operator +(setq temp '(1 2 3)) +(equal-eval temp + '(multiple-value-list + (multiple-value-prog1 + (values-list temp) + (setq temp nil) + (values-list temp)))) + +;; multiple-value-setq - macro +(eql-eval 1 '(multiple-value-setq (quotient remainder) (truncate 3.5d0 2))) +(eql-eval 1 quotient) +(eql-eval 1.5d0 'remainder) +(eql-eval 1 '(multiple-value-setq (a b c) (values 1 2))) +(eql-eval 1 'a) +(eql-eval 2 'b) +(eq-eval nil 'c) +(eql-eval 4 '(multiple-value-setq (a b) (values 4 5 6))) +(eql-eval 4 'a) +(eql-eval 5 'b) +(setq a 1) +(eql-eval nil '(multiple-value-setq (a) (values))) +(eql-eval nil 'a) + +;; nconc - function +(eq-test nil #'nconc) +(setq x '(a b c)) +(setq y '(d e f)) +(equal-test '(a b c d e f) #'nconc x y) +(equal-eval '(a b c d e f) 'x) +(eq-test y #'cdddr x) +(equal-test '(1 . 2) #'nconc (list 1) 2) +(error-test #'nconc 1 2 3) +(equal-eval '(k l m) + '(setq foo (list 'a 'b 'c 'd 'e) + bar (list 'f 'g 'h 'i 'j) + baz (list 'k 'l 'm))) +(equal-test '(a b c d e f g h i j k l m) #'nconc foo bar baz) +(equal-eval '(a b c d e f g h i j k l m) 'foo) +(equal-eval (nthcdr 5 foo) 'bar) +(equal-eval (nthcdr 10 foo) 'baz) +(setq foo (list 'a 'b 'c 'd 'e) + bar (list 'f 'g 'h 'i 'j) + baz (list 'k 'l 'm)) +(equal-eval '(a b c d e f g h i j k l m) '(setq foo (nconc nil foo bar nil baz))) +(equal-eval '(a b c d e f g h i j k l m) 'foo) +(equal-eval (nthcdr 5 foo) 'bar) +(equal-eval (nthcdr 10 foo) 'baz) + +;; notany - function +(eql-test t #'notany #'> '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) +(eql-test t #'notany 'not-used ()) +(eql-test nil #'notany #'characterp #(1 2 3 4 5 #\6 7 8)) + +;; notevery - function +(eql-test nil #'notevery #'< '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) +(eql-test nil #'notevery 'not-used ()) +(eql-test t #'notevery #'numberp #(1 2 3 4 5 #\6 7 8)) + +;; nth - accessor (function) +(eql-test 'foo #'nth 0 '(foo bar baz)) +(eql-test 'bar #'nth 1 '(foo bar baz)) +(eq-test nil #'nth 3 '(foo bar baz)) +(error-test #'nth 0 #c(1 2)) +(error-test #'nth 0 #(1 2)) +(error-test #'nth 0 "test") + +;; nth-value - macro +(equal-eval 'a '(nth-value 0 (values 'a 'b))) +(equal-eval 'b '(nth-value 1 (values 'a 'b))) +(eq-eval nil '(nth-value 2 (values 'a 'b))) +(equal-eval '(3332987528 3332987528 t) + '(multiple-value-list + (let* ((x 83927472397238947423879243432432432) + (y 32423489732) + (a (nth-value 1 (floor x y))) + (b (mod x y))) + (values a b (= a b))))) + +;; nthcdr - function +(eq-test nil #'nthcdr 0 '()) +(eq-test nil #'nthcdr 3 '()) +(equal-test '(a b c) #'nthcdr 0 '(a b c)) +(equal-test '(c) #'nthcdr 2 '(a b c)) +(eq-test () #'nthcdr 4 '(a b c)) +(eql-test 1 #'nthcdr 1 '(0 . 1)) +(error-test #'nthcdr -1 '(1 2)) +(error-test #'nthcdr #\Null '(1 2)) +(error-test #'nthcdr 1 t) +(error-test #'nthcdr 1 #(1 2 3)) + +;; or - macro +(eq-eval nil '(or)) +(setq temp0 nil temp1 10 temp2 20 temp3 30) +(eql-eval 10 '(or temp0 temp1 (setq temp2 37))) +(eql-eval 20 'temp2) +(eql-eval 11 '(or (incf temp1) (incf temp2) (incf temp3))) +(eql-eval 11 'temp1) +(eql-eval 20 temp2) +(eql-eval 30 'temp3) +(eql-eval 11 '(or (values) temp1)) +(eql-eval 11 '(or (values temp1 temp2) temp3)) +(equal-eval '(11 20) '(multiple-value-list (or temp0 (values temp1 temp2)))) +(equal-eval '(20 30) + '(multiple-value-list (or (values temp0 temp1) (values temp2 temp3)))) + +;; packagep - function (predicate) +(eq-test t #'packagep *package*) +(eq-test nil #'packagep 10) +(eq-test t #'packagep (make-package "TEST-PACKAGE")) +(eq-test nil #'packagep 'keyword) +(eq-test t #'packagep (find-package 'keyword)) + +;; pairlis - function +#+xedit ;; order of result may vary +(progn + (equal-test '((one . 1) (two . 2) (three . 3) (four . 19)) + #'pairlis '(one two) '(1 2) '((three . 3) (four . 19))) + (setq keys '(1 2 3) + data '("one" "two" "three") + alist '((4 . "four"))) + (equal-test '((1 . "one") (2 . "two") (3 . "three")) + #'pairlis keys data) + (equal-test '((1 . "one") (2 . "two") (3 . "three") (4 . "four")) + #'pairlis keys data alist) + (equal-eval '(1 2 3) 'keys) + (equal-eval '("one" "two" "three") 'data) + (equal-eval '((4 . "four")) 'alist) + (eq-test nil #'pairlis 1 2) + (error-test #'pairlis '(1 2 3) '(4 5)) +) + +;; pop - macro +(setq stack '(a b c) test stack) +(eq-eval 'a '(pop stack)) +(eq-eval (cdr test) 'stack) +(setq llst '((1 2 3 4)) test (car llst)) +(eq-eval 1 '(pop (car llst))) +(eq-eval (cdr test) '(car llst)) +(error-eval '(pop 1)) +(error-eval '(pop nil)) +;; dotted list +(setq stack (cons 1 2)) +(eq-eval 1 '(pop stack)) +(error-eval '(pop stack)) +;; circular list +(setq stack '#1=(1 . #1#) *print-circle* t) +(eql-eval 1 '(pop stack)) +(eql-eval 1 '(pop stack)) +(eql-eval 1 '(pop (cdr stack))) + +;; position - function +(eql-test 4 #'position #\a "baobab" :from-end t) +(eql-test 2 #'position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car) +(eq-test nil #'position 595 '()) +(eq-test 4 #'position-if-not #'integerp '(1 2 3 4 5.0)) +(eql-test 1 #'position (char-int #\1) "0123" :key #'char-int) + +;; prog - macro +(eq-eval nil '(prog () :error)) +(eq-eval 'ok + '(prog ((a 0)) + l1 (if (< a 10) (go l3) (go l2)) + (return 'failed) + l2 (return 'ok) + (return 'failed) + l3 (incf a) (go l1) + (return 'failed) + )) +(setq a 1) +(eq-eval '/= '(prog ((a 2) (b a)) (return (if (= a b) '= '/=)))) + +;; prog* - macro +(setq a 1) +(eq-eval nil '(prog* () :error)) +(eq-eval 'ok + '(prog* ((a 0) (b 0)) + l1 (if (< a 10) (go l3) (go l2)) + (return 'failed) + l2 (if (< b 10) (go l4) (return 'ok)) + (return 'failed) + l3 (incf a) (go l1) + (return 'failed) + l4 (incf b) (setq a 0) (go l1) + (return 'failed) + )) +(eq-eval '= '(prog* ((a 2) (b a)) (return (if (= a b) '= '/=)))) + +;; prog1 - macro +(setq temp 1) +(eql-eval 1 '(prog1 temp (incf temp) (eql-eval 2 'temp) temp)) +(eql-eval 2 'temp) +(eql-eval 2 '(prog1 temp (setq temp nil) (eql-eval nil 'temp) temp)) +(eq-eval nil 'temp) +(eql-eval 1 '(prog1 (values 1 2 3) 4)) +(setq temp (list 'a 'b 'c)) +(eq-eval 'a '(prog1 (car temp) (setf (car temp) 'alpha))) +(equal-eval '(alpha b c) 'temp) +(equal-eval '(1) + '(multiple-value-list (prog1 (values 1 2) (values 4 5)))) + +;; prog2 - macro +(setq temp 1) +(eql-eval 3 '(prog2 (incf temp) (incf temp) (incf temp))) +(eql-eval 4 'temp) +(eql-eval 2 '(prog2 1 (values 2 3 4) 5)) +(equal-eval '(3) + '(multiple-value-list (prog2 (values 1 2) (values 3 4) (values 5 6)))) + +;; progn - special operator +(eq-eval nil '(progn)) +(eql-eval 3 '(progn 1 2 3)) +(equal-eval '(1 2 3) '(multiple-value-list (progn (values 1 2 3)))) +(setq a 1) +(eq-eval 'here '(if a (progn (setq a nil) 'here) (progn (setq a t) 'there))) +(eq-eval nil 'a) + +;; progv - special operator +(makunbound '*x*) ;; make sure it is not bound +(setq *x* 1) +(eql-eval 2 '(progv '(*x*) '(2) *x*)) +(eql-eval 1 '*x*) +(equal-eval '(3 4) + '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*))))) +(makunbound '*x*) +(defvar *x* 1) +(equal-eval '(4 4) + '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*))))) +(equal-eval '(4 4) + '(multiple-value-list + (let ((*x* 3)) + (progv '(*x*) '(4) (values-list (list *x* (symbol-value '*x*))))))) + +;; push - macro +(setq llst '(nil)) +(equal-eval '(1) '(push 1 (car llst))) +(equal-eval '((1)) 'llst) +(equal-eval '(1 1) '(push 1 (car llst))) +(equal-eval '((1 1)) 'llst) +(setq x '(a (b c) d)) +(equal-eval '(5 B C) '(push 5 (cadr x))) +(equal-eval '(a (5 b c) d) 'x) + +;; pushnew - macro +(setq x '(a (b c) d)) +(equal-eval '(5 b c) '(pushnew 5 (cadr x))) +(equal-eval '(a (5 b c) d) 'x) +(equal-eval '(5 b c) '(pushnew 'b (cadr x))) +(equal-eval '(a (5 b c) d) 'x) +(setq lst '((1) (1 2) (1 2 3))) +(equal-eval '((2) (1) (1 2) (1 2 3)) '(pushnew '(2) lst)) +(equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst)) +(equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst :test 'equal)) +(equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst :key #'car)) + +;; remove-duplicates - function +(equal-test "aBcD" #'remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t) +(equal-test '(a c b d e) #'remove-duplicates '(a b c b d d e)) +(equal-test '(a b c d e) #'remove-duplicates '(a b c b d d e) :from-end t) +(equal-test '((bar #\%) (baz #\A)) + #'remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) + :test #'char-equal :key #'cadr) +(equal-test '((foo #\a) (bar #\%)) + #'remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) + :test #'char-equal :key #'cadr :from-end t) +(setq tester (list 0 1 2 3 4 5 6)) +(equal-test '(0 4 5 6) #'delete-duplicates tester :key #'oddp :start 1 :end 6) + +;; replace - function +(equal-test "abcd456hij" + #'replace (copy-seq "abcdefghij") "0123456789" :start1 4 :end1 7 :start2 4) +(setq lst (xseq "012345678")) +(equal-test "010123456" #'replace lst lst :start1 2 :start2 0) +(equal-eval "010123456" 'lst) + +;; rest - accessor +(equal-eval '(2) '(rest '(1 2))) +(eql-eval 2 '(rest '(1 . 2))) +(eq-eval nil '(rest '(1))) +(setq *cons* '(1 . 2)) +(equal-eval "two" '(setf (rest *cons*) "two")) +(equal-eval '(1 . "two") '*cons*) + +;; return - macro +(eq-eval nil '(block nil (return) 1)) +(eql-eval 1 '(block nil (return 1) 2)) +(equal-eval '(1 2) '(multiple-value-list (block nil (return (values 1 2)) 3))) +(eql-eval 1 '(block nil (block alpha (return 1) 2))) +(eql-eval 2 '(block alpha (block nil (return 1)) 2)) +(eql-eval 1 '(block nil (block nil (return 1) 2))) + +;; return-from - special operator +(eq-eval nil '(block alpha (return-from alpha) 1)) +(eql-eval 1 '(block alpha (return-from alpha 1) 2)) +(equal-eval '(1 2) + '(multiple-value-list (block alpha (return-from alpha (values 1 2)) 3))) +(eql-eval 2 + '(let ((a 0)) (dotimes (i 10) (incf a) (when (oddp i) (return))) a)) +(eq-eval 'temp '(defun temp (x) (if x (return-from temp ''dummy)) 44)) +(eql-eval 44 '(temp nil)) +(eq-eval 'dummy (temp t)) +(eql-eval 2 (block nil (unwind-protect (return-from nil 1) (return-from nil 2)))) +(error-eval '(funcall (block nil #'(lambda () (return-from nil))))) + +;; reverse - function +(setq str (xseq "abc") test str) +(equal-test "cba" #'reverse str) +(eq-eval test 'str) +(equal-eval "cba" '(setq test (nreverse str))) +(equal-eval "cba" 'test) +(setq l (list 1 2 3) test l) +(equal-eval '(3 2 1) '(setq test (nreverse l))) +(equal-eval '(3 2 1) 'test) + +;; rplac? - function +(eql-eval '*some-list* + '(defparameter *some-list* (list* 'one 'two 'three 'four))) +(equal-eval '(one two three . four) '*some-list*) +(equal-test '(uno two three . four) #'rplaca *some-list* 'uno) +(equal-eval '(uno two three . four) '*some-list*) +(equal-test '(three iv) #'rplacd (last *some-list*) (list 'iv)) +(equal-eval '(uno two three iv) '*some-list*) + +;; search - function +(eql-test 7 #'search "dog" "it's a dog's life") +(eql-test 2 #'search '(0 1) '(2 4 6 1 3 5) :key #'oddp) +(eql-test 8 #'search "foo" "foooobarfooooobarfo" :from-end t) +(eql-test 5 + #'search "123" + (mapcar #'(lambda (x) (+ x (char-code #\0))) + '(1 2 34 3 2 1 2 3 4 3 2 1)) :from-end t + :key #'(lambda (x) (if (integerp x) (code-char x) x))) +(eql-test 0 #'search "abc" "abcd" :from-end t) +(eql-test 3 #'search "bar" "foobar") + +;; set - function +(eql-eval 1 '(setf (symbol-value 'n) 1)) +(eql-test 2 #'set 'n 2) +(eql-test 2 #'symbol-value 'n) +(eql-eval 4 + '(let ((n 3)) + (setq n (+ n 1)) + (setf (symbol-value 'n) (* n 10)) + (set 'n (+ (symbol-value 'n) n)) + n)) +(eql-eval 44 'n) +(defvar *n* 2) +(eql-eval 80 + '(let ((*n* 3)) + (setq *n* (+ *n* 1)) + (setf (symbol-value '*n*) (* *n* 10)) + (set '*n* (+ (symbol-value '*n*) *n*)) + *n*)) +(eql-eval 2 '*n*) +(eq-eval '*even-count* '(defvar *even-count* 0)) +(eq-eval '*odd-count* '(defvar *odd-count* 0)) +(eql-eval 'tally-list + '(defun tally-list (list) + (dolist (element list) + (set (if (evenp element) '*even-count* '*odd-count*) + (+ element (if (evenp element) *even-count* *odd-count*)))))) +(eq-eval nil '(tally-list '(1 9 4 3 2 7))) +(eql-eval 6 '*even-count*) +(eql-eval 20 '*odd-count*) + +;; set-difference - function +(setq lst1 (list "A" "b" "C" "d") lst2 (list "a" "B" "C" "d")) +(equal-test '("A" "b" "C" "d") #'set-difference lst1 lst2) +(equal-test '("A" "b") #'set-difference lst1 lst2 :test 'equal) +(eq-test nil #'set-difference lst1 lst2 :test #'equalp) +(equal-test '("A" "b") #'nset-difference lst1 lst2 :test #'string=) +(setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f")) + lst2 '(("c" . "a") ("e" . "b") ("d" . "a"))) +(equal-test '(("c" . "d") ("e" . "f")) + #'nset-difference lst1 lst2 :test #'string= :key #'cdr) +(equal-eval '(("c" . "a") ("e" . "b") ("d" . "a")) 'lst2) +(equal-test '("banana" "lemon" "rhubarb") + #'set-difference + '("strawberry" "chocolate" "banana" "lemon" "pistachio" "rhubarb") + '(#\c #\w) :test #'(lambda (s c) (find c s))) + +;; set-exclusive-or - function +(setq lst1 (list 1 "a" "b") lst2 (list 1 "A" "b")) +(equal-test '("a" "b" "A" "b") #'set-exclusive-or lst1 lst2) +(equal-test '("a" "A") #'set-exclusive-or lst1 lst2 :test #'equal) +(eq-test nil #'set-exclusive-or lst1 lst2 :test 'equalp) +(equal-test '("a" "b" "A" "b") #'nset-exclusive-or lst1 lst2) +(setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f")) + lst2 '(("c" . "a") ("e" . "b") ("d" . "a"))) +(equal-test '(("c" . "d") ("e" . "f") ("c" . "a") ("d" . "a")) + #'nset-exclusive-or lst1 lst2 :test #'string= :key #'cdr) + +;; setf - macro +(setq x (cons 'a 'b) y (list 1 2 3)) +(equal-eval '(1 x 3) '(setf (car x) 'x (cadr y) (car x) (cdr x) y)) +(equal-eval '(x 1 x 3) 'x) +(equal-eval '(1 x 3) 'y) +(setq x (cons 'a 'b) y (list 1 2 3)) +(eq-eval nil '(psetf (car x) 'x (cadr y) (car x) (cdr x) y)) +(equal-eval '(x 1 a 3) 'x) +(equal-eval '(1 a 3) 'y) +(error-eval '(setf x)) +(error-eval '(psetf x)) + +;; setq - special form +(eql-eval 3 '(setq a 1 b 2 c 3)) +(eql-eval 1 'a) +(eql-eval 2 'b) +(eql-eval 3 'c) +(eql-eval 7 '(setq a (1+ b) b (1+ a) c (+ a b))) +(eql-eval 3 'a) +(eql-eval 4 'b) +(eql-eval 7 'c) +(eq-eval nil '(psetq a 1 b 2 c 3)) +(eql-eval 1 'a) +(eql-eval 2 'b) +(eql-eval 3 'c) +(equal-eval '(2 1) + '(multiple-value-list (let ((a 1) (b 2)) (psetq a b b a) (values a b)))) +(error-eval '(setq x)) +(error-eval '(setq x 1 y)) + +;; some - function +(eq-test t #'some #'= '(1 2 3 4 5) '(5 4 3 2 1)) + +;; sort - function +(setq tester (copy-seq "lkjashd")) +(equal-test "adhjkls" #'sort tester #'char-lessp) +(setq tester (list '(1 2 3) '(4 5 6) '(7 8 9))) +(equal-test '((7 8 9) (4 5 6) (1 2 3)) #'sort tester #'> :key #'car) +(setq tester (list 1 2 3 4 5 6 7 8 9 0)) +(equal-test '(1 3 5 7 9 2 4 6 8 0) + #'stable-sort tester #'(lambda (x y) (and (oddp x) (evenp y)))) +(equalp-test + #((("Kathy" "Chapman") "Editorial") + (("Dick" "Gabriel") "Objects") + (("Gregor" "Kiczales") "Objects") + (("Sandra" "Loosemore") "Compiler") + (("Larry" "Masinter") "Cleanup") + (("David" "Moon") "Objects") + (("Kent" "Pitman") "Conditions") + (("Dick" "Waters") "Iteration") + (("JonL" "White") "Iteration")) + #'sort (setq committee-data + (vector (list (list "JonL" "White") "Iteration") + (list (list "Dick" "Waters") "Iteration") + (list (list "Dick" "Gabriel") "Objects") + (list (list "Kent" "Pitman") "Conditions") + (list (list "Gregor" "Kiczales") "Objects") + (list (list "David" "Moon") "Objects") + (list (list "Kathy" "Chapman") "Editorial") + (list (list "Larry" "Masinter") "Cleanup") + (list (list "Sandra" "Loosemore") "Compiler"))) + #'string-lessp :key #'cadar) +(equalp-eval + #((("Larry" "Masinter") "Cleanup") + (("Sandra" "Loosemore") "Compiler") + (("Kent" "Pitman") "Conditions") + (("Kathy" "Chapman") "Editorial") + (("Dick" "Waters") "Iteration") + (("JonL" "White") "Iteration") + (("Dick" "Gabriel") "Objects") + (("Gregor" "Kiczales") "Objects") + (("David" "Moon") "Objects")) + '(setq committee-data + (stable-sort committee-data #'string-lessp :key #'cadr))) +(error-test #'sort #c(1 2)) + +;; string - function +(setq a "already a string") +(eq-test a #'string a) +(equal-test "ELM" #'string 'elm) +(equal-test "c" #'string #\c) + +;; string-* - function +(eq-test t #'string= "foo" "foo") +(eq-test nil #'string= "foo" "Foo") +(eq-test nil #'string= "foo" "bar") +(eq-test t #'string= "together" "frog" :start1 1 :end1 3 :start2 2) +(eq-test t #'string-equal "foo" "Foo") +(eq-test t #'string= "abcd" "01234abcd9012" :start2 5 :end2 9) +(eql-test 3 #'string< "aaaa" "aaab") +(eql-test 4 #'string>= "aaaaa" "aaaa") +(eql-test 5 #'string-not-greaterp "Abcde" "abcdE") +(eql-test 6 #'string-lessp "012AAAA789" "01aaab6" :start1 3 :end1 7 + :start2 2 :end2 6) +(eq-test nil #'string-not-equal "AAAA" "aaaA") +(error-test #'string= #(1 2 3) '(1 2 3)) +(eql-test 0 #'string< "abcd" "efg") +(eql-test 1 #'string< "abcd" "afg") +(eql-test 0 #'string/= "foo" "baar") +(eql-test nil #'string/= "foobar" "foobar") + +;; string-{upcase,downcase,capitalize} - function +(equal-test "ABCDE" #'string-upcase "abcde") +(equal-test "aBCDe" #'string-upcase "abcde" :start 1 :end 4) +(equal-test "aBCDe" #'nstring-upcase (xseq "abcde") :start 1 :end 4) +(equal-test "DR. LIVINGSTON, I PRESUME?" + #'string-upcase "Dr. Livingston, I presume?") +(equal-test "Dr. LIVINGSTON, I Presume?" + #'string-upcase "Dr. Livingston, I presume?" :start 4 :end 19) +(equal-test "Dr. LIVINGSTON, I Presume?" + #'nstring-upcase (xseq "Dr. Livingston, I presume?") :start 4 :end 19) +(equal-test "Dr. LiVINGston, I presume?" + #'string-upcase "Dr. Livingston, I presume?" :start 6 :end 10) +(equal-test "Dr. LiVINGston, I presume?" + #'nstring-upcase (xseq "Dr. Livingston, I presume?") :start 6 :end 10) +(equal-test "dr. livingston, i presume?" + #'string-downcase "Dr. Livingston, I presume?") +(equal-test "Dr. livingston, i Presume?" + #'string-downcase "Dr. Livingston, I Presume?" :start 1 :end 17) +(equal-test "Dr. livingston, i Presume?" + #'nstring-downcase (xseq "Dr. Livingston, I Presume?") :start 1 :end 17) +(equal-test "Elm 13c Arthur;Fig Don'T" + #'string-capitalize "elm 13c arthur;fig don't") +(equal-test "elm 13C Arthur;Fig Don't" + #'string-capitalize "elm 13c arthur;fig don't" :start 6 :end 21) +(equal-test "elm 13C Arthur;Fig Don't" + #'nstring-capitalize (xseq "elm 13c arthur;fig don't") :start 6 :end 21) +(equal-test " Hello " #'string-capitalize " hello ") +(equal-test " Hello " #'nstring-capitalize (xseq " hello ")) +(equal-test "Occluded Casements Forestall Inadvertent Defenestration" + #'string-capitalize "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION") +(equal-test "Don'T!" #'string-capitalize "DON'T!") +(equal-test "Pipe 13a, Foo16c" #'string-capitalize "pipe 13a, foo16c") +(setq str (copy-seq "0123ABCD890a")) +(equal-test "0123AbcD890a" #'nstring-downcase str :start 5 :end 7) +(equal-eval "0123AbcD890a" 'str) +(error-test #'nstring-capitalize 1) +(error-test #'string-capitalize "foobar" :start 4 :end 2) +(equal-test "foobar" #'string-capitalize "foobar" :start 0 :end 0) + +;; string-{,left-,right-}trim - function +(equal-test "kaaak" #'string-trim "abc" "abcaakaaakabcaaa") +#+xedit (equal-test "kaaak" #'nstring-trim "abc" "abcaakaaakabcaaa") +(equal-test "garbanzo beans" + #'string-trim '(#\Space #\Tab #\Newline) " garbanzo beans + ") +#+xedit (equal-test "garbanzo beans" + #'nstring-trim '(#\Space #\Tab #\Newline) " garbanzo beans + ") +(equal-test "three (silly) words" + #'string-trim " (*)" " ( *three (silly) words* ) ") +#+xedit (equal-test "three (silly) words" + #'nstring-trim " (*)" " ( *three (silly) words* ) ") +(equal-test "labcabcabc" #'string-left-trim "abc" "labcabcabc") +#+xedit (equal-test "labcabcabc" #'nstring-left-trim "abc" "labcabcabc") +(equal-test "three (silly) words* ) " + #'string-left-trim " (*)" " ( *three (silly) words* ) ") +#+xedit (equal-test "three (silly) words* ) " + #'nstring-left-trim " (*)" " ( *three (silly) words* ) ") +(equal-test " ( *three (silly) words" + #'string-right-trim " (*)" " ( *three (silly) words* ) ") +#+xedit (equal-test " ( *three (silly) words" + #'nstring-right-trim " (*)" " ( *three (silly) words* ) ") +(error-test #'string-trim 123 "123") +(error-test #'string-left-trim 123 "123") + +;; stringp - function (predicate) +(eq-test t #'stringp "abc") +(eq-test nil #'stringp #\a) +(eq-test nil #'stringp 1) +(eq-test nil #'stringp #(#\a #\b #\c)) + +;; subseq - accessor +(setq str (xseq "012345")) +(equal-test "2345" #'subseq str 2) +(equal-test "34" #'subseq str 3 5) +(equal-eval "abc" '(setf (subseq str 4) "abc")) +(equal-eval "0123ab" 'str) +(equal-eval "A" '(setf (subseq str 0 2) "A")) +(equal-eval "A123ab" 'str) + +;; subsetp - function +(setq cosmos '(1 "a" (1 2))) +(eq-test t #'subsetp '(1) cosmos) +(eq-test nil #'subsetp '((1 2)) cosmos) +(eq-test t #'subsetp '((1 2)) cosmos :test 'equal) +(eq-test t #'subsetp '(1 "A") cosmos :test #'equalp) +(eq-test nil #'subsetp '((1) (2)) '((1) (2))) +(eq-test t #'subsetp '((1) (2)) '((1) (2)) :key #'car) + +;; svref - function +;; XXX vectors will be reimplemented, just a test for the current implementation +(setq v (vector 1 2 'sirens)) +(eql-eval 1 '(svref v 0)) +(eql-eval 'sirens '(svref v 2)) +(eql-eval 'newcomer '(setf (svref v 1) 'newcomer)) +(equalp-eval #(1 newcomer sirens) 'v) + +;; symbol-name - function +(equal-test "TEMP" #'symbol-name 'temp) +(equal-test "START" #'symbol-name :start) +(error-test #'symbol-name 1) + +;; symbol-package - function +(eq-test (find-package "LISP") #'symbol-package 'car) +(eql-test *package* #'symbol-package 'bus) +(eq-test (find-package "KEYWORD") #'symbol-package :optional) +;; Gensyms are uninterned, so have no home package. +(eq-test nil #'symbol-package (gensym)) +(setq pk1 (make-package 'pk1)) +(intern "SAMPLE1" "PK1") +(eq-eval t '(export (find-symbol "SAMPLE1" "PK1") "PK1")) +(setq pk2 (make-package 'pk2 :use '(pk1))) +(equal-eval '(pk1:sample1 :inherited) + '(multiple-value-list (find-symbol "SAMPLE1" "PK2"))) +(eq-test pk1 #'symbol-package 'pk1::sample1) +(eq-test pk1 #'symbol-package 'pk2::sample1) +(eq-test pk1 #'symbol-package 'pk1::sample2) +(eq-test pk2 #'symbol-package 'pk2::sample2) +;; The next several forms create a scenario in which a symbol +;; is not really uninterned, but is "apparently uninterned", +;; and so SYMBOL-PACKAGE still returns NIL. +(setq s3 'pk1::sample3) +(eq-eval t '(import s3 'pk2)) +(eq-eval t '(unintern s3 'pk1)) ;; XXX unintern not yet implemented +(eq-test nil #'symbol-package s3) ;; fail due to unintern not implemented +(eq-test t #'eq s3 'pk2::sample3) + +;; symbol-plist - accessor +(setq sym (gensym)) +(eq-eval () '(symbol-plist sym)) +(eq-eval 'val1 '(setf (get sym 'prop1) 'val1)) +(equal-eval '(prop1 val1) '(symbol-plist sym)) +(eq-eval 'val2 '(setf (get sym 'prop2) 'val2)) +(equal-eval '(prop2 val2 prop1 val1) '(symbol-plist sym)) +(setq sym-plist (list 'prop3 'val3)) +(eq-eval sym-plist '(setf (symbol-plist sym) sym-plist)) +(eq-eval sym-plist '(symbol-plist sym)) + +;; symbol-value - accessor +(eql-eval 1 '(setf (symbol-value 'a) 1)) +(eql-eval 1 '(symbol-value 'a)) +;; SYMBOL-VALUE cannot see lexical variables. +(eql-eval 1 '(let ((a 2)) (symbol-value 'a))) +(eql-eval 1 '(let ((a 2)) (setq a 3) (symbol-value 'a))) + +#+xedit ;; incorrect... +(progn + ;; SYMBOL-VALUE can see dynamic variables. + ;; declare not yet implemented + (proclaim '(special a)) + (eql-eval 2 '(let ((a 2)) (symbol-value 'a))) + (eql-eval 1 'a) + (eql-eval 3 '(let ((a 2)) (setq a 3) (symbol-value 'a))) + (eql-eval 1 'a) + ;; declare not yet implement + (makunbound 'a) + (eql-eval 2 '(let ((a 2)) (setf (symbol-value 'a) 3) a)) + (eql-eval 3 'a) + (eql-eval 3 '(symbol-value 'a)) + ;; declare not yet implement + (makunbound 'a) + (equal-eval '(5 4) + '(multiple-value-list + (let ((a 4)) + + ;; declare not yet implemented + (defparameter a 3) + + (let ((b (symbol-value 'a))) + (setf (symbol-value 'a) 5) + (values a b))))) + (eql-eval 3 'a) +) +(eq-eval :any-keyword '(symbol-value :any-keyword)) +;; XXX these will fail +(eq-eval nil '(symbol-value 'nil)) +(eq-eval nil '(symbol-value '())) + +;; symbolp - function (predicate) +(eq-test t #'symbolp 'elephant) +(eq-test nil #'symbolp 12) +;; XXX these will fail +(eq-test t #'symbolp nil) +(eq-test t #'symbolp '()) +(eq-test t #'symbolp :test) +(eq-test nil #'symbolp "hello") + +;; remprop - function +(setq test (make-symbol "PSEUDO-PI")) +(eq-eval () '(symbol-plist test)) +(eq-eval t '(setf (get test 'constant) t)) +(eql-eval 3.14 '(setf (get test 'approximation) 3.14)) +(eql-eval 'noticeable '(setf (get test 'error-range) 'noticeable)) +(equal-eval '(error-range noticeable approximation 3.14 constant t) + '(symbol-plist test)) +(eq-eval nil '(setf (get test 'approximation) nil)) +(equal-eval '(error-range noticeable approximation nil constant t) + '(symbol-plist test)) +(eq-eval nil (get test 'approximation)) +(eq-test t #'remprop test 'approximation) +(eq-eval nil '(get test 'approximation)) +(equal-eval '(error-range noticeable constant t) '(symbol-plist test)) +(eq-test nil #'remprop test 'approximation) +(equal-eval '(error-range noticeable constant t) '(symbol-plist test)) +(eq-test t #'remprop test 'error-range) +(eql-eval 3 '(setf (get test 'approximation) 3)) +(equal-eval '(approximation 3 constant t) '(symbol-plist test)) + +;; throw - special operator +(equal-eval '(3 9) + '(multiple-value-list + (catch 'result + (setq i 0 j 0) + (loop (incf j 3) (incf i) + (if (= i 3) (throw 'result (values i j))))))) +(eql-eval 2 '(catch nil (unwind-protect (throw nil 1) (throw nil 2)))) + +;; XXX undefined consequences +(eql-eval 2 + '(catch 'a + (catch 'b + (unwind-protect (throw 'a 1) + (throw 'b 2))))) +(eq-eval :outer-catch + '(catch 'foo + (setq string (format nil "The inner catch returns ~s." + (catch 'foo + (unwind-protect (throw 'foo :first-throw) + (throw 'foo :second-throw))))) + :outer-catch)) +(equal-eval "The inner catch returns :SECOND-THROW." 'string) + +;; tree-equal - function +(setq tree1 '(1 (1 2)) + tree2 '(1 (1 2))) +(eq-test t #'tree-equal tree1 tree2) +(eq-test nil #'eql tree1 tree2) +(setq tree1 '('a ('b 'c)) + tree2 '('a ('b 'c))) +(eq-test t #'tree-equal tree1 tree2 :test 'eq) +(eq-test t #'tree-equal 1 1) +(eq-test nil #'tree-equal (list 1 2) (cons 1 2)) +(eq-test nil #'tree-equal 1 2) + +;; union - function +(equal-test '(b c f a d) #'union '(a b c) '(f a d)) +(equal-test '((y 6) (z 2) (x 4)) + #'union '((x 5) (y 6)) '((z 2) (x 4)) :key #'car) +(setq lst1 (list 1 2 '(1 2) "a" "b") + lst2 (list 2 3 '(2 3) "B" "C")) +(equal-test '(1 (1 2) "a" "b" 2 3 (2 3) "B" "C") #'nunion lst1 lst2) + +;; unless - macro +(eq-eval 'hello '(when t 'hello)) +(eq-eval nil '(unless t 'hello)) +(eq-eval nil (when nil 'hello)) +(eq-eval 'hello '(unless nil 'hello)) +(eq-eval nil (when t)) +(eql-eval nil '(unless nil)) +(setq test nil) +(equal-eval '(3 2 1) '(when t (push 1 test) (push 2 test) (push 3 test))) +(equal-eval '(3 2 1) 'test) +(setq test nil) +(eq-eval nil '(unless t (push 1 test) (push 2 test) (push 3 test))) +(eq-eval nil 'test) +(eq-eval nil '(when nil (push 1 test) (push 2 test) (push 3 test))) +(eq-eval nil 'test) +(equal-eval '(3 2 1) '(unless nil (push 1 test) (push 2 test) (push 3 test))) +(equal-eval '(3 2 1) 'test) +(equal-eval '((4) nil (5) nil 6 (6) 7 (7)) + '(let ((x 3)) + (list (when (oddp x) (incf x) (list x)) + (when (oddp x) (incf x) (list x)) + (unless (oddp x) (incf x) (list x)) + (unless (oddp x) (incf x) (list x)) + (if (oddp x) (incf x) (list x)) + (if (oddp x) (incf x) (list x)) + (if (not (oddp x)) (incf x) (list x)) + (if (not (oddp x)) (incf x) (list x))))) + +;; unwind-protect - special operator +(defun dummy-function (x) + (setq state 'running) + (unless (numberp x) (throw 'abort 'not-a-number)) + (setq state (1+ x))) +(eql-eval 2 '(catch 'abort (dummy-function 1))) +(eql-eval 2 'state) +(eq-eval 'not-a-number '(catch 'abort (dummy-function 'trash))) +(eq-eval 'running 'state) +(eq-eval 'not-a-number + '(catch 'abort (unwind-protect (dummy-function 'trash) + (setq state 'aborted)))) +(eq-eval 'aborted 'state) +(eql-eval 2 '(block nil (unwind-protect (return 1) (return 2)))) +;; XXX undefined consequences +(eql-eval 2 + '(block a + (block b + (unwind-protect (return-from a 1) + (return-from b 2))))) +(eql-eval 2 '(catch nil (unwind-protect (throw nil 1) (throw nil 2)))) +;; XXX undefined consequences +(eql-eval 2 + '(catch 'a (catch 'b (unwind-protect (throw 'a 1) (throw 'b 2))))) +(eq-eval ':outer-catch + '(catch 'foo + (setq string + (format nil "The inner catch returns ~s." + (catch 'foo + (unwind-protect (throw 'foo :first-throw) + (throw 'foo :second-throw))))) + :outer-catch)) +(equal-eval "The inner catch returns :SECOND-THROW." 'string) +(eql-eval 10 + '(catch 'a + (catch 'b + (unwind-protect (1+ (catch 'a (throw 'b 1))) + (throw 'a 10))))) +;; XXX undefined consequences +(eql-eval 4 + '(catch 'foo + (catch 'bar + (unwind-protect (throw 'foo 3) + (throw 'bar 4) + (print 'xxx))))) +(eql-eval 4 + '(catch 'bar + (catch 'foo + (unwind-protect (throw 'foo 3) + (throw 'bar 4) + (print 'xxx))))) +(eql-eval 5 + '(block nil + (let ((x 5)) + (unwind-protect (return) + (return x))))) + +;; upper-case-p - function +(eq-test t #'upper-case-p #\A) +(eq-test nil #'upper-case-p #\a) +(eq-test nil #'upper-case-p #\5) +(error-test #'upper-case-p 1) + +;; values - accessor +(eq-eval () '(multiple-value-list (values))) +(equal-eval '(1) '(multiple-value-list (values 1))) +(equal-eval '(1 2) '(multiple-value-list (values 1 2))) +(equal-eval '(1 2 3) '(multiple-value-list (values 1 2 3))) +(equal-eval '(1 4 5) '(multiple-value-list (values (values 1 2 3) 4 5))) + +;; values-list - function +(eq-eval nil '(multiple-value-list (values-list nil))) +(equal-eval '(1) '(multiple-value-list (values-list '(1)))) +(equal-eval '(1 2) '(multiple-value-list (values-list '(1 2)))) +(equal-eval '(1 2 3) '(multiple-value-list (values-list '(1 2 3)))) diff --git a/lisp/test/math.lsp b/lisp/test/math.lsp new file mode 100644 index 0000000..162f73f --- /dev/null +++ b/lisp/test/math.lsp @@ -0,0 +1,982 @@ +;; +;; Copyright (c) 2002 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/test/math.lsp,v 1.5 2003/01/30 02:46:26 paulo Exp $ +;; + +;; basic math tests +;; This is far from a good regression test, but in the current stage of +;; the interpreter, this is good enough to make sure it is not "so" +;; broken. But note that this does not test all cases where there is +;; change in the type of a numeric object. + +(setq *default-float-format* 'double-float) + +;; floating point results may differ from implementation to implementation (?!) + +(defun test (expect function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + (if error + (format t "ERROR: (~A~{ ~A~})~%" function arguments) + ;; Use eql to make sure result and expect have the same type + (or (eql result expect) +#-xedit ;; hack... + (or + (and + (floatp result) + (floatp expect) + (< (abs (- (abs result) (abs expect))) + 0.00000000000001d0) + ) + (format t "(~A~{ ~A~}) => should be ~A not ~A~%" + function arguments expect result + ) + ) +#+xedit (format t "(~A~{ ~A~}) => should be ~A not ~A~%" + function arguments expect result + ) + ) + ) +) + +(defun div-test (quotient remainder function &rest arguments + &aux quo rem (error t)) + (ignore-errors + (multiple-value-setq (quo rem) (apply function arguments)) + (setq error nil) + ) + (if error + (format t "ERROR: (~A~{ ~A~})~%" function arguments) + (or (and (eql quotient quo) (eql remainder rem)) +#-xedit ;; hack + (or + (or + (eql quotient quo) + (and + (floatp quotient) + (floatp quo) + (< (abs (- (abs quotient) (abs quo))) + 0.00000000000001d0) + ) + ) + (or + (eql remainder rem) + (and + (floatp remainder) + (floatp rem) + (< (abs (- (abs remainder) (abs rem))) + 0.00000000000001d0) + ) + ) + (format t "(~A~{ ~A~}) => should be ~A; ~A not ~A; ~A~%" + function arguments quotient remainder quo rem + ) + ) +#+xedit (format t "(~A~{ ~A~}) => should be ~A; ~A not ~A; ~A~%" + function arguments quotient remainder quo rem + ) + ) + ) +) + +(defun bool-test (expect function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + (if error + (format t "ERROR: (~A~{ ~A~})~%" function arguments) + (or (eq result expect) + (format t "(~A~{ ~A~}) => should be ~A not ~A~%" + function arguments expect result + ) + ) + ) +) + +(defun error-test (function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil)) + (unless error + (format t "ERROR: no error for (~A~{ ~A}), result was ~A~%" + function arguments result))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 0 #'+) +(test 5 #'+ 5) +(test -2 #'+ -2) +(test 3 #'+ 2 1) +(test 134217728 #'+ 134217727 1) +(test -134217729 #'+ -134217728 -1) +(test 2147483648 #'+ 2147483647 1) +(test -2147483649 #'+ -2147483648 -1) +(test -5 #'- 5) +(test 6 #'- -6) +(test 1 #'- 2 1) +(test 134217728 #'- 134217727 -1) +(test -2147483649 #'- -2147483648 1) +(test 4294967295 #'- 2147483647 -2147483648) +(test 1 #'*) +(test 4 #'* 4) +(test -5 #'* -5) +(test 6 #'* 2 3) +(test 2147483648 #'* 65536 32768) +(test 2147418112 #'* 65536 32767) +(test 134217728 #'* 65536 2048) +(test -134217728 #'* 65536 -2048) +(test 1/3 #'/ 3) +(test -1/4 #'/ -4) +(test 1/3 #'/ 10 30) +(test -1/2 #'/ -5 10) +(test -4 #'/ 20 -5) +(test 431432412345/32 #'/ 431432412345 32) +(test -2147483647/2147483648 #'/ 2147483647 -2147483648) +(test -1 #'/ 2147483648 -2147483648) +(test 2147483648 #'/ -2147483648 -1) +(test -1/2147483648 #'/ 1 -2147483648) +(test 1 #'min 2 3 4 1 5) +(test 7 #'max 0 -2 7 6 3) +(test -2147483648 #'min -2147483648 2147483647) +(test 2147483647 #'max -2147483648 2147483647) +(bool-test t #'< 1 2) +(bool-test nil #'< 2 2) +(bool-test nil #'< 4 3) +(bool-test t #'< -2147483648 -1) +(bool-test t #'< -2147483648 2147483648) +(bool-test t #'<= 3 3) +(bool-test nil #'<= 3 2) +(bool-test t #'<= 3 7) +(bool-test t #'<= -2147483648 2147483648) +(bool-test t #'= 1 1) +(bool-test nil #'= 1 -1) +(bool-test t #'= -2147483648 -2147483648) +(bool-test t #'>= 4 3) +(bool-test t #'>= 5 5) +(bool-test nil #'>= 4 9) +(bool-test t #'>= 2147483647 -2147483648) +(bool-test t #'> 7 5) +(bool-test nil #'> 20 20) +(bool-test nil #'> 19 31) +(bool-test nil #'> 2147483647 2147483648) +(bool-test nil #'> -2147483648 2147483647) +(bool-test nil #'/= 2147483647 2147483647) +(bool-test t #'/= 2147483647 -2147483648) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum bignum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4123412341238575768576858308380 #'+ + 431412 4123412341238575768576857876968) +(test -653653534554686349560628211 #'- + 4231423 653653534554686349564859634) +(test 17952112630025927929 #'* 4342423 4134123421423) +(test 412341/766687896595678 #'/ 412341 766687896595678) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 566594.4123d0 #'+ 43141 523453.4123d0) +(test -2.106249523586876d9 #'+ -2147483647 41234123.413124d0) +(test -6530250.653d0 #'- 4314 6534564.653d0) +(test -358687.653d0 #'- -324123 34564.653d0) +(test 3.26338916904d67 #'* 431234 756756d56) +(test 5.731169192902366d-50 #'/ 3 5234534d43) +(bool-test t #'< 423421 646454d0) +(bool-test t #'= 43242113 43242113d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 38654705646/17 #'+ 2147483647 2147483647/17) +(test -2146748499/17 #'+ 43244 -2147483647/17) +(test 17633127/4232 #'- 4321 653345/4232) +(test 28227714415090/4323 #'* 4312442 6545645/4323) +(test 639030/1441 #'* 42 15215/1441) +(test 924444112/547 #'/ 3432342 1641/808) +(bool-test t #'> 41342 42423/32) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 134681902103055335/31231131234 #'+ 4312423 53453535353/31231131234) +(test 134681795195984629/31231131234 #'- 4312423 53453535353/31231131234) +(test 230514255287590319/31231131234 #'* 4312423 53453535353/31231131234) +(test 134681848649519982/53453535353 #'/ 4312423 53453535353/31231131234) +(bool-test t #'> 4312423 53453535353/31231131234) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bignum fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4123412341234124068 #'+ 4123412341234123412 656) +(test 2147483647 #'+ 2147483648 -1) +(test 2147483648 #'- 2147483647 -1) +(test 3245393337480 #'* 4242344232 765) +(test 1414114744/255 #'/ 4242344232 765) +(bool-test nil #'< 2147483648 1) +(bool-test t #'> 2147483648 -2147483648) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bignum flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 5.452523543454353d15 #'+ 5452523543454353 423d-6) +(test -3.41423d205 #'- 54235423452345424443423 341423d200) +(test 2.7061221650759596d89 #'* 413423412341231232 6.545643242d71) +(test 9.744908405310087d-29 #'/ 41341234214 4242342d32) +(bool-test t #'< 4314123412312341234123 4234242d46) +(bool-test nil #'> 42342342142142421412341242 423423.432423d51) +(bool-test t #'= 100000000000000000000 1d20) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bignum fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 3027180466416641662/7 #'+ 432454352345234523 1/7) +(test 4294967295/2 #'- 2147483648 1/2) +(test 14113747078041141/152263 #'* 42341241234123423 1/456789) +(test 475355357536664/19 #'* 43214123412424 11/19) +(test 143960192608 #'/ 4234123312 1/34) +(test 15032385536/5 #'/ 2147483648 5/7) +(bool-test nil #'< 4123412341234123 423424/23) +(bool-test nil #'= 2147483648 1/3) +(bool-test t #'> 2147483648 1/3) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bignum bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -493153721444554600746963362777609/11404707804137 + #'+ -43241241241241234234 18178448448449/11404707804137) +(test 22573725350444837506376255369215081106984960/431241324242143434377 + #'- 52345923457394857234895 455/431241324242143434377) +(test 355905909219316970540364021939287762325439304380984344811607132990/14374707710807 + #'* 45523452345234790345923405723902389345782390 23454234524234523623623/43124123132421) +(test -853356237922877963618542794532291751029677352/21566206170617061706171 + #'/ 4131234123412342 -43132412341234123412342/413124123412312234123412312312) +(bool-test nil #'< 9482384762389461234892 463124869123897/43124123456678) +(bool-test t #'/= 4689123469123846123843 4123894623894612/211) +(bool-test t #'> 90437849234701234891203 4234123423/37) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4.3291328479d86 #'+ 43291328479d76 431243) +(test 4.123123123432d58 #'- 4123123123432d46 2147483647) +(test 4.1974800714094d109 #'* 970874791d96 43234) +(test -1.0004838618250252d55 #'/ -432423.432d56 4322143) +(bool-test nil #'< 4324932.342d5 4321421) +(bool-test t #'> 2147483648d0 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum bignum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4.3124325345d62 #'+ 4312432.5345d56 431241234901234791023479023) +(test 4.123123443242d39 #'- 41231234.43242d32 -10947390284720389) +(test 9.81681448753991d48 #'* 42342.89d27 231840917980324712) +(test 6.837110051466236d49 #'/ -64832d57 -948236894126) +(bool-test nil #'< 7589079203d56 43214124124312) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4.12685643412d7 #'+ 34442.3412d0 41234122d0) +(test -4.23432d84 #'- -45523453d56 423432d79) +(test 2.0000000000000004d0 #'* 1.4142135623730951d0 1.4142135623730951d0) +(test -1.414213562373095d0 #'/ -2d0 1.4142135623730951d0) +(test 0.7071067811865476d0 #'/ 1.4142135623730951d0 2d0) +(bool-test nil #'< 43124123d56 4231412d43) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 3.41412d61 #'+ 341412d56 3/652) +(test 4.312443d72 #'- 43124.43d68 42421/5678) +(test -4.32112300201218d73 #'* 4321123d67 -2147483648/2147483647) +(test 3.388443859138533d58 #'/ 432412d54 13744/1077) +(bool-test t #'> 423194237d43 4231412/23) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4.378904431d62 #'+ 4378904.431d56 49230471923047129/32412341234126) +(test 0d0 #'- 1.7320508075688772d0 3900231685776981/2251799813685248) +(test 5.000000000000001d0 #'* 2.23606797749979d0 629397181890197/281474976710656) +(test 7.000000000000001d0 #'/ 2.6457513110645907d0 1125899906842624/2978851154656373) +(bool-test nil #'< 790412390412d45 1005712007432/10518078881) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 23502480199/57 #'+ 1/57 412324214) +(test -1608505/39 #'- 11/39 41244) +(test 241844976595/3121 #'* 45245/3121 5345231) +(test 4231/30211050 #'/ 4231/67890 445) +(bool-test nil #'< 43123/12 -3432) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio bignum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 290071443963580821646/4115 #'+ -14119/4115 70491237901234711) +(test 92654360215843653827434431256/1237 #'- 423412/1237 -74902473901247901234789012) +(test 139081825032265225396/111 #'* 13/777 74890213478912044444) +(test -22/19000187487170108051697772680759 #'/ -176/31 4903274190237447239147812304712) +(bool-test t #'< 7094123/312 423412429047) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 3756.777956289953d0 #'+ 41290/11 3.141592653589793d0) +(test 3750.494770982774d0 #'- 41290/11 3.141592653589793d0) +(test 11792.396424247505d0 #'* 41290/11 3.141592653589793d0) +(test 1194.8195636844289d0 #'/ 41290/11 3.141592653589793d0) +(bool-test nil #'< 41290/11 3.141592653589793d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -2/2147483647 #'+ 2147483646/2147483647 -2147483648/2147483647) +(test 4611686015206162432/2305843005992468481 #'+ 2147483648/2147483646 2147483648/2147483647) +(test 114/91 #'+ 5/7 7/13) +(test 2 #'- 2147483646/2147483647 -2147483648/2147483647) +(test -6442450939/4611686009837453315 #'- 2147483646/2147483647 2147483647/2147483645) +(test 214/231 #'- 5/7 -7/33) +(test 183092240452/408559 #'* '432421/3217 423412/127) +(test 1057751/7345 #'* 34121/65 31/113) +(test -93866791/102381559 #'/ 143747/107 -956837/653) +(test 117/517 #'/ 13/33 47/27) +(bool-test nil #'< 5/3 7/9) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 1211321073398067249731082729214954013/1099249926163926018396018404101914 + #'+ 23141/21 572903572390457239/52345234579234572304572304957234) +(test -1210401943424090457832980748892408320175/1099249926163926018396018404101914 + #'+ -23123441/21 572903572390457239/52345234579234572304572304957234) +(test -130565585970579643613431728982140/1297324236427391 + #'- 6/83 1573079349043128237436315709694/15630412487077) +(test 119377824848653/98027 #'* 4123/61 28954117111/1607) +(test -533081148/1126543487854337661125 #'/ 4132412/125 -9012347902834701289/129) +(bool-test nil #'< 4132412/125 -9012347902834701289/129) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 48668779872364438/8438103123 #'+ 49032749012471920/8438103123 -43134) +(test 49396718152579402/8438103123 #'- 49032749012471920/8438103123 -43134) +(test -704992865301321265760/2812701041 #'* 49032749012471920/8438103123 -43134) +(test -24516374506235960/181984570053741 #'/ 49032749012471920/8438103123 -43134) +(bool-test t #'> 49032749012471920/8438103123 -43134) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio bignum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 22765322736543569109219273030163417097453878379283263605274270/46382946123894712341 + #'+ 4692318468912374612389461278/46382946123894712341 490812348912346238794612389461238961238912) +(test -22765322736543569109219273030163417097453878379283263605274270/46382946123894712341 + #'- -4692318468912374612389461278/46382946123894712341 490812348912346238794612389461238961238912) +(test -2303047849571666696101160700266058250647016644840659232609643130849536/46382946123894712341 + #'* 4692318468912374612389461278/46382946123894712341 -490812348912346238794612389461238961238912) +(test 2346159234456187306194730639/11382661368271784554609636515081706202567704733454325607906496 + #'/ -4692318468912374612389461278/46382946123894712341 -490812348912346238794612389461238961238912) +(bool-test t #'< 4692318468912374612389461278/46382946123894712341 490812348912346238794612389461238961238912) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 63.2771680782255d0 #'+ 31.63858403911275d0 4452734852783697/140737488355328) +(test 0d0 #'+ -31.63858403911275d0 4452734852783697/140737488355328) +(test -1001.0000000000001d0 #'* -31.63858403911275d0 4452734852783697/140737488355328) +(test 1d0 #'/ -31.63858403911275d0 -4452734852783697/140737488355328) +(bool-test nil #'< -31.63858403911275d0 -4452734852783697/140737488355328) +(bool-test nil #'> -31.63858403911275d0 -4452734852783697/140737488355328) +(bool-test nil #'/= -31.63858403911275d0 -4452734852783697/140737488355328) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 0 #'+ 2147483648/2147483647 -2147483648/2147483647) +(test 3230093924913437/413416372043776 #'+ 45705840067699/8796093022208 123/47) +(test 4294967296/2147483647 #'- 2147483648/2147483647 -2147483648/2147483647) +(test 1066255041450269/413416372043776 #'- 45705840067699/8796093022208 123/47) +(test -5621818328326977/413416372043776 #'* -45705840067699/8796093022208 123/47) +(test -2148174483181853/1081919441731584 #'/ 45705840067699/8796093022208 -123/47) +(bool-test t #'> 45705840067699/8796093022208 123/47) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 2679495973598190955776211861634126560767052764822779809414184089582/140710542183009389719255843429922029722593 + #'+ 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) +(test 2679495973598190955776211861634126560767052765333892522296541398514/140710542183009389719255843429922029722593 + #'- 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) +(test -4866460021317766216371472892133283923086494176/140710542183009389719255843429922029722593 + #'* 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) +(test -1339747986799095477888105930817063280383526382539168082927681372024/127778178220589327233 + #'/ 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) +(bool-test t #'> 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; complex real +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test #c(2147483648 -1) #'+ #c(1 -1) 2147483647) +(test #c(2.147483648d9 -1) #'+ #c(2147483647 -1) 1d0) +(test #c(129642370237029633787/3 0.25d0) #'- #c(-11/3 0.25d0) -43214123412343211266) +(test #c(23470/21 4.333333333333334d0) #'* #c(2347/7 1.3d0) 10/3) +(test #c(134217728/11 67108864/11) #'* #c(65536 32768) 2048/11) +(test #c(1.3133333333333332d0 82304) #'/ #c(1.97d0 123456) 3/2) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; real complex +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test #c(80/7 7/13) #'+ 3/7 #c(11 7/13)) +(test #c(1.2345d47 -1) #'+ 12345d43 #c(-2147483648 -1)) +(test #c(-2147483649 2147483647) #'+ -2147483648 #c(-1 2147483647)) +(test #c(41/15 1.23456d68) #'- #c(7/5 1234.56d65) -4/3) +(test #c(-41/19 2147483648) #'* #c(41/19 -2147483648) -1) +(test #c(-88046829568/40802189293 2.147483649d41) #'* #c(41/19 -2147483648d32) -2147483648/2147483647) +(test #c(-5.0691244239631335d0 1.3911008563333336d16) + #'/ #c(-11/7 4312412654633334) 0.31d0) +(bool-test t #'= #c(1 0.0) 1) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; complex complex +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test #c(-16.0d0 -4.0d0) #'+ #c(-16.0d0 -4.0d0)) +(test #c(0d0 1d0) #'- #c(0d0 -1d0)) +(test #c(1d0 3d0) #'- #c(-1d0 -3d0)) +(test #c(-16.0d0 -4.0d0) #'* #c(-16.0d0 -4.0d0)) +(test #c(-0.058823529411764705d0 0.014705882352941176d0) #'/ #c(-16d0 -4d0)) +(test #c(1.94d0 301868863889/7) #'+ #c(3/5 5/7) #c(1.34d0 43124123412)) +(test #c(8641975242/7 -3.4596d0) #'- #c(1234567890 0.0004d0) #c(-12/7 3.46d0)) +(test #c(2944.315858312371d0 5.59002d13) #'* #c(-11/7 -1234d9) #c(-45.3d0 5/2147483647)) +(test #c(1.9635384272224412d-8 -0.33333333317811176d0) + #'/ #c(2147483647/3 -0.5d0) #c(128 2147483648.0d0)) +(test #c(8.154945137073864d11 2.621232365490813d12) + #'/ #c(-1.3d0 4312412654633) #c(3/2 7/15)) +(test #c(0.003674737027278924d0 -257.6948748113586d0) + #'/ #c(1.5d0 -432412) #c(1678 -567/31313)) +(bool-test t #'= #c(1 2d0) #c(1 2)) +(bool-test nil #'/= #c(1 2) #c(1d0 2d0)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; abs +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 2147483648 #'abs -2147483648) +(test 2147483647 #'abs -2147483647) +(test 2147483647 #'abs 2147483647) +(test 1 #'abs 1) +(test 5/7 #'abs -5/7) +(test 2147483648/2147483647 #'abs -2147483648/2147483647) +(test 3.12d0 #'abs -3.12d0) +(test 4312412341234124124123412 #'abs 4312412341234124124123412) +(test 4312412341234124124123412 #'abs -4312412341234124124123412) +(test 1.0 #'abs #c(1 0.0)) +(test 11.40175425099138d0 #'abs #c(-11 3d0)) +(test 4.47213595499958d0 #'abs #c(-4 -2)) +(test 1.0 #'abs #c(0.0 -1.0)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; sqrt +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 3.4641016151377544d0 #'sqrt 12) +(test #c(0 12) #'sqrt -144) +(test 6.429728792199102d18 #'sqrt 41341412341234123412490123470912347210) +(test 41341412341234123412490123470912347210 + #'sqrt 1709112374367945085349927261774254951456404621200206927501652414831594784100) +(test 46340.95001184158d0 #'sqrt 2147483648) +(test 0.7071067811865476d0 #'sqrt 0.5d0) +(test 0 #'sqrt 0) +(test 0d0 #'sqrt 0d0) +(test 111.1106106544285d0 #'sqrt 12345.5678d0) +(test #c(0 11.119982014373944d0) #'sqrt -123.654d0) +(test 3/8 #'sqrt 9/64) +(test #c(0 1.1832159566199232d0) #'sqrt -7/5) +(test 514.7536007118473d0 #'sqrt 821974900428408092/3102128401119) +(test 413412341293461238946192384612893/314212341412341246128361289 + #'sqrt 170909763933741276657131032282211169869649489782500833989461829449/98729395495825697643724477479624921705328808513741521) +;; check for overflow +(error-test #'sqrt 402387260077093773543702433923003985719374864210714632543799910429938512398629020592044208486969404800479988610197196058631666872994808558901323829669944590997424504087073759918823627727188732519779505950995276120874975462497043601418278094646496291056393887437886487337119181045825783647849977012476632889835955735432513185323958463075557409114262417474349347553428646576611667797396668820291207379143853719588249808126867838374559731746136085379534524221586593201928090878297308431392844403281231558611036976801357304216168747609675871348312025478589320767169132448426236131412508780208000261683151027341827977704784635868170164365024153691398281264810213092761244896359928705114964975419909342221566832572080821333186116811553615836546984046708975602900950537616475847728421889679646244945160765353408198901385442487984959953319101723355556602139450399736280750137837615307127761926849034352625200015888535147331611702103968175921510907788019393178114194545257223865541461062892187960223838971476088506276862967146674697562911234082439208160153780889893964518263243671616762179168909779911903754031274622289988005195444414282012187361745992642956581746628302955570299024324153181617210465832036786906117260158783520751516284225540265170483304226143974286933061690897968482590125458327168226458066526769958652682272807075781391858178889652208164348344825993266043367660176999612831860788386150279465955131156552036093988180612138558600301435694527224206344631797460594682573103790084024432438465657245014402821885252470935190620929023136493273497565513958720559654228749774011413346962715422845862377387538230483865688976461927383814900140767310446640259899490222221765904339901886018566526485061799702356193897017860040811889729918311021171229845901641921068884387121855646124960798722908519296819372388642614839657382291123125024186649353143970137428531926649875337218940694281434118520158014123344828015051399694290153483077644569099073152433278288269864602789864321139083506217095002597389863554277196742822248757586765752344220207573630569498825087968928162753848863396909959826280956121450994871701244516461260379029309120889086942028510640182154399457156805941872748998094254742173582401063677404595741785160829230135358081840096996372524230560855903700624271243416909004153690105933983835777939410970027753472000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; mod +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 5 #'mod 5 9) +(test 4 #'mod -5 9) +(test -4 #'mod 5 -9) +(test -5 #'mod -5 -9) +(test 2147483646 #'mod -2147483648 2147483647) +(test -1 #'mod -2147483648 -2147483647) +(test 1 #'mod 2147483648 2147483647) +(test 0 #'mod -170909763933741276657131032282211169869649489782500833989461829449 413412341293461238946192384612893) +(test -1709112374367945085349927261774254951415063208858972804089162291360682436890 + #'mod 41341412341234123412490123470912347210 -1709112374367945085349927261774254951456404621200206927501652414831594784100) +(test 9.666666666666666d0 #'mod -1/3 10d0) +(test -9.666666666666666d0 #'mod 1/3 -10d0) +(test -0.3333333333333333d0 #'mod -1/3 -10d0) +(test 0.3333333333333333d0 #'mod 1/3 10d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; rem +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 2 #'rem 11 3) +(test 2 #'rem 11 -3) +(test -2 #'rem -11 3) +(test -2 #'rem -11 -3) +(test -1 #'rem -2147483648 2147483647) +(test 0.1499999999999999d0 #'rem 1.35d0 1/5) +(test -0.1499999999999999d0 #'rem -1.35d0 1/5) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; gcd +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 11 #'gcd 33 11) +(test 7 #'gcd 91 -49) +(test 4 #'gcd -4) +(test 0 #'gcd) +(test 11 #'gcd 3333 -33 1002001) +(test 1 #'gcd -2147483648 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; lcm +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 1 #'lcm) +(test 10 #'lcm 10) +(test 5 #'lcm -5) +(test 4611686016279904256 #'lcm -2147483648 2147483647) +(test 0 #'lcm 0 5) +(test 60 #'lcm 1 2 3 4 5 6) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; and +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -1 #'logand) +(test 0 #'logand 1 2) +(test -2147483648 #'logand -2147483648 -1) +(test 2147483647 #'logand 2147483647 -1) +(test 2147479552 #'logand 8796093018112 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; eqv +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -1 #'logeqv) +(test -4 #'logeqv 1 2) +(test -2147483648 #'logeqv -2147483648 -1) +(test 2147483647 #'logeqv 2147483647 -1) +(test -8793945542656 #'logeqv 8796093018112 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; or +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 0 #'logior) +(test 3 #'logior 1 2) +(test -1 #'logior -2147483648 -1) +(test -1 #'logior 2147483647 -1) +(test 8796093022207 #'logior 8796093018112 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; xor +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 0 #'logxor) +(test 3 #'logxor 1 2) +(test 2147483647 #'logxor -2147483648 -1) +(test -2147483648 #'logxor 2147483647 -1) +(test 8793945542655 #'logxor 8796093018112 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; not +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -1 #'lognot 0) +(test 0 #'lognot -1) +(test -2 #'lognot 1) +(test 1 #'lognot -2) +(test -3 #'lognot 2) +(test 2 #'lognot -3) +(test -2147483648 #'lognot 2147483647) +(test 2147483647 #'lognot -2147483648) +(test -8793945542656 #'lognot 8793945542655) +(test -8796093018113 #'lognot 8796093018112) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; floor +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(div-test 1 1/2 #'floor 3/2) +(div-test 1d0 1 #'ffloor 3 2) +(div-test -2 2147483646 #'floor -2147483648 2147483647) +(div-test 2147483648 0 #'floor -2147483648 -1) +(div-test 17179869184 0 #'floor 18446744073709551616 1073741824) +(div-test -17179869201 -1073741807 #'floor 18446744073709551616 -1073741823) +(div-test 2147483648 0d0 #'floor -2147483648 -1d0) +(div-test -2 2147483646/2147483647 #'floor -2147483648/2147483647) +(div-test 32768 32768/2147483647 #'floor 2147483648/2147483647 65535/2147483647) +(div-test -32769 -32767/2147483647 #'floor 2147483648/2147483647 -65535/2147483647) +(div-test -32769 32767/2147483647 #'floor -2147483648/2147483647 65535/2147483647) +(div-test 32768 -32768/2147483647 #'floor -2147483648/2147483647 -65535/2147483647) +(div-test 2 0.5d0 #'floor 3d0 1.25d0) +(div-test 2 1d0 #'floor 4d0 1.5d0) +(div-test -3 -0.5d0 #'floor 4d0 -1.5d0) +(div-test -3 0.5d0 #'floor -4d0 1.5d0) +(div-test 2 -1d0 #'floor -4d0 -1.5d0) +(div-test 1 2/91 #'floor 5/7 9/13) +(div-test -2 -61/91 #'floor 5/7 -9/13) +(div-test -2 61/91 #'floor -5/7 9/13) +(div-test 1 -2/91 #'floor -5/7 -9/13) +(div-test 1 0 #'floor 2147483648/2147483647 2147483648/2147483647) +(div-test -1 0 #'floor 2147483648/2147483647 -2147483648/2147483647) +(div-test -1 0 #'floor -2147483648/2147483647 2147483648/2147483647) +(div-test 1 0 #'floor -2147483648/2147483647 -2147483648/2147483647) +(div-test 9437 1416337955817765/144137437447079 + #'floor 16324116304212832041/144137437447079 12) +(div-test -9438 -313311293547183/144137437447079 + #'floor 16324116304212832041/144137437447079 -12) +(div-test -9438 313311293547183/144137437447079 + #'floor -16324116304212832041/144137437447079 12) +(div-test 9437 -1416337955817765/144137437447079 + #'floor -16324116304212832041/144137437447079 -12) +(div-test 8081 1138147903718848755797/4324123123412370 + #'floor 2147483648 1148972348912638496123/4324123123412370) +(div-test -8082 -1804074198964956721/720687187235395 + #'floor 2147483648 -1148972348912638496123/4324123123412370) +(div-test -8082 1804074198964956721/720687187235395 + #'floor -2147483648 1148972348912638496123/4324123123412370) +(div-test 8081 -1138147903718848755797/4324123123412370 + #'floor -2147483648 -1148972348912638496123/4324123123412370) +(div-test 0 1148972348912638496123/4324123123412370111 + #'floor 1148972348912638496123/4324123123412370111 2147483648) +(div-test -1 -9285982550494401861657948805/4324123123412370111 + #'floor 1148972348912638496123/4324123123412370111 -2147483648) +(div-test -1 9285982550494401861657948805/4324123123412370111 + #'floor -1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'floor -1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0.0d0 1.0000000004656613d0 #'ffloor 2147483648/2147483647 2147483648d0) +(div-test -1.0d0 -2.147483647d9 #'ffloor 2147483648/2147483647 -2147483648d0) +(div-test -1.0d0 2.147483647d9 #'ffloor -2147483648/2147483647 2147483648d0) +(div-test 0.0d0 -1.0000000004656613d0 #'ffloor -2147483648/2147483647 -2147483648d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ceiling +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(div-test 2 -1/2 #'ceiling 3/2) +(div-test 2d0 -1 #'fceiling 3 2) +(div-test -1 -1 #'ceiling -2147483648 2147483647) +(div-test 2147483648 0 #'ceiling -2147483648 -1) +(div-test 17179869184 0 #'ceiling 18446744073709551616 1073741824) +(div-test -17179869200 16 #'ceiling 18446744073709551616 -1073741823) +(div-test 2147483648 0d0 #'ceiling -2147483648 -1d0) +(div-test -1 -1/2147483647 #'ceiling -2147483648/2147483647) +(div-test 32769 -32767/2147483647 #'ceiling 2147483648/2147483647 65535/2147483647) +(div-test -32768 32768/2147483647 #'ceiling 2147483648/2147483647 -65535/2147483647) +(div-test -32768 -32768/2147483647 #'ceiling -2147483648/2147483647 65535/2147483647) +(div-test 32769 32767/2147483647 #'ceiling -2147483648/2147483647 -65535/2147483647) +(div-test 3 -0.75d0 #'ceiling 3d0 1.25d0) +(div-test 3 -0.5d0 #'ceiling 4d0 1.5d0) +(div-test -2 1d0 #'ceiling 4d0 -1.5d0) +(div-test -2 -1d0 #'ceiling -4d0 1.5d0) +(div-test 3 0.5d0 #'ceiling -4d0 -1.5d0) +(div-test 2 -61/91 #'ceiling 5/7 9/13) +(div-test -1 2/91 #'ceiling 5/7 -9/13) +(div-test -1 -2/91 #'ceiling -5/7 9/13) +(div-test 2 61/91 #'ceiling -5/7 -9/13) +(div-test 1 0 #'ceiling 2147483648/2147483647 2147483648/2147483647) +(div-test -1 0 #'ceiling 2147483648/2147483647 -2147483648/2147483647) +(div-test -1 0 #'ceiling -2147483648/2147483647 2147483648/2147483647) +(div-test 1 0 #'ceiling -2147483648/2147483647 -2147483648/2147483647) +(div-test 9438 -313311293547183/144137437447079 + #'ceiling 16324116304212832041/144137437447079 12) +(div-test -9437 1416337955817765/144137437447079 + #'ceiling 16324116304212832041/144137437447079 -12) +(div-test -9437 -1416337955817765/144137437447079 + #'ceiling -16324116304212832041/144137437447079 12) +(div-test 9438 313311293547183/144137437447079 + #'ceiling -16324116304212832041/144137437447079 -12) +(div-test 8082 -1804074198964956721/720687187235395 + #'ceiling 2147483648 1148972348912638496123/4324123123412370) +(div-test -8081 1138147903718848755797/4324123123412370 + #'ceiling 2147483648 -1148972348912638496123/4324123123412370) +(div-test -8081 -1138147903718848755797/4324123123412370 + #'ceiling -2147483648 1148972348912638496123/4324123123412370) +(div-test 8082 1804074198964956721/720687187235395 + #'ceiling -2147483648 -1148972348912638496123/4324123123412370) +(div-test 1 -9285982550494401861657948805/4324123123412370111 + #'ceiling 1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 1148972348912638496123/4324123123412370111 + #'ceiling 1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'ceiling -1148972348912638496123/4324123123412370111 2147483648) +(div-test 1 9285982550494401861657948805/4324123123412370111 + #'ceiling -1148972348912638496123/4324123123412370111 -2147483648) +(div-test 1.0d0 -2.147483647d9 #'fceiling 2147483648/2147483647 2147483648d0) +(div-test 0d0 1.0000000004656613d0 #'fceiling 2147483648/2147483647 -2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'fceiling -2147483648/2147483647 2147483648d0) +(div-test 1d0 2.147483647d9 #'fceiling -2147483648/2147483647 -2147483648d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; truncate +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(div-test 1 1/2 #'truncate 3/2) +(div-test 1d0 1 #'ftruncate 3 2) +(div-test -1 -1 #'truncate -2147483648 2147483647) +(div-test 2147483648 0 #'truncate -2147483648 -1) +(div-test 17179869184 0 #'truncate 18446744073709551616 1073741824) +(div-test -17179869200 16 #'truncate 18446744073709551616 -1073741823) +(div-test 2147483648 0d0 #'truncate -2147483648 -1d0) +(div-test -1 -1/2147483647 #'truncate -2147483648/2147483647) +(div-test 32768 32768/2147483647 #'truncate 2147483648/2147483647 65535/2147483647) +(div-test -32768 32768/2147483647 #'truncate 2147483648/2147483647 -65535/2147483647) +(div-test -32768 -32768/2147483647 #'truncate -2147483648/2147483647 65535/2147483647) +(div-test 32768 -32768/2147483647 #'truncate -2147483648/2147483647 -65535/2147483647) +(div-test 2 0.5d0 #'truncate 3d0 1.25d0) +(div-test 2 1d0 #'truncate 4d0 1.5d0) +(div-test -2 1d0 #'truncate 4d0 -1.5d0) +(div-test -2 -1d0 #'truncate -4d0 1.5d0) +(div-test 2 -1d0 #'truncate -4d0 -1.5d0) +(div-test 1 2/91 #'truncate 5/7 9/13) +(div-test -1 2/91 #'truncate 5/7 -9/13) +(div-test -1 -2/91 #'truncate -5/7 9/13) +(div-test 1 -2/91 #'truncate -5/7 -9/13) +(div-test 1 0 #'truncate 2147483648/2147483647 2147483648/2147483647) +(div-test -1 0 #'truncate 2147483648/2147483647 -2147483648/2147483647) +(div-test -1 0 #'truncate -2147483648/2147483647 2147483648/2147483647) +(div-test 1 0 #'truncate -2147483648/2147483647 -2147483648/2147483647) +(div-test 9437 1416337955817765/144137437447079 + #'truncate 16324116304212832041/144137437447079 12) +(div-test -9437 1416337955817765/144137437447079 + #'truncate 16324116304212832041/144137437447079 -12) +(div-test -9437 -1416337955817765/144137437447079 + #'truncate -16324116304212832041/144137437447079 12) +(div-test 9437 -1416337955817765/144137437447079 + #'truncate -16324116304212832041/144137437447079 -12) +(div-test 8081 1138147903718848755797/4324123123412370 + #'truncate 2147483648 1148972348912638496123/4324123123412370) +(div-test -8081 1138147903718848755797/4324123123412370 + #'truncate 2147483648 -1148972348912638496123/4324123123412370) +(div-test -8081 -1138147903718848755797/4324123123412370 + #'truncate -2147483648 1148972348912638496123/4324123123412370) +(div-test 8081 -1138147903718848755797/4324123123412370 + #'truncate -2147483648 -1148972348912638496123/4324123123412370) +(div-test 0 1148972348912638496123/4324123123412370111 + #'truncate 1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 1148972348912638496123/4324123123412370111 + #'truncate 1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'truncate -1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'truncate -1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0d0 1.0000000004656613d0 #'ftruncate 2147483648/2147483647 2147483648d0) +(div-test 0d0 1.0000000004656613d0 #'ftruncate 2147483648/2147483647 -2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'ftruncate -2147483648/2147483647 2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'ftruncate -2147483648/2147483647 -2147483648d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; round +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(div-test 2 -1/2 #'round 3/2) +(div-test 2d0 -1 #'fround 3 2) +(div-test -1 -1 #'round -2147483648 2147483647) +(div-test 2147483648 0 #'round -2147483648 -1) +(div-test 17179869184 0 #'round 18446744073709551616 1073741824) +(div-test -17179869200 16 #'round 18446744073709551616 -1073741823) +(div-test 2147483648 0d0 #'round -2147483648 -1d0) +(div-test -1 -1/2147483647 #'round -2147483648/2147483647) +(div-test 32769 -32767/2147483647 #'round 2147483648/2147483647 65535/2147483647) +(div-test -32769 -32767/2147483647 #'round 2147483648/2147483647 -65535/2147483647) +(div-test -32769 32767/2147483647 #'round -2147483648/2147483647 65535/2147483647) +(div-test 32769 32767/2147483647 #'round -2147483648/2147483647 -65535/2147483647) +(div-test 2 0.5d0 #'round 3d0 1.25d0) +(div-test 3 -0.5d0 #'round 4d0 1.5d0) +(div-test -3 -0.5d0 #'round 4d0 -1.5d0) +(div-test -3 0.5d0 #'round -4d0 1.5d0) +(div-test 3 0.5d0 #'round -4d0 -1.5d0) +(div-test 1 2/91 #'round 5/7 9/13) +(div-test -1 2/91 #'round 5/7 -9/13) +(div-test -1 -2/91 #'round -5/7 9/13) +(div-test 1 -2/91 #'round -5/7 -9/13) +(div-test 1 0 #'round 2147483648/2147483647 2147483648/2147483647) +(div-test -1 0 #'round 2147483648/2147483647 -2147483648/2147483647) +(div-test -1 0 #'round -2147483648/2147483647 2147483648/2147483647) +(div-test 1 0 #'round -2147483648/2147483647 -2147483648/2147483647) +(div-test 9438 -313311293547183/144137437447079 + #'round 16324116304212832041/144137437447079 12) +(div-test -9438 -313311293547183/144137437447079 + #'round 16324116304212832041/144137437447079 -12) +(div-test -9438 313311293547183/144137437447079 + #'round -16324116304212832041/144137437447079 12) +(div-test 9438 313311293547183/144137437447079 + #'round -16324116304212832041/144137437447079 -12) +(div-test 8082 -1804074198964956721/720687187235395 + #'round 2147483648 1148972348912638496123/4324123123412370) +(div-test -8082 -1804074198964956721/720687187235395 + #'round 2147483648 -1148972348912638496123/4324123123412370) +(div-test -8082 1804074198964956721/720687187235395 + #'round -2147483648 1148972348912638496123/4324123123412370) +(div-test 8082 1804074198964956721/720687187235395 + #'round -2147483648 -1148972348912638496123/4324123123412370) +(div-test 0 1148972348912638496123/4324123123412370111 + #'round 1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 1148972348912638496123/4324123123412370111 + #'round 1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'round -1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'round -1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0d0 1.0000000004656613d0 #'fround 2147483648/2147483647 2147483648d0) +(div-test 0d0 1.0000000004656613d0 #'fround 2147483648/2147483647 -2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'fround -2147483648/2147483647 2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'fround -2147483648/2147483647 -2147483648d0) +(div-test 2 0.5d0 #'round 2.5d0) +(div-test -2 -0.5d0 #'round -2.5d0) +(div-test 5 0d0 #'round 2.5d0 0.5d0) +(div-test -5 0d0 #'round 2.5d0 -0.5d0) +(div-test -5 0d0 #'round 2.5d0 -0.5d0) +(div-test -5 0d0 #'round -2.5d0 0.5d0) +(div-test 5 0d0 #'round -2.5d0 -0.5d0) +(div-test 1 -2/7 #'round 5/7) +(div-test -1 2/7 #'round -5/7) +(div-test 2 -1/2 #'round 3/2) +(div-test -2 1/2 #'round -3/2) +(div-test 2 1 #'round 30/2 7) +(div-test -2 1 #'round 30/2 -7) +(div-test -2 -1 #'round -30/2 7) +(div-test 2 -1 #'round -30/2 -7) +(div-test 1073741824 -1/2 #'round 2147483647/2) +(div-test -1073741824 1/2 #'round -2147483647/2) +(div-test 1 -2147483645/2 #'round 2147483647/2 2147483646) +(div-test -1 -2147483645/2 #'round 2147483647/2 -2147483646) +(div-test -1 2147483645/2 #'round -2147483647/2 2147483646) +(div-test 1 -2147483645/2 #'round 2147483647/2 2147483646) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; misc +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test #c(5 -5) #'conjugate #c(5 5)) +(test #c(5 5) #'conjugate #c(5 -5)) +(test #c(-5 -5) #'conjugate #c(-5 5)) +(test #c(-5 5) #'conjugate #c(-5 -5)) + +(test 1 #'denominator 10) +(test 3 #'denominator 10/3) +(test 3 #'denominator 1804074198964956721/3) +(test 4324123123412370111 #'denominator -1148972348912638496123/4324123123412370111) + +(bool-test nil #'evenp -1) +(bool-test t #'evenp -2147483648) +(bool-test t #'evenp -4294967296) +(bool-test nil #'evenp -4294967295) + +(test 0.5d0 #'float 1/2) +(test 10.0d0 #'float 10) +(test 4.978341823462786d22 #'float 49783418234627861238926) +(test 1.845867531346429d12 #'float 643827946123846123984/348794231) + +(bool-test t #'floatp 0.3d0) +(bool-test nil #'floatp 1/3) + +(test 0 #'imagpart 1) +(test -5 #'imagpart #c(1 -5)) + +(bool-test t #'integerp 12) +(bool-test nil #'integerp 1/2) +(bool-test nil #'integerp :test) +(bool-test nil #'integerp 0d0) +(bool-test t #'integerp 49783418234627861238926) + +(test 3 #'isqrt 12) +(test 46340 #'isqrt 2147483648) +(test 46340 #'isqrt 2147483647) +(test 25373764918 #'isqrt 643827946123846123984) + +(bool-test nil #'logtest 1 2) +(bool-test t #'logtest 1 3) +(bool-test t #'logtest 7 -1) + +(bool-test nil #'minusp 0) +(bool-test nil #'minusp 2147483648) +(bool-test t #'minusp -2147483648) +(bool-test t #'minusp -1/4) +(bool-test nil #'minusp 0.2d0) +(bool-test nil #'minusp 0d0) +(bool-test nil #'minusp 984723891462817946123897416) +(bool-test t #'minusp -1148972348912638496123/4324123123412370111) + +(bool-test t #'numberp #c(1 2)) +(bool-test t #'numberp -200) +(bool-test nil #'numberp :test) + +(test 10 #'numerator 10) +(test 10 #'numerator 10/3) +(test 1804074198964956721 #'numerator 1804074198964956721/3) +(test -1148972348912638496123 #'numerator -1148972348912638496123/4324123123412370111) + +(bool-test t #'oddp -1) +(bool-test nil #'oddp -2147483648) +(bool-test nil #'oddp -4294967296) +(bool-test t #'oddp -4294967295) + +(bool-test nil #'plusp 0) +(bool-test t #'plusp 2147483648) +(bool-test nil #'plusp -2147483648) +(bool-test nil #'plusp -1/4) +(bool-test t #'plusp 0.2d0) +(bool-test nil #'plusp 0d0) +(bool-test t #'plusp 984723891462817946123897416) +(bool-test nil #'plusp -1148972348912638496123/4324123123412370111) + +(test 1/4 #'rational 0.25d0) +(test 5/2 #'rational 2.5d0) +(test 1/8 #'rational 0.125d0) +(test -5/8 #'rational -0.625d0) +(test 524293/8 #'rational 65536.625d0) +(test 17179869181/8 #'rational 2147483647.625d0) + +(bool-test t #'rationalp -3) +(bool-test t #'rationalp 1/2) +(bool-test t #'rationalp 1/2412341242424122412) +(bool-test nil #'rationalp :test) +(bool-test nil #'rationalp 0d0) +(bool-test t #'rationalp 49783418234627861238926) + +(test -1 #'realpart #c(-1 0.5d0)) + +(test 1 #'signum 123/5) +(test 0d0 #'signum 0d0) +(test -1d0 #'signum -7.3d0) + +(bool-test nil #'zerop 1) +(bool-test nil #'zerop 1/4312412341234123412) +(bool-test nil #'zerop 0.000003d0) +(bool-test t #'zerop 0) +(bool-test t #'zerop 0d0) +(bool-test t #'zerop #c(0 0d0)) + +(bool-test t #'= 10 #c(10 0d0)) + diff --git a/lisp/test/psql-1.lsp b/lisp/test/psql-1.lsp new file mode 100644 index 0000000..2410fd8 --- /dev/null +++ b/lisp/test/psql-1.lsp @@ -0,0 +1,80 @@ +;; Postgresql C library interface, example program 1, using the xedit +;; lisp interface + +;; Test the C version of libpq, the PostgreSQL frontend library. +(require "psql") + +(defun exit-nicely (conn) + (pq-finish conn) + (quit 1) +) + +;; begin, by setting the parameters for a backend connection if the +;; parameters are null, then the system will try to use reasonable +;; defaults by looking up environment variables or, failing that, +;; using hardwired constants +(setq pghost nil) ; host name of the backend server +(setq pgport nil) ; port of the backend server +(setq pgoptions nil) ; special options to start up the backend server +(setq pgtty nil) ; debugging tty for the backend server +(setq pgdbname "template1") + +;; make a connection to the database +(setq conn (pq-setdb pghost pgport pgoptions pgtty pgdbname)) + +;; check to see that the backend connection was successfully made +(when (= (pq-status conn) pg-connection-bad) + (format t "Connection to database '~A' failed.~%" pgdbname) + (format t "~A" (pq-error-message conn)) + (exit-nicely conn)) + +;; start a transaction block +(setq res (pq-exec conn "BEGIN")) +(when (or (null res) (not (= (pq-result-status res) pgres-command-ok))) + (format t "BEGIN command failed~%") + (pq-clear res) + (exit-nicely conn)) + +;; Should PQclear PGresult whenever it is no longer needed to avoid memory leaks +(pq-clear res) + +;; fetch rows from the pg_database, the system catalog of databases +(setq res (pq-exec conn "DECLARE mycursor CURSOR FOR select * from pg_database")) +(when (or (null res) (not (= (pq-result-status res) pgres-command-ok))) + (format t "DECLARE CURSOR command failed~%") + (pq-clear res) + (exit-nicely conn)) +(pq-clear res) +(setq res (pq-exec conn "FETCH ALL in mycursor")) +(when (or (null res) (not (= (pq-result-status res) pgres-tuples-ok))) + (format t "FETCH ALL command didn't return tuples properly~%") + (pq-clear res) + (exit-nicely conn)) + +;; first, print out the attribute names +(setq nfields (pq-nfields res)) +(dotimes (i nfields) + (format t "~15@<~A~>" (pq-fname res i)) +) +(format t "~%") + +;; next, print out the rows +(setq ntuples (pq-ntuples res)) +(dotimes (i ntuples) + (dotimes (j nfields) + (format t "~15@<~A~>" (pq-getvalue res i j)) + ) + (format t "~%") +) +(pq-clear res) + +;; close the cursor +(setq res (pq-exec conn "CLOSE mycursor")) +(pq-clear res) + +;; commit the transaction +(setq res (pq-exec conn "COMMIT")) +(pq-clear res) + +;; close the connection to the database and cleanup +(pq-finish conn) diff --git a/lisp/test/psql-2.lsp b/lisp/test/psql-2.lsp new file mode 100644 index 0000000..011512c --- /dev/null +++ b/lisp/test/psql-2.lsp @@ -0,0 +1,74 @@ +;; Postgresql C library interface, example program 2, using the xedit +;; lisp interface + +;; Test of the asynchronous notification interface +;; +;; Start this program, then from psql in another window do +;; NOTIFY TBL2; +;; +;; Or, if you want to get fancy, try this: +;; Populate a database with the following: +;; +;; CREATE TABLE TBL1 (i int4); +;; +;; CREATE TABLE TBL2 (i int4); +;; +;; CREATE RULE r1 AS ON INSERT TO TBL1 DO +;; (INSERT INTO TBL2 values (new.i); NOTIFY TBL2); +;; +;; and do +;; +;; INSERT INTO TBL1 values (10); +(require "psql") + +(defun exit-nicely (conn) + (pq-finish conn) + (quit 1) +) + +;; begin, by setting the parameters for a backend connection if the +;; parameters are null, then the system will try to use reasonable +;; defaults by looking up environment variables or, failing that, +;; using hardwired constants +(setq pghost nil) ; host name of the backend server +(setq pgport nil) ; port of the backend server +(setq pgoptions nil) ; special options to start up the backend server +(setq pgtty nil) ; debugging tty for the backend server +(setq pgdbname "test") ; change this to the name of your test database + ;; XXX Note: getenv not yet implemented in the + ; lisp interpreter + +;; make a connection to the database +(setq conn (pq-setdb pghost pgport pgoptions pgtty pgdbname)) + +;; check to see that the backend connection was successfully made +(when (= (pq-status conn) pg-connection-bad) + (format t "Connection to database '~A' failed.~%" pgdbname) + (format t "~A" (pq-error-message conn)) + (exit-nicely conn)) + +(setq res (pq-exec conn "LISTEN TBL2")) +(when (= (pq-status conn) pg-connection-bad) + (format t "LISTEN command failed~%") + (format t "~A" (pq-error-message conn)) + (exit-nicely conn)) + +;; Should PQclear PGresult whenever it is no longer needed to avoid memory leaks +(pq-clear res) + +(loop + ;; wait a little bit between checks; waiting with select() + ;; would be more efficient. + ;; XXX Note: sleep not yet implemented in the lisp interpreter + + ;; collect any asynchronous backend messages + (pq-consume-input conn) + + ;; check for asynchronous notify messages + (when (setq notifies (pq-notifies conn)) + (format t "ASYNC NOTIFY of '~A' from backend pid '~D' received~%" + (pg-notify-relname notifies) (pg-notify-be-pid notifies)) + ) +) + +(pq-finish conn) diff --git a/lisp/test/psql-3.lsp b/lisp/test/psql-3.lsp new file mode 100644 index 0000000..bb172c9 --- /dev/null +++ b/lisp/test/psql-3.lsp @@ -0,0 +1,118 @@ +;; Postgresql C library interface, example program 3, using the xedit +;; lisp interface + +;; Test the binary cursor interface +;; +;; populate a database by doing the following: +;; +;; CREATE TABLE test1 (i int4, d real, p polygon); +;; +;; INSERT INTO test1 values (1, 3.567, polygon '(3.0, 4.0, 1.0, 2.0)'); +;; +;; INSERT INTO test1 values (2, 89.05, polygon '(4.0, 3.0, 2.0, 1.0)'); +;; +;; the expected output is: +;; +;; tuple 0: got i = (4 bytes) 1, d = (4 bytes) 3.567000, p = (4 +;; bytes) 2 points boundbox = (hi=3.000000/4.000000, lo = +;; 1.000000,2.000000) tuple 1: got i = (4 bytes) 2, d = (4 bytes) +;; 89.050003, p = (4 bytes) 2 points boundbox = +;; (hi=4.000000/3.000000, lo = 2.000000,1.000000) + +;; Output of the lisp code: +;; +;; type[0] = 23, size[0] = 4 +;; type[1] = 700, size[1] = 4 +;; type[2] = 604, size[2] = -1 +;; tuple 0: got +;; i = (4 bytes) 1 +;; d = (4 bytes) 3.567 +;; p = (4 bytes) 2 points boundbox = (hi=3.0/4.0, lo = 1.0/2.0) +;; tuple 1: got +;; i = (4 bytes) 2 +;; d = (4 bytes) 89.05 +;; p = (4 bytes) 2 points boundbox = (hi=4.0/3.0, lo = 2.0/1.0) + + +(require "psql") + +(defun exit-nicely (conn) + (pq-finish conn) + (quit 1) +) + +;; begin, by setting the parameters for a backend connection if the +;; parameters are null, then the system will try to use reasonable +;; defaults by looking up environment variables or, failing that, +;; using hardwired constants +(setq pghost nil) ; host name of the backend server +(setq pgport nil) ; port of the backend server +(setq pgoptions nil) ; special options to start up the backend server +(setq pgtty nil) ; debugging tty for the backend server +(setq pgdbname "test") ; change this to the name of your test database + ;; XXX Note: getenv not yet implemented in the + ; lisp interpreter + +;; make a connection to the database +(setq conn (pq-setdb pghost pgport pgoptions pgtty pgdbname)) + +;; check to see that the backend connection was successfully made +(when (= (pq-status conn) pg-connection-bad) + (format t "Connection to database '~A' failed.~%" pgdbname) + (format t "~A" (pq-error-message conn)) + (exit-nicely conn)) + +(setq res (pq-exec conn "BEGIN")) +(when (= (pq-status conn) pg-connection-bad) + (format t "BEGIN command failed~%") + (pq-clear res) + (exit-nicely conn)) + +;; Should PQclear PGresult whenever it is no longer needed to avoid memory leaks +(pq-clear res) + +(setq res (pq-exec conn "DECLARE mycursor BINARY CURSOR FOR select * from test1")) +(when (= (pq-status conn) pg-connection-bad) + (format t "DECLARE CURSOR command failed~%") + (pq-clear res) + (exit-nicely conn)) +(pq-clear res) + +(setq res (pq-exec conn "FETCH ALL in mycursor")) +(when (or (null res) (not (= (pq-result-status res) pgres-tuples-ok))) + (format t "FETCH ALL command didn't return tuples properly~%") + (pq-clear res) + (exit-nicely conn)) + +(setq i-fnum (pq-fnumber res "i")) +(setq d-fnum (pq-fnumber res "d")) +(setq p-fnum (pq-fnumber res "p")) + +(dotimes (i 3) + (format t "type[~D] = ~D, size[~D] = ~D~%" + i (pq-ftype res i) i (pq-fsize res i)) +) + +(dotimes (i (pq-ntuples res)) + (setq i-val (pq-getvalue res i i-fnum 'int32)) + (setq d-val (pq-getvalue res i d-fnum 'float)) + (setq p-val (pq-getvalue res i p-fnum 'pg-polygon)) + (format t "tuple ~D: got~%" i) + (format t " i = (~D bytes) ~D~%" (pq-getlength res i i-fnum) i-val) + (format t " d = (~D bytes) ~D~%" (pq-getlength res i d-fnum) d-val) + (format t " p = (~D bytes) ~D points~,8@Tboundbox = (hi=~F/~F, lo = ~F/~F)~%" + (pq-getlength res i d-fnum) (pg-polygon-num-points p-val) + (pg-point-x (pg-box-high (pg-polygon-boundbox p-val))) + (pg-point-y (pg-box-high (pg-polygon-boundbox p-val))) + (pg-point-x (pg-box-low (pg-polygon-boundbox p-val))) + (pg-point-y (pg-box-low (pg-polygon-boundbox p-val)))) +) +(pq-clear res) + +(setq res (pq-exec conn "CLOSE mycursor")) +(pq-clear res) + +(setq res (pq-exec conn "COMMIT")) +(pq-clear res) + +(pq-finish conn) diff --git a/lisp/test/regex.lsp b/lisp/test/regex.lsp new file mode 100644 index 0000000..64ba572 --- /dev/null +++ b/lisp/test/regex.lsp @@ -0,0 +1,440 @@ +;; +;; Copyright (c) 2002 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/test/regex.lsp,v 1.2 2002/12/11 04:44:28 paulo Exp $ +;; + +;; Basic regex tests. This file is only for xedit lisp and for it's regex +;; library. Note that the regex library used by xedit lisp is not mean't +;; to be fully compatible with most regexes, but to be as fast as possible. +;; This means that some patterns that looks basic may never be matched, +;; but it is expected that almost any pattern can be rewritten to be +;; matched, or in the worst case, it may be required to search in the +;; regions matched by a previous regex. + +(defun re-test (expect &rest arguments &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply #'re-exec arguments)) + (setq error nil))) + (if error + (format t "ERROR: (re-exec~{ ~S~}) => ~S~%" arguments error-value) + (or (equal result expect) + (format t "(re-exec~{ ~S~}) => should be ~S not ~S~%" + arguments expect result)))) + +;; errors only generated for regex compilation (or incorrect arguments) +(defun re-error (&rest arguments &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply #'re-comp arguments)) + (setq error nil))) + (or error + (format t "ERROR: no error for (re-comp~{ ~S~})" arguments))) + +(re-error "") +(re-error "a**") +(re-error "[a") +(re-error "a{") +(re-error "a(") +(re-error "a||b") +(re-error "|b|c") +(re-error "a|b|") + +(setq re (re-comp "abc")) +(re-test '((0 . 3)) re "abc") +(re-test '((0 . 3)) re "abc" :notbol t) +(re-test '((0 . 3)) re "abc" :noteol t) +(re-test '((0 . 3)) re "abc" :notbol t :noteol t) +(re-test '((14 . 17)) re "aaaaaaaaaaaaaaabc") +(re-test '((14 . 17)) re "aaaaaaaaaaaaaaabc" :start 12 :end 17) +(re-test '((30 . 33)) re "xxxxxxxxxxxxxxaaaaaaaaaaaaaaaaabcxx") +(re-test '((30 . 33)) re "xxxxxxxxxxxxxxaaaaaaaaaaaaaaaaabcxx" :start 28 :end 34) + +(setq re (re-comp "^abc")) +(re-test '((0 . 3)) re "abc") +(re-test :nomatch re "xabc") +(re-test '((1 . 4)) re "xabc" :start 1) +(re-test :nomatch re "xabc" :start 1 :notbol t) + +(setq re (re-comp "abc$")) +(re-test '((0 . 3)) re "abc") +(re-test :nomatch re "xabcx") +(re-test '((1 . 4)) re "xabcx" :end 4) +(re-test :nomatch re "xabc" :end 4 :noteol t) + +(setq re (re-comp "^abc$")) +(re-test '((0 . 3)) re "abc") +(re-test :nomatch re "xabcx") +(re-test '((1 . 4)) re "xabcx" :start 1 :end 4) +(re-test :nomatch re "xabcx" :start 1 :end 4 :notbol t) +(re-test :nomatch re "xabcx" :start 1 :end 4 :noteol t) +(re-test :nomatch re "xabcx" :start 1 :end 4 :notbol t :noteol t) +(re-test nil re "abc" :count 0) + +(setq re (re-comp "abc|bcd|cde")) +(re-test '((0 . 3)) re "abc") +(re-test '((1 . 4)) re "aabc") +(re-test '((3 . 6)) re "xxxbcdef") +(re-test '((8 . 11)) re "abdzzzcdabcde") +(re-test '((13 . 16)) re "xxxxabdecdabdcde") + +(setq re (re-comp "^abc|bcd$|cde")) +(re-test '((0 . 3)) re "abcde") +(re-test '((3 . 6)) re "xabcde") +(re-test '((1 . 4)) re "xabcde" :start 1) +(re-test '((3 . 6)) re "xabcde" :start 1 :notbol t) +(re-test '((2 . 5)) re "xabcd") +(re-test :nomatch re "xabcd" :noteol t) +(re-test nil re "xabcd" :count 0) +(re-test :nomatch re "abcdx" :notbol t) + +(setq re (re-comp "a?bc|ab?c|abc?")) +(re-test '((0 . 3)) re "abc") +(re-test :nomatch re "xxxb") +(re-test '((3 . 5)) re "xxxbc") +(re-test '((5 . 7)) re "sssssab") +(re-test '((0 . 3)) re "abcd") +(re-test '((1 . 4)) re "aabcdef") +(re-test '((1 . 3)) re "aabbccdef") ;; ab matches abc? + +(setq re (re-comp "a?bc")) +(re-test '((2 . 4)) re "acbcd") +(re-test '((2 . 5)) re "acabcd") + +(setq re (re-comp "ab?c")) +(re-test '((1 . 3)) re "xacc") +(re-test '((2 . 5)) re "xxabcc") + +(setq re (re-comp "abc?")) +(re-test '((1 . 3)) re "xababc") +(re-test '((2 . 5)) re "xxabccabc") + +(setq re (re-comp "a*bc|ab*c|abc*")) +(re-test '((0 . 9)) re "aaaaaaabc") +(re-test '((1 . 10)) re "xaaaaaaabc") +(re-test '((3 . 12)) re "xyzaaaaaaabc") +(re-test '((0 . 4)) re "abbc") +(re-test '((2 . 9)) re "xxabbbbbc") +(re-test '((0 . 12)) re "abcccccccccc") +(re-test '((0 . 12)) re "abccccccccccd") +(re-test '((16 . 29)) re "xxxxxxxaaaaaaaaaabbbbbbbbbbbccccccccccc") +(re-test '((11 . 13)) re "xxxbbbbbbbbbc") +(re-test '((8 . 10)) re "aaaaazbxacd") + +(setq re (re-comp "a*bc")) +(re-test '((2 . 4)) re "acbcd") +(re-test '((2 . 5)) re "acabcd") +(re-test '((2 . 8)) re "acaaaabcd") + +(setq re (re-comp "ab*c")) +(re-test '((1 . 3)) re "xacc") +(re-test '((2 . 5)) re "xxabcc") +(re-test '((3 . 8)) re "xxaabbbcc") + +(setq re (re-comp "abc*")) +(re-test '((1 . 3)) re "xababc") +(re-test '((2 . 5)) re "xxabcbabccc") +(re-test '((3 . 7)) re "axxabccabc") + +(setq re (re-comp "a+bc|ab+c|abc+")) +(re-test :nomatch re "xxxbc") +(re-test '((1 . 6)) re "xaaabc") +(re-test '((8 . 12)) re "zzzzaaaaabbc") +(re-test '((7 . 15)) re "zzzzaaaabbbbbbcccc") + +(setq re (re-comp "a.c")) +(re-test '((0 . 3)) re "abc") +(re-test '((1 . 4)) re "aaac") +(re-test :nomatch re "xac") +(re-test '((3 . 6)) re "xaxaac") +(re-test '((2 . 5)) re "xxabc") +(re-test '((3 . 6)) re "acxaxc") + +(setq re (re-comp "a*c")) +(re-test '((0 . 1)) re "c") +(re-test '((5 . 6)) re "xxxxxc") +(re-test '((8 . 9)) re "xxxxxxxxc") +(re-test '((7 . 8)) re "xxxxxxxcc") +(re-test '((0 . 2)) re "ac") +(re-test '((0 . 5)) re "aaaac") +(re-test '((1 . 3)) re "xac") +(re-test '((3 . 6)) re "xxxaac") +(re-test '((2 . 4)) re "xxac") +(re-test '((4 . 6)) re "xxxxac") + +(setq re (re-comp "a+c")) +(re-test '((2 . 5)) re "xxaac") +(re-test '((3 . 8)) re "xxxaaaac") +(re-test '((6 . 8)) re "xaaaabac") +(re-test :nomatch re "xxxc") +(re-test '((4 . 9)) re "xxxxaaaaccc") + +(setq re (re-comp "a{4}b")) +(re-test '((19 . 24)) re "xabxxaabxxxaaabxxxxaaaab") +(re-test '((4 . 9)) re "aaabaaaab") + +(setq re (re-comp "a{4,}b")) +(re-test '((3 . 8)) re "xxxaaaab") +(re-test '((8 . 25)) re "zaaabzzzaaaaaaaaaaaaaaaab") + +(setq re (re-comp "a{,4}b")) +(re-test '((0 . 1)) re "b") +(re-test '((8 . 9)) re "xxxxxxxxb") +(re-test '((6 . 11)) re "xaaaaaaaaab") +(re-test '((3 . 5)) re "xxxab") +(re-test '((6 . 10)) re "aaaaaxaaab") + +(setq re (re-comp "a{2,4}b")) +(re-test :nomatch re "xab") +(re-test '((1 . 4)) re "xaab") +(re-test '((1 . 5)) re "xaaab") +(re-test '((2 . 7)) re "xxaaaab") +(re-test '((4 . 9)) re "xxxaaaaab") + +(setq re (re-comp "foo(bar|baz)fee")) +(re-test '((9 . 18)) re "feebarbazfoobarfee") +(re-test '((9 . 18) (12 . 15)) re "feebarbazfoobarfee" :count 2) +(re-test '((13 . 22)) re "foofooobazfeefoobazfee") +(re-test '((13 . 22) (16 . 19)) re "foofooobazfeefoobazfee" :count 3) + +(setq re (re-comp "foo(bar|baz)fee" :nosub t)) +(re-test '((9 . 18)) re "feebarbazfoobarfee") +(re-test '((9 . 18)) re "feebarbazfoobarfee" :count 2) +(re-test '((13 . 22)) re "foofooobazfeefoobazfee") +(re-test '((13 . 22)) re "foofooobazfeefoobazfee" :count 3) + +(setq re (re-comp "f(oo|ee)ba[rz]")) +(re-test :nomatch re "barfoebaz") +(re-test '((3 . 9) (4 . 6)) re "bazfoobar" :count 2) +(re-test '((3 . 9) (4 . 6)) re "barfeebaz" :count 2) + +(setq re (re-comp "f(oo|ee)ba[rz]" :nosub t)) +(re-test :nomatch re "barfoebaz") +(re-test '((3 . 9)) re "bazfoobar" :count 2) +(re-test '((3 . 9)) re "barfeebaz" :count 2) + +(setq re (re-comp "\\<(int|char)\\>")) +(re-test '((15 . 18)) re "aint character int foo") +(re-test '((15 . 18) (15 . 18)) re "aint character int foo" :count 2) + +(setq re (re-comp "\\<(int|char)\\>" :nosub t)) +(re-test '((15 . 18)) re "aint character int foo" :count 2) + +(setq re (re-comp "foo.*bar")) +(re-test '((11 . 17)) re "barfoblaboofoobarfoobarfoobar") + +(setq re (re-comp "foo.+bar")) +(re-test :nomatch re "foobar") +(re-test '((6 . 13)) re "fobbarfooxbarfooybar") + +(setq re (re-comp "foo.?bar")) +(re-test '((1 . 7)) re "xfoobar") +(re-test :nomatch re "xxfooxxbar") +(re-test '((3 . 10)) re "yyyfootbar") + +(setq re (re-comp "a.*b.*c")) +(re-test '((0 . 3)) re "abc") +(re-test '((9 . 18)) re "xxxxxxxxxabbbbbbbccaaaaabbbc") + +(setq re (re-comp "a.+b.*c")) +(re-test :nomatch re "xxxabc") +(re-test '((2 . 7)) re "xxaxbbc") + +(setq re (re-comp "a.+b.?c")) +(re-test '((1 . 5)) re "xaabc") +(re-test '((2 . 7)) re "xxaabbc") + +(setq re (re-comp "(foo.*|bar)fee")) +(re-test '((3 . 9) (3 . 6)) re "barfoofee" :count 2) +(re-test '((0 . 9) (0 . 6)) re "foobarfee" :count 2) +(re-test '((4 . 10) (4 . 7)) re "xxfobarfee" :count 2) +(re-test '((3 . 17) (3 . 14)) re "barfooooooobarfee" :count 2) +(re-test '((4 . 10) (4 . 7)) re "xxfobarfeefoobar" :count 2) + +(setq re (re-comp "(foo.+|bar)fee")) +(re-test :nomatch re "barfoofee" :count 2) +(re-test '((3 . 10) (3 . 7)) re "barfooxfee" :count 2) + +(setq re (re-comp "(foo.?|bar)fee")) +(re-test :nomatch re "foobar" :count 2) +(re-test '((2 . 8) (2 . 5)) re "bafoofee" :count 2) +(re-test '((2 . 9) (2 . 6)) re "bafooofeebarfee" :count 4) +(re-test '((2 . 8) (2 . 5)) re "bafoofeebarfee" :count 2) +(re-test nil re "bafoofeebarfee" :count 0) +(re-test '((2 . 8)) re "bafoofeebarfee" :count 1) + +(setq re (re-comp "(a|b|c)\\1")) +(re-test '((0 . 2) (0 . 1)) re "aa" :count 2) + +(setq re (re-comp "(a|b|c)(a|b|c)\\1\\2")) +(re-test '((0 . 4) (0 . 1) (1 . 2)) re "acac" :count 5) +(re-test '((4 . 8) (4 . 5) (5 . 6)) re "xxxxacac" :count 4) +(re-test '((24 . 28) (24 . 25) (25 . 26)) re "xxacabacbcacbbacbcaaccabcaca" :count 3) +(re-test '((4 . 8) (4 . 5) (5 . 6)) re "xyabcccc" :count 3) +(re-test '((4 . 8) (4 . 5)) re "xyabcccc" :count 2) +(re-test '((4 . 8)) re "xyabcccc" :count 1) +(re-test nil re "xyabcccc" :count 0) + +(setq re (re-comp "(a*b)\\1")) +(re-test '((3 . 15) (3 . 9)) re "xxxaaaaabaaaaab" :count 2) +(re-test '((7 . 9) (7 . 8)) re "abaabaxbb" :count 2) + +(setq re (re-comp "(ab+c)\\1")) +(re-test '((3 . 13) (3 . 8)) re "xaaabbbcabbbc" :count 3) + +(setq re (re-comp "(ab?c)\\1")) +(re-test :nomatch re "abcac" :count 2) +(re-test '((4 . 8) (4 . 6)) re "acabacac" :count 2) +(re-test '((5 . 11) (5 . 8)) re "abcacabcabc" :count 2) +(re-test '((3 . 7) (3 . 5)) re "abcacac" :count 2) + +(setq re (re-comp "a(.*)b\\1")) +(re-test '((3 . 5) (4 . 4)) re "xxxab" :count 2) +(re-test '((4 . 12) (5 . 8)) re "xxxxazzzbzzz" :count 2) + +(setq re (re-comp "abc" :icase t)) +(re-test '((0 . 3)) re "AbC") + +(setq re (re-comp "[0-9][a-z]+" :icase t)) +(re-test '((3 . 10)) re "xxx0aaZxYT9") + +(setq re (re-comp "a.b" :icase t)) +(re-test '((10 . 13)) re "aaaaaaaaaaaxB") + +(setq re (re-comp "a.*z" :icase t)) +(re-test '((3 . 9)) re "xxxAaaaaZ") +(re-test '((2 . 6)) re "xxaaaZaaa") + +(setq re (re-comp "\\<(lambda|defun|defmacro)\\>" :icase t)) +(re-test '((5 . 11)) re " (lambda") +(re-test '((5 . 11) (5 . 11)) re " (lambda" :count 2) +(re-test :nomatch re "lamda defunn deffmacro") + +(setq re (re-comp "\\<(nil|t)\\>" :icase t)) +(re-test '((3 . 6)) re "it Nil") +(re-test '((3 . 6) (3 . 6)) re "it Nil" :count 6) +(re-test :nomatch re "nilo") + +(setq re (re-comp "\\<(begin|end)\\>" :icase t)) +(re-test '((21 . 24) (21 . 24)) re "beginning the ending EnD" :count 7) + +(setq re (re-comp "a.*" :newline t)) +(re-test '((0 . 1)) re "a +aaa") +(re-test '((3 . 4)) re "xyza +aa") + +(setq re (re-comp "a.+" :newline t)) +(re-test '((2 . 5)) re "a +aaa") +(re-test '((5 . 7)) re "xyza +aa") + +(setq re (re-comp "a.?" :newline t)) +(re-test '((0 . 1)) re "a +aaa") +(re-test '((3 . 4)) re "xyza +aa") + +(setq re (re-comp "a.*b.*c" :newline t)) +(re-test '((11 . 14)) re "xxaa +zyacb +abc") +(re-test '((6 . 9)) re "xxxab +abc +c") + +(setq re (re-comp "a.+b.*c" :newline t)) +(re-test '((6 . 10)) re "ab +bc +abbc") + +(setq re (re-comp "a.?b.*c" :newline t)) +(re-test '((4 . 8)) re "ab +cabbc +cc") + +(setq re (re-comp "^foo$" :newline t)) +(re-test '((11 . 14)) re "bar +foobar +foo") +(re-test '((0 . 3)) re "foo +bar +foo +bar") +(re-test '((8 . 11)) re "foo +bar +foo +bar" :notbol t) +(re-test '((8 . 11)) re "foo +bar +foo" :notbol t) +(re-test :nomatch re "foo +bar +foo" :notbol t :noteol t) + +(setq re (re-comp "^\\s*#\\s*(define|include)\\s+.+" :newline t)) +(re-test '((8 . 18)) re "#define +#include x") +(re-test '((8 . 18) (9 . 16)) re "#define +#include x" :count 2) + +(setq re (re-comp "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")) +(re-test '((3 . 259)) re "zzzxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxzzz") + +(setq re (re-comp "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~")) +(re-test '((13 . 333)) re "String here: ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~/") + +(setq re (re-comp "(.*)\\D(\\d+)")) +(re-test '((0 . 6) (0 . 3) (4 . 6)) re "abcW12" :count 3) +(re-test '((0 . 6) (0 . 3)) re "abcW12" :count 2) +(re-test '((0 . 6)) re "abcW12" :count 1) +(re-test nil re "abcW12" :count 0) +(re-test '((0 . 6) (0 . 3) (4 . 6)) re "abcW12abcW12" :count 3) +(re-test '((0 . 6) (0 . 3) (4 . 6)) re "abcW12abcW12a" :count 3) + +(setq re (re-comp ".*\\d")) +(re-test '((0 . 2)) re "a1a1a1aaaaaaa") ; minimal match only + +(setq re (re-comp "(.*)\\d")) +(re-test '((0 . 2) (0 . 1)) re "a1a1a1aaaaaaa" :count 2); minimal match only + +(setq re (re-comp ".*(\\d)")) +(re-test '((0 . 2) (1 . 2)) re "a1a1a1aaaaaaa" :count 2); minimal match only + +;; XXX this very simple pattern was entering an infinite loop +;; actually, this pattern is not supported, just test if is not +;; crashing (not supported because it is not cheap to match variations +;; of the pattern) +(setq re (re-comp "(.*a)?")) +(re-test '((0 . 1)) re "aaaa") ; expected, minimal match +(re-test '((0 . 1) (0 . 1)) re "aaaa" :count 2) diff --git a/lisp/test/stream.lsp b/lisp/test/stream.lsp new file mode 100644 index 0000000..8af4ff6 --- /dev/null +++ b/lisp/test/stream.lsp @@ -0,0 +1,807 @@ +;; +;; Copyright (c) 2002 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/test/stream.lsp,v 1.4 2002/12/10 03:59:04 paulo Exp $ +;; + +;; most format tests from the cltl second edition samples + +;; basic io/format/pathname/stream tests + +(defun do-format-test (error-test expect arguments + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply #'format nil arguments)) + (setq error nil) + ) + ) + (if error-test + (or error + (format t "ERROR: no error for (format nil~{ ~S~}), result was ~S~%" + arguments result)) + (if error + (format t "ERROR: (format nil~{ ~S~}) => ~S~%" arguments error-value) + (or (string= result expect) + (format t "(format nil~{ ~S~}) => should be ~S not ~S~%" + arguments expect result))) + ) +) + +(defun format-test (expect &rest arguments) + (do-format-test nil expect arguments)) + +(defun format-error (&rest arguments) + (do-format-test t nil arguments)) + + + +(defun compare-test (test expect function arguments + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value) + (or (funcall test result expect) + (format t "(~S~{ ~S~}) => should be ~S not ~S~%" + function arguments expect result + ) + ) + ) +) + +(defun compare-eval (test expect form + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: ~S => ~S~%" form error-value) + (or (funcall test result expect) + (format t "~S => should be ~S not ~S~%" + form expect result + ) + ) + ) +) + +(defun error-test (function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + (or error + (format t "ERROR: no error for (~S~{ ~S~}), result was ~S~%" + function arguments result) + ) +) + +(defun error-eval (form &aux result (error t)) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + (or error + (format t "ERROR: no error for ~S, result was ~S~%" form result) + ) +) + +(defun eq-test (expect function &rest arguments) + (compare-test #'eq expect function arguments)) + +(defun eql-test (expect function &rest arguments) + (compare-test #'eql expect function arguments)) + +(defun equal-test (expect function &rest arguments) + (compare-test #'equal expect function arguments)) + +(defun equalp-test (expect function &rest arguments) + (compare-test #'equalp expect function arguments)) + +(defun eq-eval (expect form) + (compare-eval #'eq expect form)) + +(defun eql-eval (expect form) + (compare-eval #'eql expect form)) + +(defun equal-eval (expect form) + (compare-eval #'equal expect form)) + +(defun equalp-eval (expect form) + (compare-eval #'equalp expect form)) + +(defun bool-test (expect function &rest arguments + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value) + (or (eq (null result) (null expect)) + (format t "(~S~{ ~S~}) => should be ~A not ~A~%" + function arguments expect result + ) + ) + ) +) + +(defun bool-eval (expect form &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: ~S => ~S~%" form error-value) + (or (eq (null result) (null expect)) + (format t "~S => should be ~A not ~A~%" + form expect result + ) + ) + ) +) + + +;; format - function + +;; ~c +(format-test "A" "~C" #\A) +(format-test " " "~C" #\Space) +(format-test "A" "~:C" #\A) +(format-test "Space" "~:C" #\Space) +(format-test "#\\A" "~@C" #\A) +(format-test "#\\Space" "~@C" #\Space) +(format-test " " "~A" #\Space) +(let ((*print-escape* t)) (format-test " " "~A" #\Space)) +(format-test "#\\Space" "~S" #\Space) +(let ((*print-escape* nil)) (format-test "#\\Space" "~S" #\Space)) + +;; ~% +(format-test " +" "~%") +(format-test " + + +" "~3%") + +;; ~& +(format-test "" "~&") +(format-test " +" "~2&") + +;; ~| +(format-test " " "~|") + +;; ~~ +(format-test "~~~" "~3~") + +;; radix +(format-test "1101" "~,,' ,4:B" 13) +(format-test "1 0001" "~,,' ,4:B" 17) +(format-test "1101 0000 0101" "~14,,' ,4:B" 3333) +(format-test "1 22" "~3,,,' ,2:R" 17) +(format-test "6|55|35" "~,,'|,2:D" #xFFFF) +(format-test "1,000,000" "~,,,3:D" 1000000) +(format-test "one hundred and twenty-three thousand, four hundred and fifty-six" + "~R" 123456) +(format-test "six hundred and fifty-four thousand, three hundred twenty-first" + "~:R" 654321) +(format-test "MCCXXXIV" "~@R" 1234) +(format-test "MCCXXXXVIIII" "~@:R" 1249) +(format-test "3039" "~X" 12345) +(format-test "30071" "~O" 12345) +(format-test "9IX" "~36R" 12345) +(format-test "11000000111001" "~B" 12345) +(format-test "The answer is 5." "The answer is ~D." 5) +(format-test "The answer is 5." "The answer is ~3D." 5) +(format-test "The answer is 005." "The answer is ~3,'0D." 5) +(format-test "1111 1010 1100 1110" "~,,' ,4:B" #xFACE) +(format-test "1 1100 1110" "~,,' ,4:B" #x1CE) +(format-test "1111 1010 1100 1110" "~19,,' ,4:B" #xFACE) +(format-test " 1 1100 1110" "~19,,' ,4:B" #x1CE) + +;; 6.37 and 6.38 are correct +#+xedit (format-test "6.38" "~4,2F" 6.375d0) +(format-test "10.0" "~,1F" 9.995d0) +;; 6.37E+2 and 6.38E+2 are correct +#+xedit (format-test " 6.38E+2" "~8,2E" 637.5) +(do* + ( + (n '(3.14159 -3.14159 100.0 1234.0 0.006) (cdr n)) + (r '(" 3.14| 31.42| 3.14|3.1416|3.14|3.14159" + " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" + "100.00|******|100.00| 100.0|100.00|100.0" + "1234.00|******|??????|1234.0|1234.00|1234.0" + " 0.01| 0.06| 0.01| 0.006|0.01|0.006") (cdr r)) + (x (car n) (car n)) + ) + ((endp n)) + (format-test (car r) + "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" x x x x x x) +) +(do* + ( + (n '(3.14159 -3.14159 1100.0 1.1e13 #+xedit 1.1e120) (cdr n)) + (r '(" 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" + " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" + " 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3" + "*********| 11.00$+12|+.001E+16| 1.10E+13" + #+xedit + "*********|??????????|%%%%%%%%%|1.10E+120") (cdr r)) + (x (car n) (car n)) + ) + ((endp n)) + (format-test (car r) + "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" x x x x) +) +(do + ( + (k -5 (1+ k)) + (r '("Scale factor -5: | 0.000003E+06|" + "Scale factor -4: | 0.000031E+05|" + "Scale factor -3: | 0.000314E+04|" + "Scale factor -2: | 0.003142E+03|" + "Scale factor -1: | 0.031416E+02|" + "Scale factor 0: | 0.314159E+01|" + "Scale factor 1: | 3.141590E+00|" + "Scale factor 2: | 31.41590E-01|" + "Scale factor 3: | 314.1590E-02|" + "Scale factor 4: | 3141.590E-03|" + "Scale factor 5: | 31415.90E-04|" + "Scale factor 6: | 314159.0E-05|" + "Scale factor 7: | 3141590.E-06|") (cdr r)) + ) + ((endp r)) + (format-test (car r) "Scale factor ~2D: | ~12,6,2,VE|" k k 3.14159) +) +(do* + ( + (n '(0.0314159 0.314159 3.14159 31.4159 314.159 3141.59 3.14E12 + #+xedit 3.14d120) (cdr n)) + (r '(" 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" + " 0.31 |0.314 |0.314 | 0.31 " + " 3.1 | 3.14 | 3.14 | 3.1 " + " 31. | 31.4 | 31.4 | 31. " + " 3.14E+2| 314. | 314. | 3.14E+2" + " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3" + "*********|314.0$+10|0.314E+13| 3.14E+12" + #+xedit "*********|?????????|%%%%%%%%%|3.14E+120") (cdr r)) + (x (car n) (car n)) + ) + ((endp n)) + (format-test (car r) "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" + x x x x) +) +(format-test " 1." "~4,0f" 0.5) +(format-test " 0." "~4,0f" 0.4) + +;; ~p +(setq n 3) +(format-test "3 items found.""~D item~:P found." n) +(format-test "three dogs are here." "~R dog~:[s are~; is~] here." n (= n 1)) +(format-test "three dogs are here." "~R dog~:*~[s are~; is~:;s are~] here." n) +(format-test "Here are three puppies.""Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n) +(format-test "7 tries/1 win" "~D tr~:@P/~D win~:P" 7 1) +(format-test "1 try/0 wins" "~D tr~:@P/~D win~:P" 1 0) +(format-test "1 try/3 wins" "~D tr~:@P/~D win~:P" 1 3) + +;; ~t +(format-test " foo" "~8Tfoo") +#+xedit (format-test " foo" "~8,3Tfoo") +(format-test " foo" "~8,3@Tfoo") +(format-test " foo" "~1,3@Tfoo") + +;; ~* +(format-test "2" "~*~D" 1 2 3 4) +(format-test "4" "~3*~D" 1 2 3 4) +(format-test "2" "~3*~2:*~D" 1 2 3 4) +(format-test "4 3 2 1 2 3 4" "~3@*~D ~2@*~D ~1@*~D ~0@*~D ~D ~D ~D" 1 2 3 4) + +;; ~? +(format-test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5) 7) +(format-test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) +(format-test "<Foo 5> 7" "~@? ~D" "<~A ~D>" "Foo" 5 7) +(format-test "<Foo 5> 14" "~@? ~D" "<~A ~D>" "Foo" 5 14 7) + + +(format-error "~:[abc~:@(def~;ghi~:@(jkl~]mno~)" 1) +(format-error "~?ghi~)" "abc~@(def") + + +;; ~(...~) +(format-test "XIV xiv" "~@R ~(~@R~)" 14 14) +(format-test "Zero errors detected." "~@(~R~) error~:P detected." 0) +(format-test "One error detected." "~@(~R~) error~:P detected." 1) +(format-test "Twenty-three errors detected." "~@(~R~) error~:P detected." 23) + +;; ~[...~] +(format-test "Persian Cat" "~[Siamese~;Manx~;Persian~] Cat" 2) +(format-test " Cat" "~[Siamese~;Manx~;Persian~] Cat" 3) +(format-test "Siamese Cat" "~[Siamese~;Manx~;Persian~] Cat" 0) +(setq *print-level* nil *print-length* 5) +(format-test " print length = 5" + "~@[ print level = ~D~]~@[ print length = ~D~]" *print-level* *print-length*) +(setq foo "Items:~#[ none~; ~S~; ~S and ~S~:;~@{ ~#[~;and ~]~S~^,~}~].") +(format-test "Items: none." foo) +(format-test "Items: FOO." foo 'foo) +(format-test "Items: FOO and BAR." foo 'foo 'bar) +(format-test "Items: FOO, BAR, and BAZ." foo 'foo 'bar 'baz) +(format-test "Items: FOO, BAR, BAZ, and QUUX." foo 'foo 'bar 'baz 'quux) + +;; ~{...~} +(format-test "The winners are: FRED HARRY JILL." + "The winners are:~{ ~S~}." '(fred harry jill)) +(format-test "Pairs: <A,1> <B,2> <C,3>." "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) +(format-test "Pairs: <A,1> <B,2> <C,3>." + "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) +(format-test "Pairs: <A,1> <B,2> <C,3>." + "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) + +;; ~<...~> +(format-test "foo bar" "~10<foo~;bar~>") +(format-test " foo bar" "~10:<foo~;bar~>") +(format-test " foo bar " "~10:@<foo~;bar~>") +(format-test " foobar" "~10<foobar~>") +(format-test " foobar" "~10:<foobar~>") +(format-test "foobar " "~10@<foobar~>") +(format-test " foobar " "~10:@<foobar~>") + +;; ~^ +(setq donestr "Done.~^ ~D warning~:P.~^ ~D error~:P.") +(format-test "Done." donestr) +(format-test "Done. 3 warnings." donestr 3) +(format-test "Done. 1 warning. 5 errors." donestr 1 5) +(format-test "/HOT .../HAMBURGER/ICE .../FRENCH ..." + "~:{/~S~^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) +(format-test "/HOT .../HAMBURGER .../ICE .../FRENCH" + "~:{/~S~:^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) +(format-test "/HOT .../HAMBURGER" + "~:{/~S~:#^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) +(setq tellstr "~@(~@[~R~]~^ ~A.~)") +(format-test "Twenty-three" tellstr 23) +(format-test " Losers." tellstr nil "losers") +(format-test "Twenty-three losers." tellstr 23 "losers") +(format-test " FOO" "~15<~S~;~^~S~;~^~S~>" 'foo) +(format-test "FOO BAR" "~15<~S~;~^~S~;~^~S~>" 'foo 'bar) +(format-test "FOO BAR BAZ" "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz) + + +;; make-pathname - function +(equal-test #P"/public/games/chess.db" + #'make-pathname :directory '(:absolute "public" "games") + :name "chess" :type "db") +(equal-test #P"/etc/passwd" #'list* #P"/etc/passwd") +(setq path (make-pathname :directory '(:absolute "public" "games") + :name "chess" :type "db")) +(eq-test path #'pathname path) +(eq-test nil #'pathname-host path) +(eq-test nil #'pathname-device path) +(equal-test '(:absolute "public" "games") #'pathname-directory path) +(equal-test "chess" #'pathname-name path) +(equal-test "db" #'pathname-type path) +(eq-test nil #'pathname-version path) +(equal-test #P"/tmp/foo.txt" #'make-pathname :defaults "/tmp/foo.txt") + +#+xedit (equal-test #P"/tmp/foo.txt" #'pathname "///tmp///foo.txt") +;; XXX changed to remove extra separators +;; (equal-test #P"///tmp///foo.txt" #'pathname "///tmp///foo.txt") + + +;; merge-pathnames - function +(equal-test #P"/tmp/foo.txt" #'merge-pathnames "/tmp/foo" "/tmp/foo.txt") +(equal-test #P"/tmp/foo.txt" #'merge-pathnames "foo" "/tmp/foo.txt") +(equal-test #P"/tmp/foo/bar.txt" #'merge-pathnames "foo/bar" "/tmp/foo.txt") + +;; namestring - function +(setq path (merge-pathnames "foo/bar" "/tmp/foo.txt")) +(equal-test "/tmp/foo/bar.txt" #'namestring path) +(equal-test "" #'host-namestring path) +(equal-test "/tmp/foo/" #'directory-namestring path) +(equal-test "bar.txt" #'file-namestring path) +(equal-test "/tmp/foo/bar.txt" #'enough-namestring path) +(equal-test "foo/bar.txt" #'enough-namestring path "/tmp/") +(equal-test "bar.txt" #'enough-namestring path "/tmp/foo/") +(equal-test "foo/bar.txt" #'enough-namestring path "/tmp/foo") + +;; parse-namestring - function +(equal-eval '(#P"foo" 3) '(multiple-value-list (parse-namestring "foo"))) +(equal-eval '(#P"foo" 0) '(multiple-value-list (parse-namestring #P"foo"))) + + + +;; read - function +(setq is (make-string-input-stream " foo ")) +(eq-test t #'streamp is) +(eq-test t #'input-stream-p is) +(eq-test nil #'output-stream-p is) +(eq-test 'foo #'read is) +(eq-test t #'close is) +(setq is (make-string-input-stream "xfooy" 1 4)) +(eq-test 'foo #'read is) +(eq-test t #'close is) +(setq is (make-string-input-stream "")) +(eq-test nil #'read is nil) +(eq-test 'end-of-string #'read is nil 'end-of-string) +(close is) +(error-test #'read is) +(error-test #'read is nil) +(error-test #'read is nil 'end-of-string) +(eq-test t #'streamp is) +(eq-test nil #'input-stream-p is) +(eq-test nil #'streamp "test") +(error-test #'input-stream-p "test") + +;; read-char - function +(setq is (make-string-input-stream "0123")) +(setq test nil) +(equal-eval '(#\0 #\1 #\2 #\3) + '(do ((c (read-char is) (read-char is nil 'the-end))) + ((not (characterp c)) test) + (setq test (append test (list c))))) +(close is) +(setq is (make-string-input-stream "abc")) +(eql-test #\a #'read-char is) +(eql-test #\b #'read-char is) +(eql-test #\c #'read-char is) +(error-test #'read-char is) +(eq-test nil #'read-char is nil) +(eq-test :end-of-string #'read-char is nil :end-of-string) +(eq-test t #'close is) + +;; read-char-no-hang - function +(setq is (make-string-input-stream "0123")) +(setq test nil) +(equal-eval '(#\0 #\1 #\2 #\3) + '(do ((c (read-char-no-hang is) (read-char-no-hang is nil 'the-end))) + ((not (characterp c)) test) + (setq test (append test (list c))))) +(close is) +(setq is (make-string-input-stream "abc")) +(eql-test #\a #'read-char-no-hang is) +(eql-test #\b #'read-char-no-hang is) +(eql-test #\c #'read-char-no-hang is) +(error-test #'read-char-no-hang is) +(eq-test nil #'read-char-no-hang is nil) +(eq-test :end-of-string #'read-char-no-hang is nil :end-of-string) +(eq-test t #'close is) +#+(and xedit unix) +(progn + ;; wait one second for input pooling every 0.1 seconds + (defun wait-for-cat () + (let ((time 0.0)) + (loop + (and (listen is) (return)) + (sleep 0.1) + (when (>= (incf time 0.1) 1.0) + (format t "Cat is sleeping~%") + (return))))) + (setq is (make-pipe "/bin/cat" :direction :io)) + (equal-test "dog" #'write-line "dog" is) + (wait-for-cat) + (eql-test #\d #'read-char-no-hang is) + (eql-test #\o #'read-char-no-hang is) + (eql-test #\g #'read-char-no-hang is) + (eql-test #\Newline #'read-char-no-hang is) + (eq-test nil #'read-char-no-hang is) + (eq-test nil #'read-char-no-hang is) + (equal-test "mouse" #'write-line "mouse" is) + (wait-for-cat) + (eql-test #\m #'read-char-no-hang is) + (eql-test #\o #'read-char-no-hang is) + (eql-test #\u #'read-char-no-hang is) + (eql-test #\s #'read-char-no-hang is) + (eql-test #\e #'read-char-no-hang is) + (eql-test #\Newline #'read-char-no-hang is) + (eq-test nil #'read-char-no-hang is) + (eq-test t #'close is) + (error-test #'read-char-no-hang is) + (error-test #'read-char-no-hang is nil) + (error-test #'read-char-no-hang is nil t) +) + +;; read-from-string - function +(equal-eval '(3 5) + '(multiple-value-list (read-from-string " 1 3 5" t nil :start 2))) +(equal-eval '((a b c) 7) + '(multiple-value-list (read-from-string "(a b c)"))) +(error-test #'read-from-string "") +(eq-test nil #'read-from-string "" nil) +(eq-test 'end-of-file #'read-from-string "" nil 'end-of-file) + +;; read-line - function +(setq is (make-string-input-stream "line 1 +line 2")) +(equal-eval '("line 1" nil) '(multiple-value-list (read-line is))) +(equal-eval '("line 2" t) '(multiple-value-list (read-line is))) +(error-test #'read-line is) +(equal-eval '(nil t) '(multiple-value-list (read-line is nil))) +(equal-eval '(end-of-string t) + '(multiple-value-list (read-line is nil 'end-of-string))) + + +;; write - function +;; XXX several write options still missing +(setq os (make-string-output-stream)) +(equal-test '(1 2 3 4) #'write '(1 2 3 4) :stream os) +(equal-test "(1 2 3 4)" #'get-output-stream-string os) +(eq-test t #'streamp os) +(eq-test t #'output-stream-p os) +(eq-test nil #'input-stream-p os) +(equal-test '(:foo :bar) #'write '(:foo :bar) :case :downcase :stream os) +(equal-test "(:foo :bar)" #'get-output-stream-string os) +(equal-test '(:foo :bar) #'write '(:foo :bar) :case :capitalize :stream os) +(equal-test "(:Foo :Bar)" #'get-output-stream-string os) +(equal-test '(:foo :bar) #'write '(:foo :bar) :case :upcase :stream os) +(equal-test "(:FOO :BAR)" #'get-output-stream-string os) +(equal-test '(foo bar baz) #'write '(foo bar baz) :length 2 :stream os) +(equal-test "(FOO BAR ...)" #'get-output-stream-string os) +(equal-test '(foo (bar) baz) #'write '(foo (bar) baz) :level 1 :stream os) +(equal-test "(FOO # BAZ)" #'get-output-stream-string os) +(setq circle '#1=(1 #1#)) +(eq-test circle #'write circle :circle t :stream os) +(equal-test "#1=(1 #1#)" #'get-output-stream-string os) +(eql-test #\Space #'write #\Space :stream os) +(equal-test "#\\Space" #'get-output-stream-string os) +(eql-test #\Space #'write #\Space :escape nil :stream os) +(equal-test " " #'get-output-stream-string os) +(eq-test t #'close os) +(eq-test nil #'output-stream-p os) +(error-test #'output-stream-p "test") +(error-test #'write 'foo :stream "bar") + +;; fresh-line - function +(setq os (make-string-output-stream)) +(equal-test "some text" #'write-string "some text" os) +(eq-test t #'fresh-line os) +(eq-test nil #'fresh-line os) +(equal-test "more text" #'write-string "more text" os) +(equal-test "some text +more text" #'get-output-stream-string os) +(equal-test nil #'fresh-line os) +(equal-test nil #'fresh-line os) +(equal-test "" #'get-output-stream-string os) +(close os) +(error-test #'fresh-line 1) + +;; prin1 - function +;; (prin1 object stream) == +;; (write object :stream stream :escape t) +(setq p-os (make-string-output-stream) w-os (make-string-output-stream)) +(dolist (object (list #\a 1 "string" 2.5d0 '(a . b) '(a b c) #P"foo" + *package* *standard-input* #c(1 2) #(1 2 3) + (make-hash-table))) + (eq-test object #'prin1 object p-os) + (eq-test object #'write object :stream w-os :escape t) + (equal-test (get-output-stream-string p-os) + #'get-output-stream-string w-os)) +(close p-os) +(close w-os) +(error-test #'prin1 1 1) + +;; princ - function +;; (princ object stream) == +;; (write object :stream stream :escape nil :readably nil) +;; XXX readably not yet implemented +(setq p-os (make-string-output-stream) w-os (make-string-output-stream)) +(dolist (object (list #\a 1 "string" 2.5d0 '(a . b) '(a b c) #P"foo" + *package* *standard-input* #c(1 2) #(1 2 3) + (make-hash-table))) + (eq-test object #'princ object p-os) + (eq-test object #'write object :stream w-os :escape nil) + (equal-test (get-output-stream-string p-os) + #'get-output-stream-string w-os)) +(close p-os) +(close w-os) +(error-test #'princ 1 1) + +;; print - function +;; (print object stream) == +;; (progn +;; (terpri stream) +;; (write object :stream stream :escape t) +;; (write-char #\Space stream)) +(setq p-os (make-string-output-stream) w-os (make-string-output-stream)) +(dolist (object (list #\a 1 "string" 2.5d0 '(a . b) '(a b c) #P"foo" + *package* *standard-input* #c(1 2) #(1 2 3) + (make-hash-table))) + (eq-test object #'print object p-os) + (progn + (eq-test nil #'terpri w-os) + (eq-test object #'write object :stream w-os :escape t) + (eql-test #\Space #'write-char #\Space w-os)) + (equal-test (get-output-stream-string p-os) + #'get-output-stream-string w-os)) +(close p-os) +(close w-os) +(error-test #'print 1 1) + +;; terpri - function +(setq os (make-string-output-stream)) +(equal-test "some text" #'write-string "some text" os) +(eq-test nil #'terpri os) +(eq-test nil #'terpri os) +(equal-test "more text" #'write-string "more text" os) +(equal-test "some text + +more text" #'get-output-stream-string os) +(equal-test nil #'terpri os) +(equal-test nil #'terpri os) +(equal-test " + +" #'get-output-stream-string os) +(close os) +(error-test #'terpri 1) + +;; write-char - function +(equal-eval "a b" + '(with-output-to-string (s) + (write-char #\a s) + (write-char #\Space s) + (write-char #\b s))) +(error-test #'write-char 1) + +;; write-line - function +(setq os (make-string-output-stream)) +(equal-test "text" #'write-line "text" os) +(equal-test "text +" #'get-output-stream-string os) +(eql-test #\< #'write-char #\< os) +(equal-test "text" #'write-line "text" os :start 1 :end 3) +(eql-test #\> #'write-char #\> os) +(equal-test "<ex +>" #'get-output-stream-string os) +(error-test #'write-line 1) +(close os) + +;; write-string - function +(setq os (make-string-output-stream)) +(equal-test "text" #'write-string "text" os) +(equal-test "text" #'get-output-stream-string os) +(eql-test #\< #'write-char #\< os) +(equal-test "text" #'write-string "text" os :start 1 :end 3) +(eql-test #\> #'write-char #\> os) +(equal-test "<ex>" #'get-output-stream-string os) +(error-test #'write-string #\a) +(close os) + + +;; open - function +(setq name #P"delete-me.text") +(bool-eval t '(setq file (open name :direction :output))) +(equal-test "some text" #'write-line "some text" file) +(close file) +(equal-test "delete-me.text" #'file-namestring (truename name)) +(setq file (open name :direction :output :if-exists :rename)) +(equal-test "other text" #'write-line "other text" file) +(close file) +(equal-test "delete-me.text" #'file-namestring (truename name)) +;; Clisp returns the pathname if the file exists +#+xedit (eq-test t #'delete-file name) +#+clisp (bool-test t #'delete-file name) +(setq backup + #+xedit "delete-me.text~" + #+clisp "delete-me.text%" + #+cmu "delete-me.text.BAK") +(bool-test t #'delete-file backup) +(eq-test nil #'delete-file name) +(eq-test nil #'directory name) +(eq-test nil #'directory backup) +;; test append +(with-open-file (s name :direction :output :if-exists :error) + (write-line "line 1" s)) +(with-open-file (s name :direction :output :if-exists :append) + (write-line "line 2" s)) +(with-open-file (s name :direction :input) + (equal-test "line 1" #'read-line s) + (equal-test "line 2" #'read-line s) + (eq-test 'eof #'read-line s nil 'eof) +) +(bool-test t #'delete-file name) +;; test overwrite +(with-open-file (s name :direction :output :if-exists :error) + (write-line "overwrite-me" s)) +(with-open-file (s name :direction :output :if-exists :overwrite) + (write-line "some-text" s)) +(with-open-file (s name :direction :input) + (equal-test "some-text" #'read-line s) + (eq-test 'eof #'read-line s nil 'eof)) +;; test check for file existence +(eq-test nil #'open name :direction :output :if-exists nil) +(error-test #'open name :direction :output :if-exists :error) +(bool-test t #'delete-file name) +;; test check for no file existence +(eq-test nil #'open name :direction :output :if-does-not-exist nil) +(error-test #'open name :direction :output :if-does-not-exist :error) +#+xedit ;; test io -- not sure if this is the expected behaviour +(progn + (with-open-file (s name :direction :io) + (write-line "foo" s) + (write-line "bar" s)) + (with-open-file (s name :direction :io :if-exists :append) + (equal-test "foo" #'read-line s) + (equal-test "bar" #'read-line s) + (eq-test 'eof #'read-line s nil 'eof) + (write-line "baz" s)) + (with-open-file (s name :direction :io :if-exists :append) + (equal-test "foo" #'read-line s) + (equal-test "bar" #'read-line s) + (equal-test "baz" #'read-line s) + (eq-test 'eof #'read-line s nil 'eof)) + (bool-test t #'delete-file name) +) + +;; delete-file - function +(eq-eval nil + '(with-open-file (s "delete-me.text" :direction :output :if-exists :error))) +(eq-test t #'pathnamep (setq p (probe-file "delete-me.text"))) +(bool-test t #'delete-file p) +(eq-test nil #'probe-file "delete-me.text") +(bool-eval t + '(with-open-file (s "delete-me.text" :direction :output :if-exists :error) + (delete-file s))) +(bool-test nil #'probe-file "delete-me.text") + +;; rename-file - function +(setq name "foo.bar") +(bool-eval t '(setq file (open name :direction :output :if-exists :error))) +(eq-test t #'close file) +(setq result (multiple-value-list (rename-file name "bar.foo"))) +(eql-test 3 #'length result) +(eq-test t #'pathnamep (first result)) +(eq-test t #'pathnamep (second result)) +(eq-test t #'pathnamep (third result)) +(equal-test (third result) #'truename "bar.foo") +(eq-test nil #'directory name) +(eq-test nil #'directory (second result)) +(equal-test (list (third result)) #'directory (third result)) +(error-test #'truename name) +(error-test #'truename (second result)) +(eq-test nil #'probe-file name) +(bool-test t #'probe-file (first result)) +(eq-test nil #'probe-file (second result)) +(bool-test t #'probe-file (third result)) +(bool-test t #'delete-file "bar.foo") +(eq-test nil #'delete-file (third result)) +(eq-test nil #'delete-file (second result)) diff --git a/lisp/test/widgets.lsp b/lisp/test/widgets.lsp new file mode 100644 index 0000000..be68788 --- /dev/null +++ b/lisp/test/widgets.lsp @@ -0,0 +1,71 @@ +;; +;; 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/test/widgets.lsp,v 1.3 2002/11/08 08:01:01 paulo Exp $ +;; +(require "xaw") +(require "xt") + +(defun quit-callback (widget user call) (quit)) + +(setq toplevel + (xt-app-initialize 'appcontext "Widgets" + '(("title" . "Widgets (without customization)")))) + +(setq vpane + (xt-create-managed-widget "vpane" paned-widget-class toplevel)) +(setq form + (xt-create-managed-widget "form" form-widget-class vpane)) +(xt-create-managed-widget "command" command-widget-class form + '(("label" . "Command Widget"))) +(xt-create-managed-widget "label" label-widget-class form + '(("label" . "Label Widget") ("fromVert" . "command"))) +(xt-create-managed-widget "button" menu-button-widget-class form + '(("label" . "MenuButton Widget") ("fromVert" . "label"))) + +(setq popup + (xt-create-managed-widget "menu" simple-menu-widget-class toplevel)) +(xt-create-managed-widget "smebsb" sme-bsb-object-class popup + '(("label" . "SmeBSB Object"))) +(xt-create-managed-widget "smeline" sme-line-object-class popup) +(xt-create-managed-widget "smebsb2" sme-bsb-object-class popup + '(("label" . "SmeBSB Object two"))) + +(xt-create-managed-widget "toggle" toggle-widget-class form + '(("label" . "Toggle Widget") ("fromVert" . "button"))) +(xt-create-managed-widget "repeater" repeater-widget-class form + '(("label" . "Repeater Widget") ("fromVert" . "toggle"))) + +(setq quit + (xt-create-managed-widget "quit" command-widget-class vpane + '(("label" . "Quit")))) +(xt-add-callback quit "callback" 'quit-callback) + +(xt-realize-widget toplevel) +(xt-app-main-loop appcontext) diff --git a/lisp/time.c b/lisp/time.c new file mode 100644 index 0000000..3c21d00 --- /dev/null +++ b/lisp/time.c @@ -0,0 +1,138 @@ +/* + * 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/time.c,v 1.7 2002/11/08 08:00:57 paulo Exp $ */ + +#include "time.h" +#include "bytecode.h" + +/* + * Implementation +*/ +LispObj * +Lisp_Time(LispBuiltin *builtin) +/* + time form + */ +{ + struct itimerval real, virt, prof; + unsigned long count; + long sec, usec; + LispObj *result; +#define MONTH 60 * 60 * 31 + + LispObj *form; + + form = ARGUMENT(0); + + real.it_value.tv_sec = + virt.it_value.tv_sec = + prof.it_value.tv_sec = + real.it_interval.tv_sec = + virt.it_interval.tv_sec = + prof.it_interval.tv_sec = MONTH; + real.it_value.tv_usec = + virt.it_value.tv_usec = + prof.it_value.tv_usec = + real.it_interval.tv_usec = + virt.it_interval.tv_usec = + prof.it_interval.tv_usec = 0; + + setitimer(ITIMER_REAL, &real, NULL); + setitimer(ITIMER_VIRTUAL, &virt, NULL); + setitimer(ITIMER_PROF, &prof, NULL); + + getitimer(ITIMER_REAL, &real); + getitimer(ITIMER_VIRTUAL, &virt); + getitimer(ITIMER_PROF, &prof); + + lisp__data.gc.gctime = 0; + lisp__data.gc.timebits = 1; + + count = lisp__data.gc.count; + +#if 0 + form = CONS(form, NIL); + COD = CONS(form, COD); + result = LispExecuteBytecode(LispCompileForm(form)); +#else + result = EVAL(form); +#endif + + getitimer(ITIMER_REAL, &real); + getitimer(ITIMER_VIRTUAL, &virt); + getitimer(ITIMER_PROF, &prof); + + sec = real.it_interval.tv_sec - real.it_value.tv_sec; + usec = real.it_interval.tv_usec - real.it_value.tv_usec; + if (usec < 0) { + --sec; + usec += 1000000; + } + LispMessage("Real time : %g sec", sec + usec / 1000000.0); + + sec = virt.it_interval.tv_sec - virt.it_value.tv_sec; + usec = virt.it_interval.tv_usec - virt.it_value.tv_usec + 10000; + if (usec < 0) { + --sec; + usec += 1000000; + } + LispMessage("Virtual time: %g sec", sec + usec / 1000000.0); + + sec = prof.it_interval.tv_sec - prof.it_value.tv_sec; + usec = prof.it_interval.tv_usec - prof.it_value.tv_usec + 10000; + if (usec < 0) { + --sec; + usec += 1000000; + } + LispMessage("Profile time: %g sec", sec + usec / 1000000.0); + + real.it_value.tv_sec = + virt.it_value.tv_sec = + prof.it_value.tv_sec = + real.it_interval.tv_sec = + virt.it_interval.tv_sec = + prof.it_interval.tv_sec = + real.it_value.tv_usec = + virt.it_value.tv_usec = + prof.it_value.tv_usec = + real.it_interval.tv_usec = + virt.it_interval.tv_usec = + prof.it_interval.tv_usec = 0; + + setitimer(ITIMER_REAL, &real, NULL); + setitimer(ITIMER_VIRTUAL, &virt, NULL); + setitimer(ITIMER_PROF, &prof, NULL); + + LispMessage("GC: %ld times, %g sec", + lisp__data.gc.count - count, lisp__data.gc.gctime / 1000000.0); + lisp__data.gc.timebits = 0; + + return (result); +} diff --git a/lisp/time.h b/lisp/time.h new file mode 100644 index 0000000..3d07916 --- /dev/null +++ b/lisp/time.h @@ -0,0 +1,39 @@ +/* + * 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/time.h,v 1.3 2002/11/08 08:00:57 paulo Exp $ */ + +#ifndef Lisp_time_h +#define Lisp_time_h + +#include "private.h" + +LispObj *Lisp_Time(LispBuiltin*); + +#endif /* Lisp_time_h */ diff --git a/lisp/write.c b/lisp/write.c new file mode 100644 index 0000000..4952119 --- /dev/null +++ b/lisp/write.c @@ -0,0 +1,2411 @@ +/* + * Copyright (c) 2002 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/write.c,v 1.30 2002/12/04 18:43:19 paulo Exp $ */ + +#include "write.h" +#include "hash.h" +#include <math.h> +#include <ctype.h> + +#define FLOAT_PREC 17 + +#define UPCASE 0 +#define DOWNCASE 1 +#define CAPITALIZE 2 + +#define INCDEPTH() \ + if (++info->depth > MAX_STACK_DEPTH / 2) \ + LispDestroy("stack overflow") +#define DECDEPTH() --info->depth + +/* + * Types + */ +typedef struct _circle_info { + long circle_nth; /* nth circular list */ + LispObj *object; /* the circular object */ +} circle_info; + +typedef struct _write_info { + long depth; + long level; /* current level */ + long length; /* current length */ + long print_level; /* *print-level* when started printing */ + long print_length; /* *print-length* when started printing */ + + int print_escape; + int print_case; + + long circle_count; + /* used while building circle info */ + LispObj **objects; + long num_objects; + /* the circular lists */ + circle_info *circles; + long num_circles; +} write_info; + +/* + * Prototypes + */ +static void check_stream(LispObj*, LispFile**, LispString**, int); +static void parse_double(char*, int*, double, int); +static int float_string_inc(char*, int); +static void format_integer(char*, long, int); +static int LispWriteCPointer(LispObj*, void*); +static int LispWriteCString(LispObj*, char*, long, write_info*); +static int LispDoFormatExponentialFloat(LispObj*, LispObj*, + int, int, int*, int, int, + int, int, int, int); + +static int LispWriteInteger(LispObj*, LispObj*); +static int LispWriteCharacter(LispObj*, LispObj*, write_info*); +static int LispWriteString(LispObj*, LispObj*, write_info*); +static int LispWriteFloat(LispObj*, LispObj*); +static int LispWriteAtom(LispObj*, LispObj*, write_info*); +static int LispDoWriteAtom(LispObj*, char*, int, int); +static int LispWriteList(LispObj*, LispObj*, write_info*, int); +static int LispWriteArray(LispObj*, LispObj*, write_info*); +static int LispWriteStruct(LispObj*, LispObj*, write_info*); +static int LispDoWriteObject(LispObj*, LispObj*, write_info*, int); +static void LispBuildCircle(LispObj*, write_info*); +static void LispDoBuildCircle(LispObj*, write_info*); +static long LispCheckCircle(LispObj*, write_info*); +static int LispPrintCircle(LispObj*, LispObj*, long, int*, write_info*); +static int LispWriteAlist(LispObj*, LispArgList*, write_info*); + +/* + * Initialization + */ +LispObj *Oprint_level, *Oprint_length, *Oprint_circle, + *Oprint_escape, *Oprint_case; +LispObj *Kupcase, *Kdowncase, *Kcapitalize; + +/* + * Implementation + */ +void +LispWriteInit(void) +{ + Oprint_level = STATIC_ATOM("*PRINT-LEVEL*"); + LispProclaimSpecial(Oprint_level, NIL, NIL); + LispExportSymbol(Oprint_level); + + Oprint_length = STATIC_ATOM("*PRINT-LENGTH*"); + LispProclaimSpecial(Oprint_length, NIL, NIL); + LispExportSymbol(Oprint_length); + + Oprint_circle = STATIC_ATOM("*PRINT-CIRCLE*"); + LispProclaimSpecial(Oprint_circle, T, NIL); + LispExportSymbol(Oprint_circle); + + Oprint_escape = STATIC_ATOM("*PRINT-ESCAPE*"); + LispProclaimSpecial(Oprint_escape, T, NIL); + LispExportSymbol(Oprint_escape); + + Kupcase = KEYWORD("UPCASE"); + Kdowncase = KEYWORD("DOWNCASE"); + Kcapitalize = KEYWORD("CAPITALIZE"); + Oprint_case = STATIC_ATOM("*PRINT-CASE*"); + LispProclaimSpecial(Oprint_case, Kupcase, NIL); + LispExportSymbol(Oprint_case); +} + +LispObj * +Lisp_FreshLine(LispBuiltin *builtin) +/* + fresh-line &optional output-stream + */ +{ + LispObj *output_stream; + + output_stream = ARGUMENT(0); + + if (output_stream == UNSPEC) + output_stream = NIL; + else if (output_stream != NIL) { + CHECK_STREAM(output_stream); + } + if (LispGetColumn(output_stream)) { + LispWriteChar(output_stream, '\n'); + if (output_stream == NIL || + (output_stream->data.stream.type == LispStreamStandard && + output_stream->data.stream.source.file == Stdout)) + LispFflush(Stdout); + return (T); + } + + return (NIL); +} + +LispObj * +Lisp_Prin1(LispBuiltin *builtin) +/* + prin1 object &optional output-stream + */ +{ + LispObj *object, *output_stream; + + output_stream = ARGUMENT(1); + object = ARGUMENT(0); + + if (output_stream == UNSPEC) + output_stream = NIL; + LispPrint(object, output_stream, 0); + + return (object); +} + +LispObj * +Lisp_Princ(LispBuiltin *builtin) +/* + princ object &optional output-stream + */ +{ + int head; + LispObj *object, *output_stream; + + output_stream = ARGUMENT(1); + object = ARGUMENT(0); + + if (output_stream == UNSPEC) + output_stream = NIL; + head = lisp__data.env.length; + LispAddVar(Oprint_escape, NIL); + ++lisp__data.env.head; + LispPrint(object, output_stream, 0); + lisp__data.env.head = lisp__data.env.length = head; + + return (object); +} + +LispObj * +Lisp_Print(LispBuiltin *builtin) +/* + print object &optional output-stream + */ +{ + LispObj *object, *output_stream; + + output_stream = ARGUMENT(1); + object = ARGUMENT(0); + + if (output_stream == UNSPEC) + output_stream = NIL; + LispWriteChar(output_stream, '\n'); + LispPrint(object, output_stream, 0); + LispWriteChar(output_stream, ' '); + + return (object); +} + +LispObj * +Lisp_Terpri(LispBuiltin *builtin) +/* + terpri &optional output-stream + */ +{ + LispObj *output_stream; + + output_stream = ARGUMENT(0); + + if (output_stream == UNSPEC) + output_stream = NIL; + else if (output_stream != NIL) { + CHECK_STREAM(output_stream); + } + LispWriteChar(output_stream, '\n'); + if (output_stream == NIL || + (output_stream->data.stream.type == LispStreamStandard && + output_stream->data.stream.source.file == Stdout)) + LispFflush(Stdout); + + return (NIL); +} + +LispObj * +Lisp_Write(LispBuiltin *builtin) +/* + write object &key case circle escape length level lines pretty readably right-margin stream + */ +{ + int head = lisp__data.env.length; + + LispObj *object, *ocase, *circle, *escape, *length, *level, + *lines, *pretty, *readably, *right_margin, *stream; + + stream = ARGUMENT(10); + right_margin = ARGUMENT(9); /* yet unused */ + readably = ARGUMENT(8); /* yet unused */ + pretty = ARGUMENT(7); /* yet unused */ + lines = ARGUMENT(6); /* yet unused */ + level = ARGUMENT(5); + length = ARGUMENT(4); + escape = ARGUMENT(3); + circle = ARGUMENT(2); + ocase = ARGUMENT(1); + object = ARGUMENT(0); + + if (stream == UNSPEC) + stream = NIL; + else if (stream != NIL) { + CHECK_STREAM(stream); + } + + /* prepare the printer environment */ + if (circle != UNSPEC) + LispAddVar(Oprint_circle, circle); + if (length != UNSPEC) + LispAddVar(Oprint_length, length); + if (level != UNSPEC) + LispAddVar(Oprint_level, level); + if (ocase != UNSPEC) + LispAddVar(Oprint_case, ocase); + if (escape != UNSPEC) + LispAddVar(Oprint_escape, escape); + + lisp__data.env.head = lisp__data.env.length; + + (void)LispWriteObject(stream, object); + + lisp__data.env.head = lisp__data.env.length = head; + + return (object); +} + +LispObj * +Lisp_WriteChar(LispBuiltin *builtin) +/* + write-char character &optional output-stream + */ +{ + int ch; + + LispObj *character, *output_stream; + + output_stream = ARGUMENT(1); + character = ARGUMENT(0); + + if (output_stream == UNSPEC) + output_stream = NIL; + CHECK_SCHAR(character); + ch = SCHAR_VALUE(character); + + LispWriteChar(output_stream, ch); + + return (character); +} + +LispObj * +Lisp_WriteLine(LispBuiltin *builtin) +/* + write-line string &optional output-stream &key start end + */ +{ + return (LispWriteString_(builtin, 1)); +} + +LispObj * +Lisp_WriteString(LispBuiltin *builtin) +/* + write-string string &optional output-stream &key start end + */ +{ + return (LispWriteString_(builtin, 0)); +} + + +int +LispWriteObject(LispObj *stream, LispObj *object) +{ + write_info info; + int bytes; + LispObj *level, *length, *circle, *oescape, *ocase; + + /* current state */ + info.depth = info.level = info.length = 0; + + /* maximum level to descend */ + level = LispGetVar(Oprint_level); + if (level && INDEXP(level)) + info.print_level = FIXNUM_VALUE(level); + else + info.print_level = -1; + + /* maximum list length */ + length = LispGetVar(Oprint_length); + if (length && INDEXP(length)) + info.print_length = FIXNUM_VALUE(length); + else + info.print_length = -1; + + /* detect circular/shared objects? */ + circle = LispGetVar(Oprint_circle); + info.circle_count = 0; + info.objects = NULL; + info.num_objects = 0; + info.circles = NULL; + info.num_circles = 0; + if (circle && circle != NIL) { + LispBuildCircle(object, &info); + /* free this data now */ + if (info.num_objects) { + LispFree(info.objects); + info.num_objects = 0; + } + } + + /* escape characters and strings? */ + oescape = LispGetVar(Oprint_escape); + if (oescape != NULL) + info.print_escape = oescape == NIL; + else + info.print_escape = -1; + + /* don't use the default case printing? */ + ocase = LispGetVar(Oprint_case); + if (ocase == Kdowncase) + info.print_case = DOWNCASE; + else if (ocase == Kcapitalize) + info.print_case = CAPITALIZE; + else + info.print_case = UPCASE; + + bytes = LispDoWriteObject(stream, object, &info, 1); + if (circle && circle != NIL && info.num_circles) + LispFree(info.circles); + + return (bytes); +} + +static void +LispBuildCircle(LispObj *object, write_info *info) +{ + LispObj *list; + + switch (OBJECT_TYPE(object)) { + case LispCons_t: + LispDoBuildCircle(object, info); + break; + case LispArray_t: + /* Currently arrays are implemented as lists, but only + * the elements could/should be circular */ + if (LispCheckCircle(object, info) >= 0) + return; + LispDoBuildCircle(object, info); + for (list = object->data.array.list; + CONSP(list); list = CDR(list)) + LispBuildCircle(CAR(list), info); + break; + case LispStruct_t: + /* Like arrays, structs are currently implemented as lists, + * but only the elements could/should be circular */ + if (LispCheckCircle(object, info) >= 0) + return; + LispDoBuildCircle(object, info); + for (list = object->data.struc.fields; + CONSP(list); list = CDR(list)) + LispBuildCircle(CAR(list), info); + break; + case LispQuote_t: + case LispBackquote_t: + case LispFunctionQuote_t: + LispDoBuildCircle(object, info); + LispBuildCircle(object->data.quote, info); + break; + case LispComma_t: + LispDoBuildCircle(object, info); + LispBuildCircle(object->data.comma.eval, info); + break; + case LispLambda_t: + /* Circularity in a function body should fail elsewhere... */ + if (LispCheckCircle(object, info) >= 0) + return; + LispDoBuildCircle(object, info); + LispBuildCircle(object->data.lambda.code, info); + break; + default: + break; + } +} + +static void +LispDoBuildCircle(LispObj *object, write_info *info) +{ + long i; + + if (LispCheckCircle(object, info) >= 0) + return; + + for (i = 0; i < info->num_objects; i++) + if (info->objects[i] == object) { + /* circularity found */ + info->circles = LispRealloc(info->circles, sizeof(circle_info) * + (info->num_circles + 1)); + info->circles[info->num_circles].circle_nth = 0; + info->circles[info->num_circles].object = object; + ++info->num_circles; + return; + } + + /* object pointer not yet recorded */ + if ((i % 16) == 0) + info->objects = LispRealloc(info->objects, sizeof(LispObj*) * + (info->num_objects + 16)); + info->objects[info->num_objects++] = object; + + if (CONSP(object)) { + if (CONSP(CAR(object))) + LispDoBuildCircle(CAR(object), info); + else + LispBuildCircle(CAR(object), info); + if (CONSP(CDR(object))) + LispDoBuildCircle(CDR(object), info); + else + LispBuildCircle(CDR(object), info); + } +} + +static long +LispCheckCircle(LispObj *object, write_info *info) +{ + long i; + + for (i = 0; i < info->num_circles; i++) + if (info->circles[i].object == object) + return (i); + + return (-1); +} + +static int +LispPrintCircle(LispObj *stream, LispObj *object, long circle, + int *length, write_info *info) +{ + char stk[32]; + + if (!info->circles[circle].circle_nth) { + sprintf(stk, "#%ld=", ++info->circle_count); + *length += LispWriteStr(stream, stk, strlen(stk)); + info->circles[circle].circle_nth = info->circle_count; + + return (1); + } + sprintf(stk, "#%ld#", info->circles[circle].circle_nth); + *length += LispWriteStr(stream, stk, strlen(stk)); + + return (0); +} + +static int +LispWriteAlist(LispObj *stream, LispArgList *alist, write_info *info) +{ + char *name; + int i, length = 0, need_space = 0; + +#define WRITE_ATOM(object) \ + name = ATOMID(object); \ + length += LispDoWriteAtom(stream, name, strlen(name), \ + info->print_case) +#define WRITE_STRING(string) \ + length += LispDoWriteAtom(stream, string, strlen(string), \ + info->print_case) +#define WRITE_OBJECT(object) \ + length += LispDoWriteObject(stream, object, info, 1) +#define WRITE_OPAREN() \ + length += LispWriteChar(stream, '(') +#define WRITE_SPACE() \ + length += LispWriteChar(stream, ' ') +#define WRITE_CPAREN() \ + length += LispWriteChar(stream, ')') + + WRITE_OPAREN(); + for (i = 0; i < alist->normals.num_symbols; i++) { + WRITE_ATOM(alist->normals.symbols[i]); + if (i + 1 < alist->normals.num_symbols) + WRITE_SPACE(); + else + need_space = 1; + } + if (alist->optionals.num_symbols) { + if (need_space) + WRITE_SPACE(); + WRITE_STRING(Soptional); + WRITE_SPACE(); + for (i = 0; i < alist->optionals.num_symbols; i++) { + WRITE_OPAREN(); + WRITE_ATOM(alist->optionals.symbols[i]); + WRITE_SPACE(); + WRITE_OBJECT(alist->optionals.defaults[i]); + if (alist->optionals.sforms[i]) { + WRITE_SPACE(); + WRITE_ATOM(alist->optionals.sforms[i]); + } + WRITE_CPAREN(); + if (i + 1 < alist->optionals.num_symbols) + WRITE_SPACE(); + } + need_space = 1; + } + if (alist->keys.num_symbols) { + if (need_space) + WRITE_SPACE(); + length += LispDoWriteAtom(stream, Skey, 4, info->print_case); + WRITE_SPACE(); + for (i = 0; i < alist->keys.num_symbols; i++) { + WRITE_OPAREN(); + if (alist->keys.keys[i]) { + WRITE_OPAREN(); + WRITE_ATOM(alist->keys.keys[i]); + WRITE_SPACE(); + } + WRITE_ATOM(alist->keys.symbols[i]); + if (alist->keys.keys[i]) + WRITE_CPAREN(); + WRITE_SPACE(); + WRITE_OBJECT(alist->keys.defaults[i]); + if (alist->keys.sforms[i]) { + WRITE_SPACE(); + WRITE_ATOM(alist->keys.sforms[i]); + } + WRITE_CPAREN(); + if (i + 1 < alist->keys.num_symbols) + WRITE_SPACE(); + } + need_space = 1; + } + if (alist->rest) { + if (need_space) + WRITE_SPACE(); + WRITE_STRING(Srest); + WRITE_SPACE(); + WRITE_ATOM(alist->rest); + need_space = 1; + } + if (alist->auxs.num_symbols) { + if (need_space) + WRITE_SPACE(); + WRITE_STRING(Saux); + WRITE_SPACE(); + for (i = 0; i < alist->auxs.num_symbols; i++) { + WRITE_OPAREN(); + WRITE_ATOM(alist->auxs.symbols[i]); + WRITE_SPACE(); + WRITE_OBJECT(alist->auxs.initials[i]); + WRITE_CPAREN(); + if (i + 1 < alist->auxs.num_symbols) + WRITE_SPACE(); + } + } + WRITE_CPAREN(); + +#undef WRITE_ATOM +#undef WRITE_STRING +#undef WRITE_OBJECT +#undef WRITE_OPAREN +#undef WRITE_SPACE +#undef WRITE_CPAREN + + return (length); +} + +static void +check_stream(LispObj *stream, + LispFile **file, LispString **string, int check_writable) +{ + /* NIL is UNIX stdout, *STANDARD-OUTPUT* may not be UNIX stdout */ + if (stream == NIL) { + *file = Stdout; + *string = NULL; + } + else { + if (!STREAMP(stream)) + LispDestroy("%s is not a stream", STROBJ(stream)); + if (check_writable && !stream->data.stream.writable) + LispDestroy("%s is not writable", STROBJ(stream)); + else if (stream->data.stream.type == LispStreamString) { + *string = SSTREAMP(stream); + *file = NULL; + } + else { + if (stream->data.stream.type == LispStreamPipe) + *file = OPSTREAMP(stream); + else + *file = stream->data.stream.source.file; + *string = NULL; + } + } +} + +/* Assumes buffer has enough storage, 64 bytes should be more than enough */ +static void +parse_double(char *buffer, int *exponent, double value, int d) +{ + char stk[64], fmt[32], *ptr, *fract = NULL; + int positive = value >= 0.0; + +parse_double_again: + if (d >= 8) { + double dcheck; + int icheck, count; + + /* this should to do the correct rounding */ + for (count = 2; count >= 0; count--) { + icheck = d <= 0 ? 0 : d > FLOAT_PREC ? FLOAT_PREC - count : d - count; + sprintf(fmt, "%%.%de", icheck); + sprintf(stk, fmt, value); + if (count) { + /* if the value read back is the same formatted */ + sscanf(stk, "%lf", &dcheck); + if (dcheck == value) + break; + } + } + } + else { + sprintf(fmt, "%%.%de", d <= 0 ? 0 : d > FLOAT_PREC ? FLOAT_PREC : d); + sprintf(stk, fmt, value); + } + + /* this "should" never fail */ + ptr = strchr(stk, 'e'); + if (ptr) { + *ptr++ = '\0'; + *exponent = atoi(ptr); + } + else + *exponent = 0; + + /* find start of number representation */ + for (ptr = stk; *ptr && !isdigit(*ptr); ptr++) + ; + + /* check if did not trim any significant digit, + * this may happen because '%.e' puts only one digit before the '.' */ + if (d > 0 && d < FLOAT_PREC && fabs(value) >= 10.0 && + strlen(ptr) - 1 - !positive <= *exponent) { + d += *exponent - (strlen(ptr) - 1 - !positive) + 1; + goto parse_double_again; + } + + /* this "should" never fail */ + fract = strchr(ptr, '.'); + if (fract) + *fract++ = '\0'; + + /* store number representation in buffer */ + *buffer = positive ? '+' : '-'; + strcpy(buffer + 1, ptr); + if (fract) + strcpy(buffer + strlen(buffer), fract); +} + +static void +format_integer(char *buffer, long value, int radix) +{ + if (radix == 10) + sprintf(buffer, "%ld", value); + else if (radix == 16) + sprintf(buffer, "%lx", value); + else if (radix == 8) + sprintf(buffer, "%lo", value); + else { + /* use bignum routine to convert number to string */ + mpi integer; + + mpi_init(&integer); + mpi_seti(&integer, value); + mpi_getstr(buffer, &integer, radix); + mpi_clear(&integer); + } +} + +static int +LispWriteCPointer(LispObj *stream, void *data) +{ + char stk[32]; + +#ifdef LONG64 + sprintf(stk, "0x%016lx", (long)data); +#else + sprintf(stk, "0x%08lx", (long)data); +#endif + + return (LispWriteStr(stream, stk, strlen(stk))); +} + +static int +LispWriteCString(LispObj *stream, char *string, long length, write_info *info) +{ + int result; + + if (!info->print_escape) { + char *base, *ptr, *end; + + result = LispWriteChar(stream, '"'); + for (base = ptr = string, end = string + length; ptr < end; ptr++) { + if (*ptr == '\\' || *ptr == '"') { + result += LispWriteStr(stream, base, ptr - base); + result += LispWriteChar(stream, '\\'); + result += LispWriteChar(stream, *ptr); + base = ptr + 1; + } + } + result += LispWriteStr(stream, base, end - base); + result += LispWriteChar(stream, '"'); + } + else + result = LispWriteStr(stream, string, length); + + return (result); +} + +static int +LispWriteList(LispObj *stream, LispObj *object, write_info *info, int paren) +{ + int length = 0; + long circle = 0; + + INCDEPTH(); + if (info->print_level < 0 || info->level <= info->print_level) { + LispObj *car, *cdr; + long print_length = info->length; + + if (info->circles && (circle = LispCheckCircle(object, info)) >= 0) { + if (!paren) { + length += LispWriteStr(stream, ". ", 2); + paren = 1; + } + if (LispPrintCircle(stream, object, circle, &length, info) == 0) { + DECDEPTH(); + + return (length); + } + } + + car = CAR(object); + cdr = CDR(object); + + if (cdr == NIL) { + if (paren) + length += LispWriteChar(stream, '('); + if (info->print_length < 0 || info->length < info->print_length) { + info->length = 0; + length += LispDoWriteObject(stream, car, info, 1); + info->length = print_length + 1; + } + else + length += LispWriteStr(stream, "...", 3); + if (paren) + length += LispWriteChar(stream, ')'); + } + else { + if (paren) + length += LispWriteChar(stream, '('); + if (info->print_length < 0 || info->length < info->print_length) { + info->length = 0; + length += LispDoWriteObject(stream, car, info, 1); + info->length = print_length + 1; + if (!CONSP(cdr)) { + length += LispWriteStr(stream, " . ", 3); + info->length = 0; + length += LispDoWriteObject(stream, cdr, info, 0); + } + else { + length += LispWriteChar(stream, ' '); + if (info->print_length < 0 || + info->length < info->print_length) + length += LispWriteList(stream, cdr, info, 0); + else + length += LispWriteStr(stream, "...", 3); + } + } + else + length += LispWriteStr(stream, "...", 3); + if (paren) + length += LispWriteChar(stream, ')'); + } + info->length = print_length; + } + else + length += LispWriteChar(stream, '#'); + DECDEPTH(); + + return (length); +} + +static int +LispDoWriteObject(LispObj *stream, LispObj *object, write_info *info, int paren) +{ + long print_level; + int length = 0; + char stk[64], *string = NULL; + +write_again: + switch (OBJECT_TYPE(object)) { + case LispNil_t: + if (object == NIL) + string = Snil; + else if (object == T) + string = St; + else if (object == DOT) + string = "#<DOT>"; + else if (object == UNSPEC) + string = "#<UNSPEC>"; + else if (object == UNBOUND) + string = "#<UNBOUND>"; + else + string = "#<ERROR>"; + length += LispDoWriteAtom(stream, string, strlen(string), + info->print_case); + break; + case LispOpaque_t: { + char *desc = LispIntToOpaqueType(object->data.opaque.type); + + length += LispWriteChar(stream, '#'); + length += LispWriteCPointer(stream, object->data.opaque.data); + length += LispWriteStr(stream, desc, strlen(desc)); + } break; + case LispAtom_t: + length += LispWriteAtom(stream, object, info); + break; + case LispFunction_t: + if (object->data.atom->a_function) { + object = object->data.atom->property->fun.function; + goto write_lambda; + } + length += LispWriteStr(stream, "#<", 2); + if (object->data.atom->a_compiled) + LispDoWriteAtom(stream, "COMPILED", 8, info->print_case); + else if (object->data.atom->a_builtin) + LispDoWriteAtom(stream, "BUILTIN", 7, info->print_case); + /* XXX the function does not exist anymore */ + /* FIXME not sure if I want this fixed... */ + else + LispDoWriteAtom(stream, "UNBOUND", 7, info->print_case); + LispDoWriteAtom(stream, "-FUNCTION", 9, info->print_case); + length += LispWriteChar(stream, ' '); + length += LispWriteAtom(stream, object->data.atom->object, info); + length += LispWriteChar(stream, '>'); + break; + case LispString_t: + length += LispWriteString(stream, object, info); + break; + case LispSChar_t: + length += LispWriteCharacter(stream, object, info); + break; + case LispDFloat_t: + length += LispWriteFloat(stream, object); + break; + case LispFixnum_t: + case LispInteger_t: + case LispBignum_t: + length += LispWriteInteger(stream, object); + break; + case LispRatio_t: + format_integer(stk, object->data.ratio.numerator, 10); + length += LispWriteStr(stream, stk, strlen(stk)); + length += LispWriteChar(stream, '/'); + format_integer(stk, object->data.ratio.denominator, 10); + length += LispWriteStr(stream, stk, strlen(stk)); + break; + case LispBigratio_t: { + int sz; + char *ptr; + + sz = mpi_getsize(mpr_num(object->data.mp.ratio), 10) + 1 + + mpi_getsize(mpr_den(object->data.mp.ratio), 10) + 1 + + (mpi_sgn(mpr_num(object->data.mp.ratio)) < 0); + if (sz > sizeof(stk)) + ptr = LispMalloc(sz); + else + ptr = stk; + mpr_getstr(ptr, object->data.mp.ratio, 10); + length += LispWriteStr(stream, ptr, sz - 1); + if (ptr != stk) + LispFree(ptr); + } break; + case LispComplex_t: + length += LispWriteStr(stream, "#C(", 3); + length += LispDoWriteObject(stream, + object->data.complex.real, info, 0); + length += LispWriteChar(stream, ' '); + length += LispDoWriteObject(stream, + object->data.complex.imag, info, 0); + length += LispWriteChar(stream, ')'); + break; + case LispCons_t: + print_level = info->level; + ++info->level; + length += LispWriteList(stream, object, info, paren); + info->level = print_level; + break; + case LispQuote_t: + length += LispWriteChar(stream, '\''); + paren = 1; + object = object->data.quote; + goto write_again; + case LispBackquote_t: + length += LispWriteChar(stream, '`'); + paren = 1; + object = object->data.quote; + goto write_again; + case LispComma_t: + if (object->data.comma.atlist) + length += LispWriteStr(stream, ",@", 2); + else + length += LispWriteChar(stream, ','); + paren = 1; + object = object->data.comma.eval; + goto write_again; + break; + case LispFunctionQuote_t: + length += LispWriteStr(stream, "#'", 2); + paren = 1; + object = object->data.quote; + goto write_again; + case LispArray_t: + length += LispWriteArray(stream, object, info); + break; + case LispStruct_t: + length += LispWriteStruct(stream, object, info); + break; + case LispLambda_t: + write_lambda: + switch (object->funtype) { + case LispLambda: + string = "#<LAMBDA "; + break; + case LispFunction: + string = "#<FUNCTION "; + break; + case LispMacro: + string = "#<MACRO "; + break; + case LispSetf: + string = "#<SETF "; + break; + } + length += LispDoWriteAtom(stream, string, strlen(string), + info->print_case); + if (object->funtype != LispLambda) { + length += LispWriteAtom(stream, object->data.lambda.name, info); + length += LispWriteChar(stream, ' '); + length += LispWriteAlist(stream, object->data.lambda.name + ->data.atom->property->alist, info); + } + else { + length += LispDoWriteAtom(stream, Snil, 3, info->print_case); + length += LispWriteChar(stream, ' '); + length += LispWriteAlist(stream, (LispArgList*)object-> + data.lambda.name->data.opaque.data, + info); + } + length += LispWriteChar(stream, ' '); + length += LispDoWriteObject(stream, + object->data.lambda.code, info, 0); + length += LispWriteChar(stream, '>'); + break; + case LispStream_t: + length += LispWriteStr(stream, "#<", 2); + if (object->data.stream.type == LispStreamFile) + string = "FILE-STREAM "; + else if (object->data.stream.type == LispStreamString) + string = "STRING-STREAM "; + else if (object->data.stream.type == LispStreamStandard) + string = "STANDARD-STREAM "; + else if (object->data.stream.type == LispStreamPipe) + string = "PIPE-STREAM "; + length += LispDoWriteAtom(stream, string, strlen(string), + info->print_case); + + if (!object->data.stream.readable && !object->data.stream.writable) + length += LispDoWriteAtom(stream, "CLOSED", + 6, info->print_case); + else { + if (object->data.stream.readable) + length += LispDoWriteAtom(stream, "READ", + 4, info->print_case); + if (object->data.stream.writable) { + if (object->data.stream.readable) + length += LispWriteChar(stream, '-'); + length += LispDoWriteAtom(stream, "WRITE", + 5, info->print_case); + } + } + if (object->data.stream.type != LispStreamString) { + length += LispWriteChar(stream, ' '); + length += LispDoWriteObject(stream, + object->data.stream.pathname, + info, 1); + /* same address/size for pipes */ + length += LispWriteChar(stream, ' '); + length += LispWriteCPointer(stream, + object->data.stream.source.file); + if (object->data.stream.readable && + object->data.stream.type == LispStreamFile && + !object->data.stream.source.file->binary) { + length += LispWriteStr(stream, " @", 2); + format_integer(stk, object->data.stream.source.file->line, 10); + length += LispWriteStr(stream, stk, strlen(stk)); + } + } + length += LispWriteChar(stream, '>'); + break; + case LispPathname_t: + length += LispWriteStr(stream, "#P", 2); + paren = 1; + object = CAR(object->data.quote); + goto write_again; + case LispPackage_t: + length += LispDoWriteAtom(stream, "#<PACKAGE ", + 10, info->print_case); + length += LispWriteStr(stream, + THESTR(object->data.package.name), + STRLEN(object->data.package.name)); + length += LispWriteChar(stream, '>'); + break; + case LispRegex_t: + length += LispDoWriteAtom(stream, "#<REGEX ", + 8, info->print_case); + length += LispDoWriteObject(stream, + object->data.regex.pattern, info, 1); + if (object->data.regex.options & RE_NOSPEC) + length += LispDoWriteAtom(stream, " :NOSPEC", + 8, info->print_case); + if (object->data.regex.options & RE_ICASE) + length += LispDoWriteAtom(stream, " :ICASE", + 7, info->print_case); + if (object->data.regex.options & RE_NOSUB) + length += LispDoWriteAtom(stream, " :NOSUB", + 7, info->print_case); + if (object->data.regex.options & RE_NEWLINE) + length += LispDoWriteAtom(stream, " :NEWLINE", + 9, info->print_case); + length += LispWriteChar(stream, '>'); + break; + case LispBytecode_t: + length += LispDoWriteAtom(stream, "#<BYTECODE ", + 11, info->print_case); + length += LispWriteCPointer(stream, + object->data.bytecode.bytecode); + length += LispWriteChar(stream, '>'); + break; + case LispHashTable_t: + length += LispDoWriteAtom(stream, "#<HASH-TABLE ", + 13, info->print_case); + length += LispWriteAtom(stream, object->data.hash.test, info); + snprintf(stk, sizeof(stk), " %g %g", + object->data.hash.table->rehash_size, + object->data.hash.table->rehash_threshold); + length += LispWriteStr(stream, stk, strlen(stk)); + snprintf(stk, sizeof(stk), " %ld/%ld>", + object->data.hash.table->count, + object->data.hash.table->num_entries); + length += LispWriteStr(stream, stk, strlen(stk)); + break; + } + + return (length); +} + +/* return current column number in stream */ +int +LispGetColumn(LispObj *stream) +{ + LispFile *file; + LispString *string; + + check_stream(stream, &file, &string, 0); + if (file != NULL) + return (file->column); + return (string->column); +} + +/* write a character to stream */ +int +LispWriteChar(LispObj *stream, int character) +{ + LispFile *file; + LispString *string; + + check_stream(stream, &file, &string, 1); + if (file != NULL) + return (LispFputc(file, character)); + + return (LispSputc(string, character)); +} + +/* write a character count times to stream */ +int +LispWriteChars(LispObj *stream, int character, int count) +{ + int length = 0; + + if (count > 0) { + char stk[64]; + LispFile *file; + LispString *string; + + check_stream(stream, &file, &string, 1); + if (count >= sizeof(stk)) { + memset(stk, character, sizeof(stk)); + for (; count >= sizeof(stk); count -= sizeof(stk)) { + if (file != NULL) + length += LispFwrite(file, stk, sizeof(stk)); + else + length += LispSwrite(string, stk, sizeof(stk)); + } + } + else + memset(stk, character, count); + + if (count) { + if (file != NULL) + length += LispFwrite(file, stk, count); + else + length += LispSwrite(string, stk, count); + } + } + + return (length); +} + +/* write a string to stream */ +int +LispWriteStr(LispObj *stream, char *buffer, long length) +{ + LispFile *file; + LispString *string; + + check_stream(stream, &file, &string, 1); + if (file != NULL) + return (LispFwrite(file, buffer, length)); + return (LispSwrite(string, buffer, length)); +} + +static int +LispDoWriteAtom(LispObj *stream, char *string, int length, int print_case) +{ + int bytes = 0, cap = 0; + char buffer[128], *ptr; + + switch (print_case) { + case DOWNCASE: + for (ptr = buffer; length > 0; length--, string++) { + if (isupper(*string)) + *ptr = tolower(*string); + else + *ptr = *string; + ++ptr; + if (ptr - buffer >= sizeof(buffer)) { + bytes += LispWriteStr(stream, buffer, ptr - buffer); + ptr = buffer; + } + } + if (ptr > buffer) + bytes += LispWriteStr(stream, buffer, ptr - buffer); + break; + case CAPITALIZE: + for (ptr = buffer; length > 0; length--, string++) { + if (isalnum(*string)) { + if (cap && isupper(*string)) + *ptr = tolower(*string); + else + *ptr = *string; + cap = 1; + } + else { + *ptr = *string; + cap = 0; + } + ++ptr; + if (ptr - buffer >= sizeof(buffer)) { + bytes += LispWriteStr(stream, buffer, ptr - buffer); + ptr = buffer; + } + } + if (ptr > buffer) + bytes += LispWriteStr(stream, buffer, ptr - buffer); + break; + default: + /* Strings are already stored upcase/quoted */ + bytes += LispWriteStr(stream, string, length); + break; + } + + return (bytes); +} + +static int +LispWriteAtom(LispObj *stream, LispObj *object, write_info *info) +{ + int length = 0; + LispAtom *atom = object->data.atom; + Atom_id id = atom->string; + + if (atom->package != PACKAGE) { + if (atom->package == lisp__data.keyword) + length += LispWriteChar(stream, ':'); + else if (atom->package == NULL) + length += LispWriteStr(stream, "#:", 2); + else { + /* Check if the symbol is visible */ + int i, visible = 0; + + if (atom->ext) { + for (i = lisp__data.pack->use.length - 1; i >= 0; i--) { + if (lisp__data.pack->use.pairs[i] == atom->package) { + visible = 1; + break; + } + } + } + + if (!visible) { + /* XXX this assumes that package names are always "readable" */ + length += + LispDoWriteAtom(stream, + THESTR(atom->package->data.package.name), + STRLEN(atom->package->data.package.name), + info->print_case); + length += LispWriteChar(stream, ':'); + if (!atom->ext) + length += LispWriteChar(stream, ':'); + } + } + } + if (atom->unreadable) + length += LispWriteChar(stream, '|'); + length += LispDoWriteAtom(stream, id, strlen(id), + atom->unreadable ? UPCASE : info->print_case); + if (atom->unreadable) + length += LispWriteChar(stream, '|'); + + return (length); +} + +static int +LispWriteInteger(LispObj *stream, LispObj *object) +{ + return (LispFormatInteger(stream, object, 10, 0, 0, 0, 0, 0, 0)); +} + +static int +LispWriteCharacter(LispObj *stream, LispObj *object, write_info *info) +{ + return (LispFormatCharacter(stream, object, !info->print_escape, 0)); +} + +static int +LispWriteString(LispObj *stream, LispObj *object, write_info *info) +{ + return (LispWriteCString(stream, THESTR(object), STRLEN(object), info)); +} + +static int +LispWriteFloat(LispObj *stream, LispObj *object) +{ + double value = DFLOAT_VALUE(object); + + if (value == 0.0 || (fabs(value) < 1.0E7 && fabs(value) > 1.0E-4)) + return (LispFormatFixedFloat(stream, object, 0, 0, NULL, 0, 0, 0)); + + return (LispDoFormatExponentialFloat(stream, object, 0, 0, NULL, + 0, 1, 0, ' ', 'E', 0)); +} + +static int +LispWriteArray(LispObj *stream, LispObj *object, write_info *info) +{ + int length = 0; + long print_level = info->level, circle; + + if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 && + LispPrintCircle(stream, object, circle, &length, info) == 0) + return (length); + + if (object->data.array.rank == 0) { + length += LispWriteStr(stream, "#0A", 3); + length += LispDoWriteObject(stream, object->data.array.list, info, 1); + return (length); + } + + INCDEPTH(); + ++info->level; + if (info->print_level < 0 || info->level <= info->print_level) { + if (object->data.array.rank == 1) + length += LispWriteStr(stream, "#(", 2); + else { + char stk[32]; + + format_integer(stk, object->data.array.rank, 10); + length += LispWriteChar(stream, '#'); + length += LispWriteStr(stream, stk, strlen(stk)); + length += LispWriteStr(stream, "A(", 2); + } + + if (!object->data.array.zero) { + long print_length = info->length, local_length = 0; + + if (object->data.array.rank == 1) { + LispObj *ary; + long count; + + for (ary = object->data.array.dim, count = 1; + ary != NIL; ary = CDR(ary)) + count *= FIXNUM_VALUE(CAR(ary)); + for (ary = object->data.array.list; count > 0; + ary = CDR(ary), count--) { + if (info->print_length < 0 || + ++local_length <= info->print_length) { + info->length = 0; + length += LispDoWriteObject(stream, CAR(ary), info, 1); + } + else { + length += LispWriteStr(stream, "...", 3); + break; + } + if (count - 1 > 0) + length += LispWriteChar(stream, ' '); + } + } + else { + LispObj *ary; + int i, k, rank, *dims, *loop; + + rank = object->data.array.rank; + dims = LispMalloc(sizeof(int) * rank); + loop = LispCalloc(1, sizeof(int) * (rank - 1)); + + /* fill dim */ + for (i = 0, ary = object->data.array.dim; ary != NIL; + i++, ary = CDR(ary)) + dims[i] = FIXNUM_VALUE(CAR(ary)); + + i = 0; + ary = object->data.array.list; + while (loop[0] < dims[0]) { + if (info->print_length < 0 || + local_length < info->print_length) { + for (; i < rank - 1; i++) + length += LispWriteChar(stream, '('); + --i; + for (;;) { + ++loop[i]; + if (i && loop[i] >= dims[i]) + loop[i] = 0; + else + break; + --i; + } + for (k = 0; k < dims[rank - 1] - 1; + k++, ary = CDR(ary)) { + if (info->print_length < 0 || + k < info->print_length) { + ++local_length; + info->length = 0; + length += LispDoWriteObject(stream, + CAR(ary), info, 1); + length += LispWriteChar(stream, ' '); + } + } + if (info->print_length < 0 || k < info->print_length) { + ++local_length; + info->length = 0; + length += LispDoWriteObject(stream, + CAR(ary), info, 0); + } + else + length += LispWriteStr(stream, "...", 3); + for (k = rank - 1; k > i; k--) + length += LispWriteChar(stream, ')'); + if (loop[0] < dims[0]) + length += LispWriteChar(stream, ' '); + ary = CDR(ary); + } + else { + ++local_length; + length += LispWriteStr(stream, "...)", 4); + for (; local_length < dims[0] - 1; local_length++) + length += LispWriteStr(stream, " ...)", 5); + if (local_length <= dims[0]) + length += LispWriteStr(stream, " ...", 4); + break; + } + } + LispFree(dims); + LispFree(loop); + } + info->length = print_length; + } + length += LispWriteChar(stream, ')'); + } + else + length += LispWriteChar(stream, '#'); + info->level = print_level; + DECDEPTH(); + + return (length); +} + +static int +LispWriteStruct(LispObj *stream, LispObj *object, write_info *info) +{ + int length; + long circle; + LispObj *symbol; + LispObj *def = object->data.struc.def; + LispObj *field = object->data.struc.fields; + + if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 && + LispPrintCircle(stream, object, circle, &length, info) == 0) + return (length); + + INCDEPTH(); + length = LispWriteStr(stream, "#S(", 3); + symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def); + length += LispWriteAtom(stream, symbol, info); + def = CDR(def); + for (; def != NIL; def = CDR(def), field = CDR(field)) { + length += LispWriteChar(stream, ' '); + symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def); + length += LispWriteAtom(stream, symbol, info); + length += LispWriteChar(stream, ' '); + length += LispDoWriteObject(stream, CAR(field), info, 1); + } + length += LispWriteChar(stream, ')'); + DECDEPTH(); + + return (length); +} + +int +LispFormatInteger(LispObj *stream, LispObj *object, int radix, + int atsign, int collon, int mincol, + int padchar, int commachar, int commainterval) +{ + char stk[128], *str = stk; + int i, length, sign, intervals; + + if (LONGINTP(object)) + format_integer(stk, LONGINT_VALUE(object), radix); + else { + if (mpi_getsize(object->data.mp.integer, radix) >= sizeof(stk)) + str = mpi_getstr(NULL, object->data.mp.integer, radix); + else + mpi_getstr(str, object->data.mp.integer, radix); + } + + sign = *str == '-'; + length = strlen(str); + + /* if collon, update length for the number of commachars to be printed */ + if (collon && commainterval > 0 && commachar) { + intervals = length / commainterval; + length += intervals; + } + else + intervals = 0; + + /* if sign must be printed, and number is positive */ + if (atsign && !sign) + ++length; + + /* if need padding */ + if (padchar && mincol > length) + LispWriteChars(stream, padchar, mincol - length); + + /* if need to print number sign */ + if (sign || atsign) + LispWriteChar(stream, sign ? '-' : '+'); + + /* if need to print commas to separate groups of numbers */ + if (intervals) { + int j; + char *ptr; + + i = (length - atsign) - intervals; + j = i % commainterval; + /* make the loop below easier */ + if (j == 0) + j = commainterval; + i -= j; + ptr = str + sign; + for (; j > 0; j--, ptr++) + LispWriteChar(stream, *ptr); + for (; i > 0; i -= commainterval) { + LispWriteChar(stream, commachar); + for (j = 0; j < commainterval; j++, ptr++) + LispWriteChar(stream, *ptr); + } + } + /* else, just print the string */ + else + LispWriteStr(stream, str + sign, length - sign); + + /* if number required more than sizeof(stk) bytes */ + if (str != stk) + LispFree(str); + + return (length); +} + +int +LispFormatRomanInteger(LispObj *stream, long value, int new_roman) +{ + char stk[32]; + int length; + + length = 0; + while (value > 1000) { + stk[length++] = 'M'; + value -= 1000; + } + if (new_roman) { + if (value >= 900) { + strcpy(stk + length, "CM"); + length += 2, + value -= 900; + } + else if (value < 500 && value >= 400) { + strcpy(stk + length, "CD"); + length += 2; + value -= 400; + } + } + if (value >= 500) { + stk[length++] = 'D'; + value -= 500; + } + while (value >= 100) { + stk[length++] = 'C'; + value -= 100; + } + if (new_roman) { + if (value >= 90) { + strcpy(stk + length, "XC"); + length += 2, + value -= 90; + } + else if (value < 50 && value >= 40) { + strcpy(stk + length, "XL"); + length += 2; + value -= 40; + } + } + if (value >= 50) { + stk[length++] = 'L'; + value -= 50; + } + while (value >= 10) { + stk[length++] = 'X'; + value -= 10; + } + if (new_roman) { + if (value == 9) { + strcpy(stk + length, "IX"); + length += 2, + value -= 9; + } + else if (value == 4) { + strcpy(stk + length, "IV"); + length += 2; + value -= 4; + } + } + if (value >= 5) { + stk[length++] = 'V'; + value -= 5; + } + while (value) { + stk[length++] = 'I'; + --value; + } + + stk[length] = '\0'; + + return (LispWriteStr(stream, stk, length)); +} + +int +LispFormatEnglishInteger(LispObj *stream, long number, int ordinal) +{ + static char *ds[] = { + "", "one", "two", "three", "four", + "five", "six", "seven", "eight", "nine", + "ten", "eleven", "twelve", "thirteen", "fourteen", + "fifteen", "sixteen", "seventeen", "eighteen", "nineteen" + }; + static char *dsth[] = { + "", "first", "second", "third", "fourth", + "fifth", "sixth", "seventh", "eighth", "ninth", + "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", + "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth" + }; + static char *hs[] = { + "", "", "twenty", "thirty", "forty", + "fifty", "sixty", "seventy", "eighty", "ninety" + }; + static char *hsth[] = { + "", "", "twentieth", "thirtieth", "fortieth", + "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth" + }; + static char *ts[] = { + "", "thousand", "million" + }; + static char *tsth[] = { + "", "thousandth", "millionth" + }; + char stk[256]; + int length, sign; + + sign = number < 0; + if (sign) + number = -number; + length = 0; + +#define SIGNLEN 6 /* strlen("minus ") */ + if (sign) { + strcpy(stk, "minus "); + length += SIGNLEN; + } + else if (number == 0) { + if (ordinal) { + strcpy(stk, "zeroth"); + length += 6; /* strlen("zeroth") */ + } + else { + strcpy(stk, "zero"); + length += 4; /* strlen("zero") */ + } + } + for (;;) { + int count, temp; + char *t, *h, *d; + long value = number; + + for (count = 0; value >= 1000; value /= 1000, count++) + ; + + t = ds[value / 100]; + if (ordinal && !count && (value % 10) == 0) + h = hsth[(value % 100) / 10]; + else + h = hs[(value % 100) / 10]; + + if (ordinal && !count) + d = *h ? dsth[value % 10] : dsth[value % 20]; + else + d = *h ? ds[value % 10] : ds[value % 20]; + + if (((!sign && length) || length > SIGNLEN) && (*t || *h || *d)) { + if (!ordinal || count || *h || *t) { + strcpy(stk + length, ", "); + length += 2; + } + else { + strcpy(stk + length, " "); + ++length; + } + } + + if (*t) { + if (ordinal && !count && (value % 100) == 0) + temp = sprintf(stk + length, "%s hundredth", t); + else + temp = sprintf(stk + length, "%s hundred", t); + length += temp; + } + + if (*h) { + if (*t) { + if (ordinal && !count) { + strcpy(stk + length, " "); + ++length; + } + else { + strcpy(stk + length, " and "); + length += 5; /* strlen(" and ") */ + } + } + strcpy(stk + length, h); + length += strlen(h); + } + + if (*d) { + if (*h) { + strcpy(stk + length, "-"); + ++length; + } + else if (*t) { + if (ordinal && !count) { + strcpy(stk + length, " "); + ++length; + } + else { + strcpy(stk + length, " and "); + length += 5; /* strlen(" and ") */ + } + } + strcpy(stk + length, d); + length += strlen(d); + } + + if (!count) + break; + else + temp = count; + + if (count > 1) { + value *= 1000; + while (--count) + value *= 1000; + number -= value; + } + else + number %= 1000; + + if (ordinal && number == 0 && !*t && !*h) + temp = sprintf(stk + length, " %s", tsth[temp]); + else + temp = sprintf(stk + length, " %s", ts[temp]); + length += temp; + + if (!number) + break; + } + + return (LispWriteStr(stream, stk, length)); +} + +int +LispFormatCharacter(LispObj *stream, LispObj *object, + int atsign, int collon) +{ + int length = 0; + int ch = SCHAR_VALUE(object); + + if (atsign && !collon) + length += LispWriteStr(stream, "#\\", 2); + if ((atsign || collon) && (ch <= ' ' || ch == 0177)) { + char *name = LispChars[ch].names[0]; + + length += LispWriteStr(stream, name, strlen(name)); + } + else + length += LispWriteChar(stream, ch); + + return (length); +} + +/* returns 1 if string size must grow, done inplace */ +static int +float_string_inc(char *buffer, int offset) +{ + int i; + + for (i = offset; i >= 0; i--) { + if (buffer[i] == '9') + buffer[i] = '0'; + else if (buffer[i] != '.') { + ++buffer[i]; + break; + } + } + if (i < 0) { + int length = strlen(buffer); + + /* string size must change */ + memmove(buffer + 1, buffer, length + 1); + buffer[0] = '1'; + + return (1); + } + + return (0); +} + +int +LispFormatFixedFloat(LispObj *stream, LispObj *object, + int atsign, int w, int *pd, int k, int overflowchar, + int padchar) +{ + char buffer[512], stk[64]; + int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC, again; + double value = DFLOAT_VALUE(object); + + if (value == 0.0) { + exponent = k = 0; + strcpy(stk, "+0"); + } + else + /* calculate format parameters, adjusting scale factor */ + parse_double(stk, &exponent, value, d + 1 + k); + + /* make sure k won't cause overflow */ + if (k > 128) + k = 128; + else if (k < -128) + k = -128; + + /* make sure d won't cause overflow */ + if (d > 128) + d = 128; + else if (d < -128) + d = -128; + + /* adjust scale factor, exponent is used as an index in stk */ + exponent += k + 1; + + /* how many bytes in float representation */ + length = strlen(stk) - 1; + + /* need to print a sign? */ + sign = atsign || (stk[0] == '-'); + + /* format number, cannot overflow, as control variables were checked */ + offset = 0; + if (sign) + buffer[offset++] = stk[0]; + if (exponent > 0) { + if (exponent > length) { + memcpy(buffer + offset, stk + 1, length); + memset(buffer + offset + length, '0', exponent - length); + } + else + memcpy(buffer + offset, stk + 1, exponent); + offset += exponent; + buffer[offset++] = '.'; + if (length > exponent) { + memcpy(buffer + offset, stk + 1 + exponent, length - exponent); + offset += length - exponent; + } + else + buffer[offset++] = '0'; + } + else { + buffer[offset++] = '0'; + buffer[offset++] = '.'; + while (exponent < 0) { + buffer[offset++] = '0'; + exponent++; + } + memcpy(buffer + offset, stk + 1, length); + offset += length; + } + buffer[offset] = '\0'; + + again = 0; +fixed_float_check_again: + /* make sure only d digits are printed after decimal point */ + if (d > 0) { + char *dptr = strchr(buffer, '.'); + + length = strlen(dptr) - 1; + /* check if need to remove excess digits */ + if (length > d) { + int digit; + + offset = (dptr - buffer) + 1 + d; + digit = buffer[offset]; + + /* remove extra digits */ + buffer[offset] = '\0'; + + /* check if need to round */ + if (!again && offset > 1 && isdigit(digit) && digit >= '5' && + isdigit(buffer[offset - 1]) && + float_string_inc(buffer, offset - 1)) + ++offset; + } + /* check if need to add extra zero digits to fill space */ + else if (length < d) { + offset += d - length; + for (++length; length <= d; length++) + dptr[length] = '0'; + dptr[length] = '\0'; + } + } + else { + /* no digits after decimal point */ + int digit, inc = 0; + char *dptr = strchr(buffer, '.') + 1; + + digit = *dptr; + if (!again && digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2])) + inc = float_string_inc(buffer, dptr - buffer - 2); + + offset = (dptr - buffer) + inc; + buffer[offset] = '\0'; + } + + /* if d was not specified, remove any extra zeros */ + if (pd == NULL) { + while (offset > 2 && buffer[offset - 2] != '.' && + buffer[offset - 1] == '0') + --offset; + buffer[offset] = '\0'; + } + + if (w > 0 && offset > w) { + /* first check if can remove extra fractional digits */ + if (pd == NULL) { + char *ptr = strchr(buffer, '.') + 1; + + if (ptr - buffer < w) { + d = w - (ptr - buffer); + goto fixed_float_check_again; + } + } + + /* remove leading "zero" to save space */ + if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) { + /* ending nul also copied */ + memmove(buffer + sign, buffer + sign + 1, offset); + --offset; + } + /* remove leading '+' to "save" space */ + if (offset > w && buffer[0] == '+') { + /* ending nul also copied */ + memmove(buffer, buffer + 1, offset); + --offset; + } + } + + /* if cannot represent number in given width */ + if (overflowchar && offset > w) { + again = 1; + goto fixed_float_overflow; + } + + length = 0; + /* print padding if required */ + if (w > offset) + length += LispWriteChars(stream, padchar, w - offset); + + /* print float number representation */ + return (LispWriteStr(stream, buffer, offset) + length); + +fixed_float_overflow: + return (LispWriteChars(stream, overflowchar, w)); +} + +int +LispFormatExponentialFloat(LispObj *stream, LispObj *object, + int atsign, int w, int *pd, int e, int k, + int overflowchar, int padchar, int exponentchar) +{ + return (LispDoFormatExponentialFloat(stream, object, atsign, w, + pd, e, k, overflowchar, padchar, + exponentchar, 1)); +} + +int +LispDoFormatExponentialFloat(LispObj *stream, LispObj *object, + int atsign, int w, int *pd, int e, int k, + int overflowchar, int padchar, int exponentchar, + int format) +{ + char buffer[512], stk[64]; + int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC; + double value = DFLOAT_VALUE(object); + + if (value == 0.0) { + exponent = 0; + k = 1; + strcpy(stk, "+0"); + } + else + /* calculate format parameters, adjusting scale factor */ + parse_double(stk, &exponent, value, d + k - 1); + + /* set e to a value that won't overflow */ + if (e > 16) + e = 16; + + /* set k to a value that won't overflow */ + if (k > 128) + k = 128; + else if (k < -128) + k = -128; + + /* set d to a value that won't overflow */ + if (d > 128) + d = 128; + else if (d < -128) + d = -128; + + /* how many bytes in float representation */ + length = strlen(stk) - 1; + + /* need to print a sign? */ + sign = atsign || (stk[0] == '-'); + + /* adjust number of digits after decimal point */ + if (k > 0) + d -= k - 1; + + /* adjust exponent, based on scale factor */ + exponent -= k - 1; + + /* format number, cannot overflow, as control variables were checked */ + offset = 0; + if (sign) + buffer[offset++] = stk[0]; + if (k > 0) { + if (k > length) { + memcpy(buffer + offset, stk + 1, length); + offset += length; + } + else { + memcpy(buffer + offset, stk + 1, k); + offset += k; + } + buffer[offset++] = '.'; + if (length > k) { + memcpy(buffer + offset, stk + 1 + k, length - k); + offset += length - k; + } + else + buffer[offset++] = '0'; + } + else { + int tmp = k; + + buffer[offset++] = '0'; + buffer[offset++] = '.'; + while (tmp < 0) { + buffer[offset++] = '0'; + tmp++; + } + memcpy(buffer + offset, stk + 1, length); + offset += length; + } + + /* if format, then always add a sign to exponent */ + buffer[offset++] = exponentchar; + if (format || exponent < 0) + buffer[offset++] = exponent < 0 ? '-' : '+'; + + /* XXX destroy stk contents */ + sprintf(stk, "%%0%dd", e); + /* format scale factor*/ + length = sprintf(buffer + offset, stk, + exponent < 0 ? -exponent : exponent); + /* check for overflow in exponent */ + if (length > e && overflowchar) + goto exponential_float_overflow; + offset += length; + + /* make sure only d digits are printed after decimal point */ + if (d > 0) { + int currd; + char *dptr = strchr(buffer, '.'), + *eptr = strchr(dptr, exponentchar); + + currd = eptr - dptr - 1; + length = strlen(eptr); + + /* check if need to remove excess digits */ + if (currd > d) { + int digit, dpos; + + dpos = offset = (dptr - buffer) + 1 + d; + digit = buffer[offset]; + + memmove(buffer + offset, eptr, length + 1); + /* also copy ending nul character */ + + /* adjust offset to length of total string */ + offset += length; + + /* check if need to round */ + if (dpos > 1 && isdigit(digit) && digit >= '5' && + isdigit(buffer[dpos - 1]) && + float_string_inc(buffer, dpos - 1)) + ++offset; + } + /* check if need to add extra zero digits to fill space */ + else if (pd && currd < d) { + memmove(eptr + d - currd, eptr, length + 1); + /* also copy ending nul character */ + + offset += d - currd; + for (++currd; currd <= d; currd++) + dptr[currd] = '0'; + } + /* check if need to remove zeros */ + else if (pd == NULL) { + int zeros = 1; + + while (eptr[-zeros] == '0') + ++zeros; + if (eptr[-zeros] == '.') + --zeros; + if (zeros > 1) { + memmove(eptr - zeros + 1, eptr, length + 1); + offset -= zeros - 1; + } + } + } + else { + /* no digits after decimal point */ + int digit, inc = 0; + char *dptr = strchr(buffer, '.'), + *eptr = strchr(dptr, exponentchar); + + digit = dptr[1]; + + offset = (dptr - buffer) + 1; + length = strlen(eptr); + memmove(buffer + offset, eptr, length + 1); + /* also copy ending nul character */ + + if (digit >= '5' && dptr >= buffer + 2 && + isdigit(dptr[-2])) + inc = float_string_inc(buffer, dptr - buffer - 2); + + /* adjust offset to length of total string */ + offset += length + inc; + } + + if (w > 0 && offset > w) { + /* remove leading "zero" to save space */ + if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) { + /* ending nul also copied */ + memmove(buffer + sign, buffer + sign + 1, offset); + --offset; + } + /* remove leading '+' to "save" space */ + if (offset > w && buffer[0] == '+') { + /* ending nul also copied */ + memmove(buffer, buffer + 1, offset); + --offset; + } + } + + /* if cannot represent number in given width */ + if (overflowchar && offset > w) + goto exponential_float_overflow; + + length = 0; + /* print padding if required */ + if (w > offset) + length += LispWriteChars(stream, padchar, w - offset); + + /* print float number representation */ + return (LispWriteStr(stream, buffer, offset) + length); + +exponential_float_overflow: + return (LispWriteChars(stream, overflowchar, w)); +} + +int +LispFormatGeneralFloat(LispObj *stream, LispObj *object, + int atsign, int w, int *pd, int e, int k, + int overflowchar, int padchar, int exponentchar) +{ + char stk[64]; + int length, exponent, n, dd, ee, ww, d = pd ? *pd : FLOAT_PREC; + double value = DFLOAT_VALUE(object); + + if (value == 0.0) { + exponent = 0; + n = 0; + d = 1; + strcpy(stk, "+0"); + } + else { + /* calculate format parameters, adjusting scale factor */ + parse_double(stk, &exponent, value, d + k - 1); + n = exponent + 1; + } + + /* Let ee equal e+2, or 4 if e is omitted. */ + if (e) + ee = e + 2; + else + ee = 4; + + /* Let ww equal w-ee, or nil if w is omitted. */ + if (w) + ww = w - ee; + else + ww = 0; + + dd = d - n; + if (d >= dd && dd >= 0) { + length = LispFormatFixedFloat(stream, object, atsign, ww, + &dd, 0, overflowchar, padchar); + + /* ~ee@T */ + length += LispWriteChars(stream, padchar, ee); + } + else + length = LispFormatExponentialFloat(stream, object, atsign, + w, pd, e, k, overflowchar, + padchar, exponentchar); + + return (length); +} + +int +LispFormatDollarFloat(LispObj *stream, LispObj *object, + int atsign, int collon, int d, int n, int w, int padchar) +{ + char buffer[512], stk[64]; + int sign, exponent, length, offset; + double value = DFLOAT_VALUE(object); + + if (value == 0.0) { + exponent = 0; + strcpy(stk, "+0"); + } + else + /* calculate format parameters, adjusting scale factor */ + parse_double(stk, &exponent, value, d == 0 ? FLOAT_PREC : d + 1); + + /* set d to a "sane" value */ + if (d > 128) + d = 128; + + /* set n to a "sane" value */ + if (n > 128) + n = 128; + + /* use exponent as index in stk */ + ++exponent; + + /* don't put sign in buffer, + * if collon specified, must go before padding */ + sign = atsign || (stk[0] == '-'); + + offset = 0; + + /* pad with zeros if required */ + if (exponent > 0) + n -= exponent; + while (n > 0) { + buffer[offset++] = '0'; + n--; + } + + /* how many bytes in float representation */ + length = strlen(stk) - 1; + + if (exponent > 0) { + if (exponent > length) { + memcpy(buffer + offset, stk + 1, length); + memset(buffer + offset + length, '0', exponent - length); + } + else + memcpy(buffer + offset, stk + 1, exponent); + offset += exponent; + buffer[offset++] = '.'; + if (length > exponent) { + memcpy(buffer + offset, stk + 1 + exponent, length - exponent); + offset += length - exponent; + } + else + buffer[offset++] = '0'; + } + else { + if (n > 0) + buffer[offset++] = '0'; + buffer[offset++] = '.'; + while (exponent < 0) { + buffer[offset++] = '0'; + exponent++; + } + memcpy(buffer + offset, stk + 1, length); + offset += length; + } + buffer[offset] = '\0'; + + /* make sure only d digits are printed after decimal point */ + if (d > 0) { + char *dptr = strchr(buffer, '.'); + + length = strlen(dptr) - 1; + /* check if need to remove excess digits */ + if (length > d) { + int digit; + + offset = (dptr - buffer) + 1 + d; + digit = buffer[offset]; + + /* remove extra digits */ + buffer[offset] = '\0'; + + /* check if need to round */ + if (offset > 1 && isdigit(digit) && digit >= '5' && + isdigit(buffer[offset - 1]) && + float_string_inc(buffer, offset - 1)) + ++offset; + } + /* check if need to add extra zero digits to fill space */ + else if (length < d) { + offset += d - length; + for (++length; length <= d; length++) + dptr[length] = '0'; + dptr[length] = '\0'; + } + } + else { + /* no digits after decimal point */ + int digit, inc = 0; + char *dptr = strchr(buffer, '.') + 1; + + digit = *dptr; + if (digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2])) + inc = float_string_inc(buffer, dptr - buffer - 2); + + offset = (dptr - buffer) + inc; + buffer[offset] = '\0'; + } + + length = 0; + if (sign) { + ++offset; + if (atsign && collon) + length += LispWriteChar(stream, value >= 0.0 ? '+' : '-'); + } + + /* print padding if required */ + if (w > offset) + length += LispWriteChars(stream, padchar, w - offset); + + if (atsign && !collon) + length += LispWriteChar(stream, value >= 0.0 ? '+' : '-'); + + /* print float number representation */ + return (LispWriteStr(stream, buffer, offset) + length); +} diff --git a/lisp/write.h b/lisp/write.h new file mode 100644 index 0000000..994a374 --- /dev/null +++ b/lisp/write.h @@ -0,0 +1,80 @@ +/* + * Copyright (c) 2002 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/write.h,v 1.9 2002/12/04 05:27:59 paulo Exp $ */ + +#ifndef Lisp_write_h +#define Lisp_write_h + +#include "io.h" + +/* + * Prototypes + */ +void LispWriteInit(void); + +LispObj *Lisp_FreshLine(LispBuiltin*); +LispObj *Lisp_Prin1(LispBuiltin*); +LispObj *Lisp_Princ(LispBuiltin*); +LispObj *Lisp_Print(LispBuiltin*); +LispObj *Lisp_Terpri(LispBuiltin*); +LispObj *Lisp_Write(LispBuiltin*); +LispObj *Lisp_WriteChar(LispBuiltin*); +LispObj *Lisp_WriteLine(LispBuiltin*); +LispObj *Lisp_WriteString(LispBuiltin*); + +int LispGetColumn(LispObj*); + +int LispWriteChar(LispObj*, int); +int LispWriteChars(LispObj*, int, int); +int LispWriteStr(LispObj*, char*, long); + + /* write any lisp object to stream */ +int LispWriteObject(LispObj*, LispObj*); + +/* formatted output */ + /* object must be an integer */ +int LispFormatInteger(LispObj*, LispObj*, int, int, int, int, int, int, int); + /* must be in range 1 to 3999 for new roman, 1 to 4999 for old roman */ +int LispFormatRomanInteger(LispObj*, long, int); + /* must be in range -9999999 to 9999999 */ +int LispFormatEnglishInteger(LispObj*, long, int); + /* object must be a character */ +int LispFormatCharacter(LispObj*, LispObj*, int, int); + /* object must be a float */ +int LispFormatFixedFloat(LispObj*, LispObj*, int, int, int*, int, int, int); + /* object must be a float */ +int LispFormatExponentialFloat(LispObj*, LispObj*, + int, int, int*, int, int, int, int, int); + /* object must be a float */ +int LispFormatGeneralFloat(LispObj*, LispObj*, int, + int, int*, int, int, int, int, int); +int LispFormatDollarFloat(LispObj*, LispObj*, int, int, int, int, int, int); + +#endif /* Lisp_write_h */ diff --git a/lisp/xedit.c b/lisp/xedit.c new file mode 100644 index 0000000..9ef7f8f --- /dev/null +++ b/lisp/xedit.c @@ -0,0 +1,1636 @@ +/* + * Copyright (c) 2002 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/xedit.c,v 1.24 2003/01/13 03:57:59 paulo Exp $ */ + +#include "../xedit.h" +#include <X11/Xaw/TextSrcP.h> /* Needs some private definitions */ +#include <X11/Xaw/TextSinkP.h> /* Also needs private definitions... */ +#include <X11/Xmu/Xmu.h> +#define XEDIT_LISP_PRIVATE +#include "xedit.h" +#include <signal.h> + +/* Initialize to enter lisp */ +#define LISP_SETUP() \ + int lisp__running = lisp__data.running + +/* XXX Maybe should use ualarm or better, setitimer, but one + * second seens good enough to check for interrupts */ + +#define ENABLE_SIGALRM() \ + old_sigalrm = signal(SIGALRM, SigalrmHandler); \ + alarm(1) + +#define DISABLE_SIGALRM() \ + alarm(0); \ + signal(SIGALRM, old_sigalrm) + +/* Enter lisp */ +#define LISP_ENTER() \ + if (!lisp__running) { \ + lisp__data.running = 1; \ + XFlush(XtDisplay(textwindow)); \ + ENABLE_SIGALRM(); \ + if (sigsetjmp(lisp__data.jmp, 1) != 0) { \ + DISABLE_SIGALRM(); \ + lisp__data.running = 0; \ + return; \ + } \ + } + +/* Leave lisp */ +#define LISP_LEAVE() \ + if (!lisp__running) { \ + DISABLE_SIGALRM(); \ + LispTopLevel(); \ + lisp__data.running = 0; \ + } + +/* + * Types + */ +typedef struct { + XawTextPosition left, right; + XrmQuark property; +} EntityInfo; + +/* + * Prototypes + */ +static Bool ControlGPredicate(Display*, XEvent*, XPointer); +static ssize_t WriteToStdout(int, const void*, size_t); +static ssize_t WriteToStderr(int, const void*, size_t); +static ssize_t WrapWrite(Widget, const void*, size_t); +static void XeditUpdateModeInfos(void); +static void XeditPrint(Widget, LispObj*, int); +static void XeditInteractiveCallback(Widget, XtPointer, XtPointer); +static void XeditIndentationCallback(Widget, XtPointer, XtPointer); +static LispObj *XeditCharAt(LispBuiltin*, int); +static LispObj *XeditSearch(LispBuiltin*, XawTextScanDirection); + +/* + * Initialization + */ +#ifdef SIGNALRETURNSINT +static int (*old_sigalrm)(int); +#else +static void (*old_sigalrm)(int); +#endif + +EditModeInfo *mode_infos; +Cardinal num_mode_infos; + +static LispObj *Oauto_modes, *Oauto_mode, *Osyntax_highlight, *Osyntable_indent; + +/* Just to make calling interactive reparse easier */ +static LispObj interactive_arguments[4]; + +static LispObj *justify_modes[4]; +static LispObj *wrap_modes[3]; +static LispObj *scan_types[5]; +static LispObj *scan_directions[2]; +static LispObj execute_stream; +static LispString execute_string; +static LispObj result_stream; +static LispString result_string; +static XawTextPropertyList **property_lists; +static Cardinal num_property_lists; + +/* Some hacks to (at lest try to) avoid problems reentering Xlib while + * testing for user interrupts */ +static volatile int disable_timeout, request_timeout; + +extern int pagesize; + +static LispBuiltin xeditbuiltins[] = { + {LispFunction, Xedit_AddEntity, "add-entity offset length identifier"}, + {LispFunction, Xedit_AutoFill, "auto-fill &optional value"}, + {LispFunction, Xedit_Background, "background &optional color"}, + {LispFunction, Xedit_CharAfter, "char-after &optional offset"}, + {LispFunction, Xedit_CharBefore, "char-before &optional offset"}, + {LispFunction, Xedit_ClearEntities, "clear-entities left right"}, + {LispFunction, Xedit_ConvertPropertyList, "convert-property-list name definition"}, + {LispFunction, Xedit_Font, "font &optional font"}, + {LispFunction, Xedit_Foreground, "foreground &optional color"}, + {LispFunction, Xedit_GotoChar, "goto-char offset"}, + {LispFunction, Xedit_HorizontalScrollbar, "horizontal-scrollbar &optional state"}, + {LispFunction, Xedit_Insert, "insert text"}, + {LispFunction, Xedit_Justification, "justification &optional value"}, + {LispFunction, Xedit_LeftColumn, "left-column &optional left"}, + {LispFunction, Xedit_Point, "point"}, + {LispFunction, Xedit_PointMax, "point-max"}, + {LispFunction, Xedit_PointMin, "point-min"}, + {LispFunction, Xedit_PropertyList, "property-list &optional value"}, + {LispFunction, Xedit_ReadText, "read-text offset length"}, + {LispFunction, Xedit_ReplaceText, "replace-text left right text"}, + {LispFunction, Xedit_RightColumn, "right-column &optional right"}, + {LispFunction, Xedit_Scan, "scan offset type direction &key count include"}, + {LispFunction, Xedit_SearchBackward, "search-backward string &optional offset ignore-case"}, + {LispFunction, Xedit_SearchForward, "search-forward string &optional offset ignore-case"}, + {LispFunction, Xedit_VerticalScrollbar, "vertical-scrollbar &optional state"}, + {LispFunction, Xedit_WrapMode, "wrap-mode &optional value"}, + + /* This should be available from elsewhere at some time... */ + {LispFunction, Xedit_XrmStringToQuark, "xrm-string-to-quark string"}, +}; + +/* + * Implementation + */ +/*ARGUSED*/ +static Bool +ControlGPredicate(Display *display, XEvent *event, XPointer arguments) +{ + char buffer[2]; + + return ((event->type == KeyPress || event->type == KeyRelease) && + (event->xkey.state & ControlMask) && + XLookupString(&(event->xkey), buffer, sizeof(buffer), NULL, NULL) && + buffer[0] == '\a'); +} + +/*ARGSUSED*/ +static +#ifdef SIGNALRETURNSINT +int +#else +void +#endif +SigalrmHandler(int signum) +{ + XEvent event; + + if (disable_timeout) { + request_timeout = 1; + return; + } + + /* Check if user pressed C-g */ + if (XCheckIfEvent(XtDisplay(textwindow), &event, ControlGPredicate, NULL)) { + XPutBackEvent(XtDisplay(textwindow), &event); + alarm(0); + /* Tell a signal was received, print message for SIGINT */ + LispSignal(SIGINT); + } + else + alarm(1); +#ifdef SIGNALRETURNSINT + return (0); +#endif +} + +static ssize_t +WrapWrite(Widget output, const void *buffer, size_t nbytes) +{ + XawTextBlock block; + XawTextPosition position; + + disable_timeout = 1; + position = XawTextGetInsertionPoint(output); + block.firstPos = 0; + block.format = FMT8BIT; + block.length = nbytes; + block.ptr = (String)buffer; + XawTextReplace(output, position, position, &block); + XawTextSetInsertionPoint(output, position + block.length); + disable_timeout = 0; + + if (request_timeout) { + XFlush(XtDisplay(output)); + request_timeout = 0; + SigalrmHandler(SIGALRM); + } + + return ((ssize_t)nbytes); +} + +static ssize_t +WriteToStdout(int fd, const void *buffer, size_t nbytes) +{ + return (WrapWrite(textwindow, buffer, nbytes)); +} + +static ssize_t +WriteToStderr(int fd, const void *buffer, size_t nbytes) +{ + return (WrapWrite(messwidget, buffer, nbytes)); +} + +void +LispXeditInitialize(void) +{ + int i; + char *string; + LispObj *xedit, *list, *savepackage; + + LispSetFileWrite(Stdout, WriteToStdout); + LispSetFileWrite(Stderr, WriteToStderr); + + justify_modes[0] = KEYWORD("LEFT"); + justify_modes[1] = KEYWORD("RIGHT"); + justify_modes[2] = KEYWORD("CENTER"); + justify_modes[3] = KEYWORD("FULL"); + + wrap_modes[0] = KEYWORD("NEVER"); + wrap_modes[1] = KEYWORD("LINE"); + wrap_modes[2] = KEYWORD("WORD"); + + scan_types[0] = KEYWORD("POSITIONS"); + scan_types[1] = KEYWORD("WHITE-SPACE"); + scan_types[2] = KEYWORD("EOL"); + scan_types[3] = KEYWORD("PARAGRAPH"); + scan_types[4] = KEYWORD("ALL"); + scan_types[5] = KEYWORD("ALPHA-NUMERIC"); + + scan_directions[0] = justify_modes[0]; + scan_directions[1] = justify_modes[1]; + + /* Remember value of current package */ + savepackage = PACKAGE; + + /* Create the XEDIT package */ + xedit = LispNewPackage(STRING("XEDIT"), NIL); + + /* Update list of packages */ + PACK = CONS(xedit, PACK); + + /* Temporarily switch to the XEDIT package */ + lisp__data.pack = lisp__data.savepack = xedit->data.package.package; + PACKAGE = xedit; + + /* Add XEDIT builtin functions */ + for (i = 0; i < sizeof(xeditbuiltins) / sizeof(xeditbuiltins[0]); i++) + LispAddBuiltinFunction(&xeditbuiltins[i]); + + /* Create these objects in the xedit package */ + Oauto_modes = STATIC_ATOM("*AUTO-MODES*"); + Oauto_mode = STATIC_ATOM("AUTO-MODE"); + Osyntax_highlight = STATIC_ATOM("SYNTAX-HIGHLIGHT"); + Osyntable_indent = STATIC_ATOM("SYNTABLE-INDENT"); + + /* Import symbols from the LISP and EXT packages */ + for (list = PACK; CONSP(list); list = CDR(list)) { + string = THESTR(CAR(list)->data.package.name); + if (strcmp(string, "LISP") == 0 || strcmp(string, "EXT") == 0) + LispUsePackage(CAR(list)); + } + + /* Restore previous package */ + lisp__data.pack = savepackage->data.package.package; + PACKAGE = savepackage; + + /* Initialize helper static objects used when executing expressions */ + execute_stream.type = LispStream_t; + execute_stream.data.stream.source.string = &execute_string; + execute_stream.data.stream.pathname = NIL; + execute_stream.data.stream.type = LispStreamString; + execute_stream.data.stream.readable = 1; + execute_stream.data.stream.writable = 0; + execute_string.output = 0; + result_stream.type = LispStream_t; + result_stream.data.stream.source.string = &result_string; + result_stream.data.stream.pathname = NIL; + result_stream.data.stream.type = LispStreamString; + result_stream.data.stream.readable = 0; + result_stream.data.stream.writable = 1; + result_string.string = XtMalloc(pagesize); + result_string.space = pagesize; + + /* Initialize interactive edition function arguments */ + /* first argument is syntax table */ + interactive_arguments[0].type = LispCons_t; + interactive_arguments[0].data.cons.cdr = &interactive_arguments[1]; + /* second argument is where to start reparsing */ + interactive_arguments[1].type = LispCons_t; + interactive_arguments[1].data.cons.cdr = &interactive_arguments[2]; + /* third argument is where to stop reparsing */ + interactive_arguments[2].type = LispCons_t; + interactive_arguments[2].data.cons.cdr = &interactive_arguments[3]; + /* fourth argument is interactive flag */ + interactive_arguments[3].type = LispCons_t; + interactive_arguments[3].data.cons.car = T; + interactive_arguments[3].data.cons.cdr = NIL; + + /* Load extra functions and data type definitions */ + EXECUTE("(require \"xedit\")"); + + + /* + * This assumes that the *auto-modes* variable is a list where every + * item has the format: + * (regexp string-desc load-file-desc . symbol-name) + * Minimal error checking is done. + */ + + if (Oauto_modes->data.atom->a_object) { + LispObj *desc, *modes = Oauto_modes->data.atom->property->value; + + for (; CONSP(modes); modes = CDR(modes)) { + list = CAR(modes); + + desc = NIL; + for (i = 0; i < 3 && CONSP(list); i++, list = CDR(list)) { + if (i == 1) + desc = CAR(list); + } + if (i == 3 && STRINGP(desc)) { + mode_infos = (EditModeInfo*) + XtRealloc((XtPointer)mode_infos, sizeof(EditModeInfo) * + (num_mode_infos + 1)); + mode_infos[num_mode_infos].desc = XtNewString(THESTR(desc)); + mode_infos[num_mode_infos].symbol = list; + mode_infos[num_mode_infos].syntax = NULL; + ++num_mode_infos; + } + } + } +} + +static void +XeditUpdateModeInfos(void) +{ + int i; + + for (i = 0; i < num_mode_infos; i++) { + if (mode_infos[i].symbol && + mode_infos[i].syntax == NULL && + XSYMBOLP(mode_infos[i].symbol) && + mode_infos[i].symbol->data.atom->a_object) + mode_infos[i].syntax = + mode_infos[i].symbol->data.atom->property->value; + } +} + +void +XeditLispExecute(Widget output, XawTextPosition left, XawTextPosition right) +{ + GC_ENTER(); + LISP_SETUP(); + int alloced, return_count; + XawTextBlock block; + XawTextPosition position; + char *string, *ptr; + LispObj *result, *code, *_cod, *returns; + + LISP_ENTER(); + + position = left; + XawTextSourceRead(XawTextGetSource(textwindow), left, &block, right - left); + if (block.length < right - left) { + alloced = 1; + string = ptr = LispMalloc(right - left); + memcpy(ptr, block.ptr, block.length); + position = left + block.length; + ptr += block.length; + for (; position < right;) { + XawTextSourceRead(XawTextGetSource(textwindow), + position, &block, right - position); + memcpy(ptr, block.ptr, block.length); + position += block.length; + ptr += block.length; + } + } + else { + alloced = 0; + string = block.ptr; + } + + execute_string.string = string; + execute_string.length = right - left; + execute_string.input = 0; + LispPushInput(&execute_stream); + _cod = COD; + result = NIL; + if ((code = LispRead()) != NULL) + result = EVAL(code); + COD = _cod; + LispPopInput(&execute_stream); + + returns = NIL; + if (RETURN_COUNT > 0) { + GC_PROTECT(result); + returns = _cod = CONS(RETURN(0), NIL); + GC_PROTECT(returns); + for (return_count = 1; return_count < RETURN_COUNT; return_count++) { + RPLACD(_cod, CONS(RETURN(return_count), NIL)); + _cod = CDR(_cod); + } + } + LispFflush(Stdout); + LispUpdateResults(code, result); + if (RETURN_COUNT >= 0) { + XeditPrint(output, result, 1); + for (; CONSP(returns); returns = CDR(returns)) + XeditPrint(output, CAR(returns), 0); + } + + if (alloced) + LispFree(string); + GC_LEAVE(); + + LISP_LEAVE(); +} + +static void +XeditPrint(Widget output, LispObj *object, int newline) +{ + XawTextBlock block; + XawTextPosition position; + + result_string.length = result_string.output = 0; + if (newline) { + position = XawTextGetInsertionPoint(output); + if (position != XawTextSourceScan(XawTextGetSource(output), + position, XawstEOL, + XawsdLeft, 1, False)) + LispSputc(&result_string, '\n'); + } + LispWriteObject(&result_stream, object); + LispSputc(&result_string, '\n'); + + position = XawTextGetInsertionPoint(output); + block.firstPos = 0; + block.format = FMT8BIT; + block.length = result_string.length; + block.ptr = result_string.string; + XawTextReplace(output, position, position, &block); + XawTextSetInsertionPoint(output, position + block.length); +} + +/* + * This function is defined here to avoid exporting all the lisp interfaces + * to the core xedit code. + */ +void +XeditLispSetEditMode(xedit_flist_item *item, LispObj *symbol) +{ + GC_ENTER(); + LISP_SETUP(); + LispObj *syntax, *name; + + item->xldata = (XeditLispData*)XtCalloc(1, sizeof(XeditLispData)); + + LISP_ENTER(); + + /* Create an object that represents the buffer filename. + * Note that the entire path is passed to the auto-mode + * function, so that directory names may be also be used + * when determining a file type. */ + name = STRING(item->filename); + GC_PROTECT(name); + + /* Call the AUTO-MODE function to check if there is a + * syntax definition for the file being loaded */ + if (symbol == NULL) + syntax = APPLY1(Oauto_mode, name); + else + syntax = APPLY2(Oauto_mode, name, symbol); + + /* Don't need the name object anymore */ + GC_LEAVE(); + + if (syntax != NIL) { + Arg arg[1]; + LispObj arguments; + XawTextPropertyList *property_list; + + item->xldata->syntax = syntax; + + /* Apply the syntax highlight to the current buffer */ + arguments.type = LispCons_t; + arguments.data.cons.car = syntax; + arguments.data.cons.cdr = NIL; + LispFuncall(Osyntax_highlight, &arguments, 1); + + /* The previous call added the property list to the widget, + * remember it when switching sources. */ + XtSetArg(arg[0], XawNtextProperties, &property_list); + XtGetValues(XawTextGetSink(textwindow), arg, 1); + item->properties = property_list; + + /* Add callback for interactive changes */ + XtAddCallback(item->source, XtNpropertyCallback, + XeditInteractiveCallback, item->xldata); + + /* Update information as a new file may have been loaded */ + XeditUpdateModeInfos(); + } + else + item->properties = NULL; + + LISP_LEAVE(); +} + +void +XeditLispUnsetEditMode(xedit_flist_item *item) +{ + if (item->xldata) { + XtRemoveCallback(item->source, XtNpropertyCallback, + XeditInteractiveCallback, item->xldata); + XtFree((XtPointer)item->xldata); + item->xldata = NULL; + } +} + +#define MAX_INFOS 32 +/* + * This callback tries to do it's best in generating correct output while + * also doing minimal work/redrawing of the screen. It probably will fail + * for some syntax-definitions, or will just not properly repaint the + * screen. In the later case, just press Ctrl+L. + * There isn't yet any command to force reparsing of some regions, and if + * the parser becomes confused, you may need to go to a line, press a space + * and undo, just to force it to reparse the line, and possibly some extra + * lines until the parser thinks the display is in sync. + * Sometimes it will repaint a lot more of text than what is being requested + * by this callback, this should be fixed at some time, as for certain cases + * it is also required some redesign in the Xaw interface. + */ +static void +XeditInteractiveCallback(Widget w, XtPointer client_data, XtPointer call_data) +{ + LISP_SETUP(); + XeditLispData *data = (XeditLispData*)client_data; + LispObj *syntax = data->syntax; + XawTextPropertyInfo *info = (XawTextPropertyInfo*)call_data; + LispObj *result, *syntable; + XawTextAnchor *anchor; + XawTextEntity *entity; + XawTextPosition first, last, left, right, begin, next, tmp, position; + int i, j, indent; + TextSrcObject src = (TextSrcObject)w; + EntityInfo oinfo[MAX_INFOS], ninfo[MAX_INFOS]; + XrmQuark props[MAX_INFOS]; + int num_oinfo, num_ninfo, num_props; + XmuScanline *clip, *oclip, *nclip; + XmuSegment segment, *seg; + + if (data->disable_highlight) + return; + + LISP_ENTER(); + + first = XawTextSourceScan(w, 0, XawstAll, XawsdLeft, 1, True); + last = XawTextSourceScan(w, 0, XawstAll, XawsdRight, 1, True); + + left = info->left; + right = left + info->block->length; + + /* For now, only call the indent hook if a single character was typed */ + indent = (info->right == left) && (right == left + 1); + + /* Always reparse full lines */ + left = begin = XawTextSourceScan(w, left, XawstEOL, XawsdLeft, 1, False); + right = next = XawTextSourceScan(w, right, XawstEOL, XawsdRight, 1, False); + + + /* Check properties in the modified text. If a complex nested syntax + * table was parsed, the newline has it's default property, so, while + * the newline has a property, backup a line to make sure everything is + * properly parsed. + * Maybe should limit the number of backuped lines, but if the parsing + * becomes noticeable slow, better to rethink the syntax definition. */ + while (left > first) { + position = XawTextSourceScan(w, left, XawstEOL, XawsdLeft, 1, True); + if (XawTextSourceAnchorAndEntity(w, position, &anchor, &entity)) + left = XawTextSourceScan(w, left, XawstEOL, XawsdLeft, 2, False); + else + break; + } + + /* While the newline after the right position has a "hidden" property, + * keep incrementing a line to be reparsed. */ + while (right < last) { + if (XawTextSourceAnchorAndEntity(w, right, &anchor, &entity)) + right = XawTextSourceScan(w, right, XawstEOL, XawsdRight, 2, False); + else + break; + } + +#ifndef MAX +#define MAX(a, b) ((a) > (b) ? (a) : (b)) +#endif + +#ifndef MIN +#define MIN(a, b) ((a) < (b) ? (a) : (b)) +#endif + +#define STORE_STATE(count, info, from, to) \ + (count) = 0; \ + if ((anchor = XawTextSourceFindAnchor(w, (from))) != NULL) { \ + entity = anchor->entities; \ + /* Find first entity in the region to parse */ \ + while (entity && \ + anchor->position + entity->offset + entity->length <= \ + (from)) \ + entity = entity->next; \ + /* Loop storing information */ \ + while (entity && \ + (position = anchor->position + entity->offset) < (to)) { \ + (info)[(count)].left = MAX(position, (from)); \ + position += entity->length; \ + (info)[(count)].right = MIN(position, (to)); \ + (info)[(count)].property = entity->property; \ + /* If the changes are so complex, user need press Ctrl+L */ \ + if (++(count) >= MAX_INFOS) \ + break; \ + if ((entity = entity->next) == NULL && \ + (anchor = XawTextSourceNextAnchor(w, anchor)) != NULL) \ + entity = anchor->entities; \ + } \ + } + + /* Remember old state */ + STORE_STATE(num_oinfo, oinfo, begin, right); + + /* Reparse the lines in the modified/edited range of text */ + interactive_arguments[0].data.cons.car = syntax; + interactive_arguments[1].data.cons.car = FIXNUM(left); + interactive_arguments[2].data.cons.car = FIXNUM(right); + result = APPLY(Osyntax_highlight, &interactive_arguments[0]); + /* Indent table is the second return value */ + if (RETURN_COUNT) + syntable = RETURN(0); + else + syntable = NIL; + + /* This normally is the same value as right, but the parser may have + * continued when the syntax table stack did not finish. */ + if (FIXNUMP(result)) + right = FIXNUM_VALUE(result); + + LISP_LEAVE(); + + /* Check what have changed */ + STORE_STATE(num_ninfo, ninfo, begin, right); + + /* Initialize to redraw everything. */ + clip = XmuNewScanline(0, begin, right); + +#define CLIP_MASK(mask, from, to) \ + if ((from) < (to)) { \ + segment.x1 = (from); \ + segment.x2 = (to); \ + XmuScanlineOrSegment((mask), &segment); \ + } + + oclip = XmuNewScanline(0, 0, 0); + nclip = XmuNewScanline(0, 0, 0); + +#define CLIP_DEFAULT(mask, from, info, num_info) \ + for (tmp = (from), i = 0; i < (num_info); i++) { \ + CLIP_MASK((mask), tmp, (info)[i].left); \ + tmp = (info)[i].right; \ + } + + /* First generate masks of regions with the default property */ + CLIP_DEFAULT(oclip, begin, oinfo, num_oinfo); + CLIP_DEFAULT(nclip, begin, ninfo, num_ninfo); + + /* Store unchanged region in oclip */ + XmuScanlineAnd(oclip, nclip); + + /* Don't need to redraw the region in oclip */ + XmuScanlineXor(clip, oclip); + +#define LIST_PROPERTIES(prop, num_prop, info, num_info) \ + (num_prop) = 0; \ + for (i = 0; i < (num_info); i++) { \ + for (j = 0; j < (num_prop); j++) \ + if ((prop)[j] == (info)[i].property) \ + break; \ + if (j == (num_prop)) \ + (prop)[(num_prop)++] = (info)[i].property; \ + } + + /* Prepare to generate masks of regions of text with defined properties */ + LIST_PROPERTIES(props, num_props, oinfo, num_oinfo); + +#define CLIP_PROPERTY(mask, prop, info, num_info) \ + for (j = 0; j < (num_info); j++) { \ + if ((info)[j].property == (prop)) { \ + CLIP_MASK((mask), (info)[j].left, (info)[j].right); \ + } \ + } + + /* Only care about the old properties, new ones need to be redrawn */ + for (i = 0; i < num_props; i++) { + XrmQuark property = props[i]; + + /* Reset oclip and nclip */ + XmuScanlineXor(oclip, oclip); + XmuScanlineXor(nclip, nclip); + + /* Generate masks */ + CLIP_PROPERTY(oclip, property, oinfo, num_oinfo); + CLIP_PROPERTY(nclip, property, ninfo, num_ninfo); + + /* Store unchanged region in oclip */ + XmuScanlineAnd(oclip, nclip); + + /* Don't need to redraw the region in oclip */ + XmuScanlineXor(clip, oclip); + XmuOptimizeScanline(clip); + } + + XmuDestroyScanline(oclip); + XmuDestroyScanline(nclip); + + /* Tell Xaw that need update some regions */ + for (seg = clip->segment; seg; seg = seg->next) { + for (i = 0; i < src->textSrc.num_text; i++) + /* This really should have an exported interface... */ + _XawTextNeedsUpdating((TextWidget)(src->textSrc.text[i]), + seg->x1, seg->x2 + (seg->x2 > next)); + } + XmuDestroyScanline(clip); + + data->syntable = syntable; + /* XXX check lisp__running to know if at the toplevel parsing state */ + if (indent && syntable != NIL && !lisp__running && + /* Doing an undo, probably will need an exported interface for this + * case. Should not change the text now. */ + (!src->textSrc.enable_undo || !src->textSrc.undo_state)) + XtAddCallback(textwindow, XtNpositionCallback, + XeditIndentationCallback, data); +} + +/* + * This callback is called if the syntax table where the cursor is located + * defines an indentation function. + */ +static void +XeditIndentationCallback(Widget w, XtPointer client_data, XtPointer call_data) +{ + LISP_SETUP(); + LispObj *indentp; + XeditLispData *data = (XeditLispData*)client_data; + + data->disable_highlight = True; + XtRemoveCallback(w, XtNpositionCallback, XeditIndentationCallback, data); + + LISP_ENTER(); + + /* Get pointer to indentation function */ + indentp = APPLY1(Osyntable_indent, data->syntable); + + /* Execute indentation function */ + if (indentp != NIL) + APPLY2(indentp, data->syntax, data->syntable); + + data->disable_highlight = False; + + LISP_LEAVE(); +} + +/************************************************************************ + * Builtin functions + ************************************************************************/ +LispObj * +Xedit_AddEntity(LispBuiltin *builtin) +/* + add-entity offset length identifier + */ +{ + LispObj *offset, *length, *identifier; + + identifier = ARGUMENT(2); + length = ARGUMENT(1); + offset = ARGUMENT(0); + + CHECK_INDEX(offset); + CHECK_INDEX(length); + CHECK_LONGINT(identifier); + + return (XawTextSourceAddEntity(XawTextGetSource(textwindow), 0, 0, NULL, + FIXNUM_VALUE(offset), FIXNUM_VALUE(length), + LONGINT_VALUE(identifier)) ? T : NIL); +} + +LispObj * +Xedit_AutoFill(LispBuiltin *builtin) +/* + auto-fill &optional value + */ +{ + Arg arg[1]; + Boolean state; + + LispObj *value; + + value = ARGUMENT(0); + + if (value != UNSPEC) { + XtSetArg(arg[0], XtNautoFill, value == NIL ? False : True); + XtSetValues(textwindow, arg, 1); + } + else { + XtSetArg(arg[0], XtNautoFill, &state); + XtGetValues(textwindow, arg, 1); + value = state ? T : NIL; + } + + return (value); +} + +LispObj * +Xedit_Background(LispBuiltin *builtin) +/* + background &optional color + */ +{ + Pixel pixel; + Arg arg[1]; + XrmValue from, to; + + LispObj *color; + + color = ARGUMENT(0); + + if (color != UNSPEC) { + CHECK_STRING(color); + + from.size = STRLEN(color); + from.addr = (XtPointer)THESTR(color); + to.size = sizeof(Pixel); + to.addr = (XtPointer)&pixel; + + if (!XtConvertAndStore(XawTextGetSink(textwindow), + XtRString, &from, XtRPixel, &to)) + LispDestroy("cannot convert %s to Pixel", STROBJ(color)); + + XtSetArg(arg[0], XtNbackground, pixel); + XtSetValues(textwindow, arg, 1); + } + else { + from.size = sizeof(Pixel); + from.addr = (XtPointer)&pixel; + to.size = 0; + to.addr = NULL; + + XtSetArg(arg[0], XtNbackground, &pixel); + XtGetValues(XawTextGetSink(textwindow), arg, 1); + /* This cannot fail */ + XtConvertAndStore(textwindow, XtRPixel, &from, XtRString, &to); + + color = STRING(to.addr); + } + + return (color); +} + +static LispObj * +XeditCharAt(LispBuiltin *builtin, int before) +{ + Widget source = XawTextGetSource(textwindow); + XawTextPosition first, point, last; + XawTextBlock block; + + LispObj *offset; + + offset = ARGUMENT(0); + if (offset != UNSPEC) { + CHECK_INDEX(offset); + } + + first = XawTextSourceScan(source, 0, XawstAll, XawsdLeft, 1, True); + if (FIXNUMP(offset)) + point = FIXNUM_VALUE(offset); + else + point = XawTextGetInsertionPoint(textwindow); + if (before && point > first) { + XawTextPosition position = + XawTextSourceScan(source, point, XawstPositions, XawsdLeft, 1, True); + + if (position < point) + point = position; + else + return (NIL); + } + last = XawTextSourceScan(source, 0, XawstAll, XawsdRight, 1, True); + + if (point < first || point > last) + return (NIL); + + XawTextSourceRead(source, point, &block, 1); + + return (block.length ? SCHAR(*(unsigned char*)block.ptr) : NIL); +} + +LispObj * +Xedit_CharAfter(LispBuiltin *builtin) +/* + char-after &optional offset + */ +{ + return (XeditCharAt(builtin, 0)); +} + +LispObj * +Xedit_CharBefore(LispBuiltin *builtin) +/* + char-before &optional offset + */ +{ + return (XeditCharAt(builtin, 1)); +} + +LispObj * +Xedit_ClearEntities(LispBuiltin *builtin) +/* + clear-entities left right + */ +{ + LispObj *left, *right; + + right = ARGUMENT(1); + left = ARGUMENT(0); + + CHECK_INDEX(left); + CHECK_INDEX(right); + + XawTextSourceClearEntities(XawTextGetSource(textwindow), + FIXNUM_VALUE(left), FIXNUM_VALUE(right)); + + return (T); +} + +LispObj * +Xedit_ConvertPropertyList(LispBuiltin *builtin) +/* + convert-property-list name definition + */ +{ + LispObj *result; + XawTextPropertyList *property_list; + + LispObj *name, *definition; + + definition = ARGUMENT(1); + name = ARGUMENT(0); + + CHECK_STRING(name); + CHECK_STRING(definition); + + result = NIL; + property_list = XawTextSinkConvertPropertyList(THESTR(name), + THESTR(definition), + topwindow->core.screen, + topwindow->core.colormap, + topwindow->core.depth); + + if (property_list) { + Cardinal i; + + for (i = 0; i < num_property_lists; i++) + /* Check if a new property list was created */ + if (property_lists[i]->identifier == property_list->identifier) + break; + + /* Remember this pointer when asked back for it */ + if (i == num_property_lists) { + property_lists = (XawTextPropertyList**) + XtRealloc((XtPointer)property_lists, + sizeof(XawTextPropertyList) * + (num_property_lists + 1)); + property_lists[num_property_lists++] = property_list; + } + result = INTEGER(property_list->identifier); + } + + return (result); +} + +LispObj * +Xedit_Font(LispBuiltin *builtin) +/* + font &optional font + */ +{ + XFontStruct *font_struct; + Arg arg[1]; + XrmValue from, to; + + LispObj *font; + + font = ARGUMENT(0); + + if (font != UNSPEC) { + CHECK_STRING(font); + + from.size = STRLEN(font); + from.addr = (XtPointer)THESTR(font); + to.size = sizeof(XFontStruct*); + to.addr = (XtPointer)&font_struct; + + if (!XtConvertAndStore(textwindow, XtRString, &from, XtRFontStruct, &to)) + LispDestroy("cannot convert %s to FontStruct", STROBJ(font)); + + XtSetArg(arg[0], XtNfont, font_struct); + XtSetValues(textwindow, arg, 1); + } + else { + from.size = sizeof(XFontStruct*); + from.addr = (XtPointer)&font_struct; + to.size = 0; + to.addr = NULL; + + XtSetArg(arg[0], XtNfont, &font_struct); + XtGetValues(XawTextGetSink(textwindow), arg, 1); + /* This cannot fail */ + XtConvertAndStore(textwindow, XtRFontStruct, &from, XtRString, &to); + + font = STRING(to.addr); + } + + return (font); +} + +LispObj * +Xedit_Foreground(LispBuiltin *builtin) +/* + foreground &optional color + */ +{ + Pixel pixel; + Arg arg[1]; + XrmValue from, to; + + LispObj *color; + + color = ARGUMENT(0); + + if (color != UNSPEC) { + CHECK_STRING(color); + + from.size = STRLEN(color); + from.addr = (XtPointer)THESTR(color); + to.size = sizeof(Pixel); + to.addr = (XtPointer)&pixel; + + if (!XtConvertAndStore(XawTextGetSink(textwindow), + XtRString, &from, XtRPixel, &to)) + LispDestroy("cannot convert %s to Pixel", STROBJ(color)); + + XtSetArg(arg[0], XtNforeground, pixel); + XtSetValues(textwindow, arg, 1); + } + else { + from.size = sizeof(Pixel); + from.addr = (XtPointer)&pixel; + to.size = 0; + to.addr = NULL; + + XtSetArg(arg[0], XtNforeground, &pixel); + XtGetValues(XawTextGetSink(textwindow), arg, 1); + /* This cannot fail */ + XtConvertAndStore(textwindow, XtRPixel, &from, XtRString, &to); + + color = STRING(to.addr); + } + + return (color); +} + +LispObj * +Xedit_GotoChar(LispBuiltin *builtin) +/* + goto-char offset + */ +{ + LispObj *offset; + XawTextPosition point; + + offset = ARGUMENT(0); + + CHECK_INDEX(offset); + XawTextSetInsertionPoint(textwindow, FIXNUM_VALUE(offset)); + point = XawTextGetInsertionPoint(textwindow); + if (point != FIXNUM_VALUE(offset)) + offset = FIXNUM(point); + + return (offset); +} + +LispObj * +Xedit_HorizontalScrollbar(LispBuiltin *builtin) +/* + horizontal-scrollbar &optional state + */ +{ + Arg arg[1]; + XawTextScrollMode scroll; + + LispObj *state; + + state = ARGUMENT(0); + + if (state != UNSPEC) { + scroll = state == NIL ? XawtextScrollNever : XawtextScrollAlways; + XtSetArg(arg[0], XtNscrollHorizontal, scroll); + XtSetValues(textwindow, arg, 1); + } + else { + XtSetArg(arg[0], XtNscrollHorizontal, &scroll); + XtGetValues(textwindow, arg, 1); + state = scroll == XawtextScrollAlways ? T : NIL; + } + + return (state); +} + +LispObj * +Xedit_Insert(LispBuiltin *builtin) +/* + insert text + */ +{ + XawTextPosition point = XawTextGetInsertionPoint(textwindow); + XawTextBlock block; + + LispObj *text; + + text = ARGUMENT(0); + + CHECK_STRING(text); + + block.firstPos = 0; + block.format = FMT8BIT; + block.length = STRLEN(text); + block.ptr = THESTR(text); + XawTextReplace(textwindow, point, point, &block); + XawTextSetInsertionPoint(textwindow, point + block.length); + + return (text); +} + +LispObj * +Xedit_Justification(LispBuiltin *builtin) +/* + justification &optional value + */ +{ + int i; + Arg arg[1]; + XawTextJustifyMode justify; + + LispObj *value; + + value = ARGUMENT(0); + + if (value != UNSPEC) { + for (i = 0; i < 4; i++) + if (value == justify_modes[i]) + break; + if (i >= 4) + LispDestroy("%s: argument must be " + ":LEFT, :RIGHT, :CENTER, or :FULL, not %s", + STRFUN(builtin), STROBJ(value)); + XtSetArg(arg[0], XtNjustifyMode, (XawTextJustifyMode)i); + XtSetValues(textwindow, arg, 1); + } + else { + XtSetArg(arg[0], XtNjustifyMode, &justify); + XtGetValues(textwindow, arg, 1); + i = (int)justify; + if (i <= 0 || i >= 4) + i = 0; + value = justify_modes[i]; + } + + return (value); +} + +LispObj * +Xedit_LeftColumn(LispBuiltin *builtin) +/* + left-column &optional left + */ +{ + short left; + Arg arg[1]; + + LispObj *oleft; + + oleft = ARGUMENT(0); + + if (oleft != UNSPEC) { + CHECK_INDEX(oleft); + if (FIXNUM_VALUE(oleft) >= 32767) + left = 32767; + else + left = FIXNUM_VALUE(oleft); + + XtSetArg(arg[0], XtNleftColumn, left); + XtSetValues(textwindow, arg, 1); + } + else { + XtSetArg(arg[0], XtNleftColumn, &left); + XtGetValues(textwindow, arg, 1); + + oleft = FIXNUM((long)left); + } + + return (oleft); +} + +LispObj * +Xedit_Point(LispBuiltin *builtin) +/* + point + */ +{ + return (FIXNUM(XawTextGetInsertionPoint(textwindow))); +} + +LispObj * +Xedit_PointMax(LispBuiltin *builtin) +/* + point-max + */ +{ + return (FIXNUM(XawTextSourceScan(XawTextGetSource(textwindow), 0, + XawstAll, XawsdRight, 1, True))); +} + +LispObj * +Xedit_PointMin(LispBuiltin *builtin) +/* + point-min + */ +{ + return (FIXNUM(XawTextSourceScan(XawTextGetSource(textwindow), 0, + XawstAll, XawsdLeft, 1, True))); +} + +LispObj * +Xedit_PropertyList(LispBuiltin *builtin) +/* + property-list &optional value + */ +{ + Arg arg[1]; + XawTextPropertyList *property_list; + + LispObj *value; + + value = ARGUMENT(0); + + if (value != UNSPEC) { + Cardinal i; + XrmQuark quark; + + CHECK_LONGINT(value); + property_list = NULL; + quark = LONGINT_VALUE(value); + for (i = 0; i < num_property_lists; i++) + if (property_lists[i]->identifier == quark) { + property_list = property_lists[i]; + break; + } + + if (property_list) { + XtSetArg(arg[0], XawNtextProperties, property_list); + XtSetValues(XawTextGetSink(textwindow), arg, 1); + } + else + /* Maybe should generate an error here */ + value = NIL; + } + else { + XtSetArg(arg[0], XawNtextProperties, &property_list); + XtGetValues(XawTextGetSink(textwindow), arg, 1); + if (property_list) + value = INTEGER(property_list->identifier); + } + + return (value); +} + +LispObj * +Xedit_ReadText(LispBuiltin *builtin) +/* + read-text offset length + */ +{ + XawTextPosition last = XawTextSourceScan(XawTextGetSource(textwindow), 0, + XawstAll, XawsdRight, 1, True); + XawTextPosition from, to, len; + XawTextBlock block; + char *string, *ptr; + + LispObj *offset, *length; + + length = ARGUMENT(1); + offset = ARGUMENT(0); + + CHECK_INDEX(offset); + CHECK_INDEX(length); + + from = FIXNUM_VALUE(offset); + to = from + FIXNUM_VALUE(length); + if (from > last) + from = last; + if (to > last) + to = last; + + if (from == to) + return (STRING("")); + + len = to - from; + string = LispMalloc(len); + + for (ptr = string; from < to;) { + XawTextSourceRead(XawTextGetSource(textwindow), from, &block, to - from); + memcpy(ptr, block.ptr, block.length); + ptr += block.length; + from += block.length; + } + + return (LSTRING2(string, len)); +} + +LispObj * +Xedit_ReplaceText(LispBuiltin *builtin) +/* + replace-text left right text + */ +{ + XawTextPosition last = XawTextSourceScan(XawTextGetSource(textwindow), 0, + XawstAll, XawsdRight, 1, True); + XawTextPosition left, right; + XawTextBlock block; + + LispObj *oleft, *oright, *text; + + text = ARGUMENT(2); + oright = ARGUMENT(1); + oleft = ARGUMENT(0); + + CHECK_INDEX(oleft); + CHECK_INDEX(oright); + CHECK_STRING(text); + + left = FIXNUM_VALUE(oleft); + right = FIXNUM_VALUE(oright); + if (left > last) + left = last; + if (left > right) + right = left; + else if (right > last) + right = last; + + block.firstPos = 0; + block.format = FMT8BIT; + block.length = STRLEN(text); + block.ptr = THESTR(text); + XawTextReplace(textwindow, left, right, &block); + + return (text); +} + +LispObj * +Xedit_RightColumn(LispBuiltin *builtin) +/* + right-column &optional right + */ +{ + short right; + Arg arg[1]; + + LispObj *oright; + + oright = ARGUMENT(0); + + if (oright != UNSPEC) { + CHECK_INDEX(oright); + if (FIXNUM_VALUE(oright) >= 32767) + right = 32767; + else + right = FIXNUM_VALUE(oright); + + XtSetArg(arg[0], XtNrightColumn, right); + XtSetValues(textwindow, arg, 1); + } + else { + XtSetArg(arg[0], XtNrightColumn, &right); + XtGetValues(textwindow, arg, 1); + + oright = FIXNUM(right); + } + + return (oright); +} + +LispObj * +Xedit_Scan(LispBuiltin *builtin) +/* + scan offset type direction &key count include + */ +{ + int i; + XawTextPosition offset; + XawTextScanType type; + XawTextScanDirection direction; + int count; + + LispObj *ooffset, *otype, *odirection, *ocount, *include; + + include = ARGUMENT(4); + if (include == UNSPEC) + include = NIL; + ocount = ARGUMENT(3); + odirection = ARGUMENT(2); + otype = ARGUMENT(1); + ooffset = ARGUMENT(0); + + CHECK_INDEX(ooffset); + offset = FIXNUM_VALUE(ooffset); + + for (i = 0; i < 2; i++) + if (odirection == scan_directions[i]) + break; + if (i >= 2) + LispDestroy("%s: direction must be " + ":LEFT or :RIGHT, not %s", + STRFUN(builtin), STROBJ(odirection)); + direction = (XawTextScanDirection)i; + + for (i = 0; i < 5; i++) + if (otype == scan_types[i]) + break; + if (i >= 5) + LispDestroy("%s: direction must be " + ":POSITIONS, :WHITE-SPACE, :EOL, " + ":PARAGRAPH, :ALL, or :ALPHA-NUMERIC, not %s", + STRFUN(builtin), STROBJ(otype)); + type = (XawTextScanType)i; + + if (ocount == UNSPEC) + count = 1; + else { + CHECK_INDEX(ocount); + count = FIXNUM_VALUE(ocount); + } + + offset = XawTextSourceScan(XawTextGetSource(textwindow), + offset, type, direction, count, + include != NIL); + + return (FIXNUM(offset)); +} + +static LispObj * +XeditSearch(LispBuiltin *builtin, XawTextScanDirection direction) +{ + XawTextBlock block; + XawTextPosition position; + + LispObj *string, *offset, *ignore_case; + + ignore_case = ARGUMENT(2); + offset = ARGUMENT(1); + string = ARGUMENT(0); + + CHECK_STRING(string); + if (offset != UNSPEC) { + CHECK_INDEX(offset); + position = FIXNUM_VALUE(offset); + } + else + position = XawTextGetInsertionPoint(textwindow); + + block.firstPos = (ignore_case != UNSPEC && ignore_case != NIL) ? 1 : 0; + block.format = FMT8BIT; + block.length = STRLEN(string); + block.ptr = THESTR(string); + position = XawTextSourceSearch(XawTextGetSource(textwindow), + position, direction, &block); + + return (position != XawTextSearchError ? FIXNUM(position) : NIL); +} + + +LispObj * +Xedit_SearchBackward(LispBuiltin *builtin) +/* + search-backward string &optional offset ignore-case + */ +{ + return (XeditSearch(builtin, XawsdLeft)); +} + +LispObj * +Xedit_SearchForward(LispBuiltin *builtin) +/* + search-forward string &optional offset ignore-case + */ +{ + return (XeditSearch(builtin, XawsdRight)); +} + +LispObj * +Xedit_VerticalScrollbar(LispBuiltin *builtin) +/* + vertical-scrollbar &optional state + */ +{ + Arg arg[1]; + XawTextScrollMode scroll; + + LispObj *state; + + state = ARGUMENT(0); + + if (state != UNSPEC) { + scroll = state == NIL ? XawtextScrollNever : XawtextScrollAlways; + XtSetArg(arg[0], XtNscrollVertical, scroll); + XtSetValues(textwindow, arg, 1); + } + else { + XtSetArg(arg[0], XtNscrollVertical, &scroll); + XtGetValues(textwindow, arg, 1); + state = scroll == XawtextScrollAlways ? T : NIL; + } + + return (state); +} + +LispObj * +Xedit_WrapMode(LispBuiltin *builtin) +/* + wrap-mode &optional value + */ +{ + int i; + Arg arg[1]; + XawTextWrapMode wrap; + + LispObj *value; + + value = ARGUMENT(0); + + if (value != UNSPEC) { + for (i = 0; i < 3; i++) + if (value == wrap_modes[i]) + break; + if (i >= 3) + LispDestroy("%s: argument must be " + ":NEVER, :LINE, or :WORD, not %s", + STRFUN(builtin), STROBJ(value)); + XtSetArg(arg[0], XtNwrap, (XawTextWrapMode)i); + XtSetValues(textwindow, arg, 1); + } + else { + XtSetArg(arg[0], XtNwrap, &wrap); + XtGetValues(textwindow, arg, 1); + i = (int)wrap; + if (i <= 0 || i >= 3) + i = 0; + value = wrap_modes[i]; + } + + return (value); +} + +LispObj * +Xedit_XrmStringToQuark(LispBuiltin *builtin) +/* + xrm-string-to-quark string + */ +{ + LispObj *string; + + string = ARGUMENT(0); + + CHECK_STRING(string); + + return (INTEGER(XrmStringToQuark(THESTR(string)))); +} diff --git a/lisp/xedit.h b/lisp/xedit.h new file mode 100644 index 0000000..0beff56 --- /dev/null +++ b/lisp/xedit.h @@ -0,0 +1,94 @@ +/* + * Copyright (c) 2002 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/xedit.h,v 1.5 2002/11/10 23:22:00 paulo Exp $ */ + +#ifndef Lisp_xedit_h +#define Lisp_xedit_h + +#ifdef XEDIT_LISP_PRIVATE +#include "private.h" +#include "io.h" +#include "read.h" +#include "write.h" + +LispObj *Xedit_AddEntity(LispBuiltin*); +LispObj *Xedit_AutoFill(LispBuiltin*); +LispObj *Xedit_Background(LispBuiltin*); +LispObj *Xedit_CharAfter(LispBuiltin*); +LispObj *Xedit_CharBefore(LispBuiltin*); +LispObj *Xedit_ClearEntities(LispBuiltin*); +LispObj *Xedit_ConvertPropertyList(LispBuiltin*); +LispObj *Xedit_Font(LispBuiltin*); +LispObj *Xedit_Foreground(LispBuiltin*); +LispObj *Xedit_GotoChar(LispBuiltin*); +LispObj *Xedit_HorizontalScrollbar(LispBuiltin*); +LispObj *Xedit_Insert(LispBuiltin*); +LispObj *Xedit_Justification(LispBuiltin*); +LispObj *Xedit_LeftColumn(LispBuiltin*); +LispObj *Xedit_Point(LispBuiltin*); +LispObj *Xedit_PointMax(LispBuiltin*); +LispObj *Xedit_PointMin(LispBuiltin*); +LispObj *Xedit_PropertyList(LispBuiltin*); +LispObj *Xedit_ReadText(LispBuiltin*); +LispObj *Xedit_ReplaceText(LispBuiltin*); +LispObj *Xedit_RightColumn(LispBuiltin*); +LispObj *Xedit_Scan(LispBuiltin*); +LispObj *Xedit_SearchBackward(LispBuiltin*); +LispObj *Xedit_SearchForward(LispBuiltin*); +LispObj *Xedit_VerticalScrollbar(LispBuiltin*); +LispObj *Xedit_WrapMode(LispBuiltin*); +LispObj *Xedit_XrmStringToQuark(LispBuiltin*); +#else +#define LispObj void +#endif /* XEDIT_LISP_PRIVATE */ + +typedef struct _EditModeInfo { + char *desc; /* Mode description */ + Widget sme; /* Menu entry */ + LispObj *symbol; /* Symbol holding syntax data */ + LispObj *syntax; /* The syntax definition */ +} EditModeInfo; + +/* Typedef'ed to XeditLispData in ../xedit.h */ +struct _XeditLispData { + LispObj *syntax; /* Syntax definition */ + LispObj *syntable; /* Syntax-table the cursor is located */ + int disable_highlight; /* Working in the buffer */ +}; + +void LispXeditInitialize(void); +void XeditLispExecute(Widget, XawTextPosition, XawTextPosition); +void XeditLispSetEditMode(xedit_flist_item*, LispObj*); +void XeditLispUnsetEditMode(xedit_flist_item*); + +extern EditModeInfo *mode_infos; +extern Cardinal num_mode_infos; + +#endif /* Lisp_xedit_h */ |