librep-0.90.2/0000755000175200017520000000000011245011204012053 5ustar chrischrislibrep-0.90.2/m4/0000755000175200017520000000000011245011162012376 5ustar chrischrislibrep-0.90.2/man/0000755000175200017520000000000011245011153012631 5ustar chrischrislibrep-0.90.2/src/0000755000175200017520000000000011245011153012645 5ustar chrischrislibrep-0.90.2/intl/0000755000175200017520000000000011245011152013023 5ustar chrischrislibrep-0.90.2/doc/0000755000175200017520000000000011245011152012622 5ustar chrischrislibrep-0.90.2/lisp/0000755000175200017520000000000011245011153013025 5ustar chrischrislibrep-0.90.2/lisp/rep/0000755000175200017520000000000011245011153013613 5ustar chrischrislibrep-0.90.2/lisp/rep/vm/0000755000175200017520000000000011245011153014235 5ustar chrischrislibrep-0.90.2/lisp/rep/xml/0000755000175200017520000000000011245011153014413 5ustar chrischrislibrep-0.90.2/lisp/rep/system/0000755000175200017520000000000011245011153015137 5ustar chrischrislibrep-0.90.2/lisp/rep/www/0000755000175200017520000000000011245011153014437 5ustar chrischrislibrep-0.90.2/lisp/rep/util/0000755000175200017520000000000011245011153014570 5ustar chrischrislibrep-0.90.2/lisp/rep/threads/0000755000175200017520000000000011245011153015245 5ustar chrischrislibrep-0.90.2/lisp/rep/test/0000755000175200017520000000000011245011153014572 5ustar chrischrislibrep-0.90.2/lisp/rep/net/0000755000175200017520000000000011245011153014401 5ustar chrischrislibrep-0.90.2/lisp/rep/mail/0000755000175200017520000000000011245011153014535 5ustar chrischrislibrep-0.90.2/lisp/rep/lang/0000755000175200017520000000000011245011153014534 5ustar chrischrislibrep-0.90.2/lisp/rep/io/0000755000175200017520000000000011245011153014222 5ustar chrischrislibrep-0.90.2/lisp/rep/i18n/0000755000175200017520000000000011245011153014372 5ustar chrischrislibrep-0.90.2/lisp/rep/data/0000755000175200017520000000000011245011153014524 5ustar chrischrislibrep-0.90.2/lisp/rep/vm/compiler/0000755000175200017520000000000011245011153016047 5ustar chrischrislibrep-0.90.2/lisp/rep/io/file-handlers/0000755000175200017520000000000011245011153016737 5ustar chrischrislibrep-0.90.2/lisp/rep/io/file-handlers/remote/0000755000175200017520000000000011245011153020232 5ustar chrischrislibrep-0.90.2/NEWS0000644000175200017520000011024711245011176012567 0ustar chrischrisAnhang A News ************* 0.90.2 ====== * Fixed a major defunct with prin1 + utf8 [Timo Korvola] * Fixed descriptions of formats %s and %S in streams.c 0.90.1 ====== * Properly terminate the rep interpreter [Jürgen Hötzel] * Use readline history in interactive mode [Jürgen Hötzel] * Tar file-handler does now support XZ compressed tarballs * Tar file-handler does now support LZMA compressed tarballs * Improved regex for parsing tar output in the file-handler [Alexey I. Froloff] * We do now correctly check for libffi * Improved libffi-binding [Alexey I. Froloff] * Updated librep.sym for missing entries [Alexey I. Froloff] * Fixed an incomplete definition * Added -L$prefix to libs section of the .pc file * No C++ style comments in C code 0.90.0 ====== * Added UTF-8 Support! [Wang Diancheng] * Remove scheme and unscheme modules * Going on with code-cleanup 0.17.4 ====== * Don't ignore datarootdir setting * Fixed an aclocal warning from configure.in * Improved configures ending message * Doc update in 'Numbers' section. Lacking description on machine dependence is added. [Teika] * Remove tar target from Makefile [Ritz] 0.17.3 ====== * Updated MAINTAINERS * Dropped rep.m4 - use librep.pc instead * Improved librep.pc * Updated librep.spec * Add -L/lib$libsuff to READLINE_LIBS [T2 Patch] * Fix compilation on PPC64 [Marcus Comstedt] * Small fixup in src/fake-libexec [SuSE] * No rpath in src/rep-config.sh [Fedora] * Added ebuild [Harald van Dijk] * Improved Makefile's distclean rule * Reworked autogen.sh * Reworked configure.in * Major rework of the spec-file * Improved configure's ending message * Fixed configure.in's templates for autoheader * BSD-Tar is not supported by librep, give users a usefull warning message [Mark Diekhans] 0.17.2 ====== * fixups for configure.in * updated BUGS, HACKING and README * define inline if undefined (fixes compiler warnings) * create the destination directory for the .pc file before installing it * fixed in issue with FreeBSD in numbers.c [FreeBSD patch] * improved a function of numbers.c [FreeBSD patch] * rep_file_fdopen has not been listed in librep.sym * added -tag=CC to libtool in several places * don't ignore $LDFLAGS upon build * dropped some useless code in sdbm.c * make sure inline is defined 0.17.1 ====== * started code-cleanup * added a .pc file * added -no-split to makeinfo [FreeBSD patch] * added -enable-paranoia to configure [compile with CFLAGS+="-Wall -ansi"] * updated the spec file * replaced a static void by a void in main.c [Debian patch] * use correct shebang in rep-xgettext.jl [ALT-Linux patch] * trim trailing / to mkdir(2) [NetBSD patch] 0.17 ==== * Added `rep.ffi' module (Foreign Function Interface). Uses gcc's libffi. Very untested. * Partial implementation of guile's `GH' interface. * Bug fixes: - Don't hang in select for a second when starting processes via the `system' function (race condition that only seems to show up on Linux 2.6 kernels) - Miscellaneous fixes for Mac OS X. - Don't return a reversed list of items from the XML parser. (Alexander V. Nikolaev) - Fixes to string capitalization functions. (Charles Stewart) 0.16 ==== * New modules `rep.data.trie', `rep.threads.proxy' * Also added `rep.xml.reader' and `rep.xml.printer', though these should probably be used with extreme caution * Appending to queues is now O(1) not O(n) * Many changes to `rep.net.rpc' module, protocol is incompatible with previous version. Should be more robust * `rep.i18n.gettext' module exports the `bindtextdomaincodeset' function (Christophe Fergeau) * Slightly more secure way of seeding the rng * `inexact->exact' can now convert floating point numbers to rationals (though not optimally). This means that `numerator' and `denominator' also work better with floats now * New function `file-ttyp' * Some random bug fixes 0.15 ==== * Parser can now associate lexical location (file name and line number) with parsed objects. Added `call-with-lexical-origins' and `lexical-origin' functions. This adds memory overhead but is only enabled in interpreted mode, or other times it could be useful (e.g. when compiling) * The compiler enables line-numbering, and uses the information when it prints errors. It also prints errors in a more standard format (intended to mimic GCC), and distinguishes warnings from errors * Debugger is much improved, and supports emacs-style emission of line number tokens. Use the included `rep-debugger.el' elisp code to source-debug rep programs in Emacs! * New command line option `--debug'. When given, rep starts up in the debugger * Reformatted backtrace output. Also backtraces only ever include evaluated argument lists now. They also include lexical information when possible * Syntax errors include error description and line number * Now supports weak reference objects. New functions `make-weak-ref', `weak-ref', `weak-ref-set'. A weak reference is a pointer to another object. When that object is garbage collected, the pointer in the weak reference is set to false. * New `error helper' module. When an error is handled, this module is called and tries to print a human-understandable message explaining why the error may have occurred * REPL commands may now be specified by their shortest unique set of leading characters, e.g. `,o' instead of `,open' * Added an `#undefined' value. Returned by `%define' and the macros using it (`defun', `defmacro', etc...) * New function `table-size' in module `rep.data.tables' * `thread-suspend' returns true iff the timeout was reached (i.e. return false if `thread-wake' was used to unsuspend the thread) * Objects defined using the `object' macro now have an implicit `self' binding - the object representing their self (or their most derived self) * Added TIMEOUT parameter to `condition-variable-wait' and `obtain-mutex' functions * New `rep.threads.message-port' module, implements a simple message queue for threads * `log' function now optionally accepts a second argument, the base of the logarithm * Use gmp to generate random numbers when possible (if at least version 3 of gmp is found) [disabled in librep 0.15.1 - gmp seems to be buggy?] * The `string-replace' function may now be given a function as its TEMPLATE parameter * Bug fixes: - Signal an error if writes don't write all characters they were asked to. Also, some functions could write fewer characters than they were supposed to even if no errors occurred - Remembered that file sizes may not fit in fixnums - Don't preserve trailing slashes in results of canonical-file-name (to make the path canonical) - Don't signal an error when end of file is encountered immediately after reading `#\X' syntax - `current-thread' and `all-threads' will create a thread object for the implicit thread if there isn't one already - In C subrs that take optional integer arguments, signal an error if the given value isn't an integer or undefined (false). Also, accept all types of numbers where it makes sense to do so - Signal an error if end of file is read while parsing a block comment - Don't ever return a null object from `current-time-string' - Catch errors signalled during command line option processing, and pass them to the standard error handler - Right hand side of `letrec' bindings may now have more than one form - The `object' macro now evaluates its BASE-OBJECT parameter exactly once - Finally removed `define-value' - Ignore null lines (or lines which only have comments) in the repl - In the compiler, don't expand macros which have have been shadowed by local bindings - Don't print some compiler errors/warnings twice - Fixes for `mips-compaq-nonstopux' architecture (Tom Bates) - Fixed `,reload' and `,unload' repl commands not to try to remove non-existent structures 0.14 ==== * New module `rep.util.md5', has two functions for generating MD5 message digests (of files or strings) * Changes to the `rep.io.sockets' function: In the `socket-server' function the HOST and/or PORT arguments may be false, meaning to listen on all addresses and to choose a random unused port. New functions `socket-peer-address' and `socket-peer-port', these always returns the details of the far end of the connetion. `socket-address' and `socket-port' have been changed to always return the details of the local connection point. * New function in `rep.system' module, `crypt'. A wrapper for the system's `crypt' function (if it has one) * New function in `rep.threads' mdoule, `make-suspended-thread' * New module `rep.net.rpc', provides a text-stream based RPC mechanism for Lisp programs. Similar in some ways to untyped CORBA. (This is still in the experimental stage - its interface may change in forthcoming releases) * New functions in `rep.data' module, `list->vector' and `vector->list' * New macro `define-special-variable'. A combination of `defvar' and `setq' - it always makes the variable special and it always sets it to the given value * New module `rep.test.framework' implementing `assert', `check' and `test' macros. This provides a framework for implementing unit tests in Lisp modules (such that running the interpreter with the `--check' option will run all tests that have been set up to be autoloaded * Bug fixes: - When reading from strings, don't choke on zero bytes - When writing into sockets, be aware that the socket is in non-blocking mode - SDBM and GDBM modules now close any open databases before the interpreter exits - Fixed the `rep_parse_number' function not to require a terminating null character in the string when parsing bignums - Only define `Qrep_lang_interpreter' once - Don't assign vm registers to physical registers on 68000 architectures - it's been reported to crash - When running asynchronous subprocesses, open and initialize the pty slave before forking to avoid a race condition with the child process - Flush symbols from the module cache at another point - Fixes for Unixware - When compiling non-top-level `defvar' forms, add any doc string they have to the database 0.13.5 ====== * Tar file handling no longer requires GNU tar * The `defvar' special form can now take only a single argument * The reader now treats `#\return' characters as white space * Other miscellaneous bug fixes... 0.13.4 ====== * Don't restrict symbols exported from plugin libraries, some need to export symbols to work properly (this bug only seemed to appear on Solaris systems) * Added `rep_file_type' and `rep_guardian_type' to the list of symbols exported from librep * Fixed the `install-aliases' script (Peter Teichman) * New module `rep.threads.condition-variable' * Added `string-split' and `string-replace' to the gaol 0.13.3 ====== * Try to only export public symbols from `librep.so' and modules * When expanding file names translate `/..' to `/' * Set an upper bound on the allowed recursion depth when regexp matching, prevents the stack from overflowing in pathological cases * Added optional second arg to `readline' function, a function to call to generate completions. The `rl-completion-generator' method of supplying this function is deprecated * Fixed bugs when handling character-case in regexp module (Andrew Rodionoff) * Added an `premature-end-of-stream' error. This is signalled instead of `end-of-stream' when reading characters in the middle of a syntax form. The `end-of-stream' error is only signalled when the end of the stream is reached before encountering anything other than whitespace characters * Fixed bug of expanding declarations in the `define' macro expansion 0.13.2 ====== * Fix `define' so that it tracks bound variables and ignores shadowed keywords when traversing code * Added checks to compilation process for the kind of missing shared-library problems that many people see * Fixed the `install-aliases' shell script * New configure option: `--enable-full-name-terminator' 0.13.1 ====== * Added functions `remove-if' and `remove-if-not' * Various bug-fixes for non-linux or solaris systems (John H. Palmieri, Philippe Defert) * `#f', `#t', `#!optional', `#!key' and `#!rest' are now uninterned symbols. Keywords are interned in a separate obarray * Fixed bug of caching regexps even when their string has been modified * Fixed some bugs in the ftp remote file handler and the `pwd-prompt' function * Fixed `define' to ignore `structure' and `define-structure' forms 0.13 ==== * The end-of-list / boolean-false object is no longer the symbol `nil'. Instead there is a special object `()' fulfulling these two roles. For modules importing the `rep' module, the symbol `nil' evaluates to `()'. This allows the `scheme' module to be more compliant with the Scheme standard * Parameter list changes: - Deprecated `&optional' and `&rest', in favour of `#!optional' and `#!rest'. - Added keyword parameters. Use `#!key' to declare them. Keyword syntax is `#:PARAM'. For example: ((lambda (#!key a b) (list a b)) #:b 2 #:a 1) => (1 2) - `#!optional' and `#!key' parameters may now have default values, syntax is `(VAR DEFAULT)'. For example: ((lambda (#!optional (a 1)) a)) => 1 * The module namespace is now hierarchical. `.' characters in module names denote directory separators, e.g. `foo.bar' translates to the file `foo/bar' All module names prefixed with `rep.' are reserved for librep, other top-level names should be picked to be as unique as possible The existing modules have been renamed to fit this scheme (see the file `TREE' in the distribution for the hierarchy details). However, old module names will still work for the time being * The `rep' module no longer includes the `rep.regexp', `rep.system', `rep.io.files', `rep.io.processes' or `rep.io.file-handlers' modules. These need to be imported explicitly * Doc strings are now indexed by module name as well as symbol name. The `define' macro now takes a doc string as its optional third parameter * Record constructors may include all lambda-list keywords (e.g. keywords and/or default values) * Incompatible virtual machine changes, hence bytecode files will need to be recompiled. Improvements include: - Only heap-allocate variables when absolutely necessary - Closure analysis to allow inlining of some types of `letrec' expressions - Added a `safe' virtual machine, which makes no assumptions regarding validity of bytecode, so is safe for untrusted code * Added an `unscheme' module. Another Scheme implementation, but the goal of this one is to integrate cleanly with the librep runtime environment, even if this is at the expense of R4RS compliance For example, in `unscheme' code, `#f => ()' and `#t => t'. This allows rep and unscheme functions to call each other without needing to convert any data * By default, it is now illegal to modify top-level variables that have not previously been defined * New macro `define-structures' to export multiple views of a single underlying environment * The librep runtime no longer handles the `--help' option itself, this should be done by scripts * Don't search `$LD_LIBRARY_PATH' for plugins, but prepend all directories in colon-separated `$REP_DL_LOAD_PATH' to `dl-load-path'. Similarly, the contents of `$REP_LOAD_PATH' is prepended to `rep-load-path' * `(/ X) => (/ 1 X)' * Extra string-manipulation functions: `string-replace', `string-split' (in the `rep.regexp' module) * `#f' and `#t' are now primitive symbols, not special objects * Special case tail-recursive calls to `apply', to ensure they get eliminated * The `0x123' and `0123' read syntaxes have been deprecated, use `#x123' and `#o123' instead * `#| ... |#' comments now nest correctly * New modules: `rep.i18n.gettext', `rep.vm.safe-interpreter', `rep.vm.assembler', `unscheme', `rep.data.objects', `rep.www.quote-url', `rep.www.fetch-url', `rep.util.ispell', `rep.util.base64', `rep.util.autoloader', `rep.io.sockets', `rep.util.time', `rep.net.domain-name' * Bug fixes, including: - Find size of `long long' type on AIX, IRIX and Solaris (Dan McNichol, Albert Chin-A-Young) - Never allow macros to be called as functions - Make bitfields unsigned (Albert Chin-A-Young) - Fixed bounds-checking when parsing non-base-10 fixnums - Thread fixes (and much lower thread-switch latency in many cases) - Fixed `DEFUN' macro for C++ (Matt Tucker); also fixed header files to avoid C++ keywords - Make error message for bytecode version mismatches more meaningful - Fixed: `default-boundp', `continuation-callable-p' - Only the evaluate the value of `defvar' forms if the symbol isn't already bound - Compile else-less `case' expressions correctly; eliminate tail-recursion in `cond' forms when possible - Various fixes in `scheme' module 0.12.4 ====== * Support building without GNU MP, `--without-gmp' option to configure. Use `long long' for non-fixnum integers (promote to floats when out of range); no exact rationals. There's also an option to disable continuations/threading (`--disable-continuations') * Sanitized function inlining: - Use `(declare (inline NAMES...))' to tell the compiler that it might be useful to inline the named functions - Don't even think about inlining across module/file boundaries (for now anyway) * Cleaned up the `gaol' module. Interface is essentially: `gaol-define', `gaol-define-special', `gaol-define-file-handler'. Added `gaol-open' to import complete modules. Still supports old interface * Be a lot more efficient when printing quoted strings and symbol names (for some streams there used to be a system-call per character!) Also, when quoting weird symbol names, be more intelligent * Removed code to autoload from modules (which didn't really work anyway) * Be more intelligent about deciding when to flush the module cache * Build fixes for IRIX (David Kaelbling) * Other miscellaneous bug-fixes and performance tweaks 0.12.3 ====== * New function `thread-join', waits for a specified thread to exit, then returns the value of the last form it evaluated * Added a rudimentary profiler (`,profile FORM' command in repl) * Reorganized `ring' module, sanitized the interface (preserving compatibility with old functions), also added a `ring->list' function * `rplaca' and `rplacd' (but not `setcar' and `setcdr') functions now return the cell being modified, not the value being stored into it, for compatibility with CL (Karl Hegbloom) * `unwind-protect', `catch', `condition-case': these special forms are now macros * When signalling `bad-arg' or `missing-arg' errors, try to include the function as the first element of the error data * `load' function now _only_ loads files without suffixes if NO-SUFFIX arg is non-`nil' (prevents picking up un-suffixed files by mistake, e.g. from the current directory) * Fixed some bugs when reading rationals * Fixed bug of `gettext' module not redefining `_' binding in `rep' module * Fixed bug when building `rep-config' script (Mark Hewitt, Dan Winship) * Fixed bug of `rep_INTERN_SPECIAL' macro not looking for default values of special variables * Fixed interpreted versions of `min' and `max' when operating on non-numeric values * If unable to allocate heap space, just print an error and terminate the program (the low-memory handling doesn't currently work properly) * Fixed bug when extracting doc strings from `define' forms * Fixed bug when compiling structure definitions in non-top-level environments * Fixed bug of being unable to `load' empty files * When recursively macro-expanding, dereference identifiers in the correct module 0.12.2 ====== * The tar file-handler now caches the unpacked archive (wins big when loading sawfish themes) * The `gaol' module can now create multiple gaols, each with it's own namespace * More performance tweaks * Miscellaneous bug-fixes (more vm stack smashing, `defconst' never evaluates its constant) 0.12.1 ====== * Some virtual machine performance tweaks * Fixed nasty stack smashing bug (when using compiler declarations) * Some 64-bit cleanups (George Lebl) * Fixed non-ANSI C syntax (Sam Falkner) 0.12 ==== * Added a basic module system. Modelled after the Scheme48 system, but simpler. At its simplest, include a `define-structure' form in each file representing a module: (define-structure NAME INTERFACE CONFIG BODY...) The external definitions of this module can then be imported by other modules through their CONFIG statements, e.g. `(open NAMES...)'. Most modules will open `rep' to get the standard language definitions. `foo#bar' reads as `(structure-ref foo bar)' The `timers', `tables', `sdbm', `gdbm', `readline', `gettext', `ring', `mutex', `memoize', `lisp-doc', `disassembler', `compiler', `date', `cgi-get', `gaol' features are all now modules (this is backwards compatible, since modules may be imported using `require') See the "Modules" section of the manual for more details. * The repl now contains meta-commands for inspecting and configuring the module system (amongst other things) * Added a facility for creating new primitive types: `make-datum', `datum-ref', `datum-set', `has-type-p', `define-datum-printer' * Added an SRFI 9 compatible `define-record-type' macro for defining data structures (the `records' module) * Added fluid variables--a method of creating dynamically scoped bindings that fit well with lexically scoped definitions (`make-fluid', `fluid', `fluid-set', `with-fluids', `let-fluids') * Added a `queues' module providing a basic queue type * Added stream functions: `peek-char', `input-stream-p', `output-stream-p' * Interpreter now also eliminates tail-calls * Changed handling of inexact numbers to be compatible with the Scheme standard: - Many operations now produce inexact outputs if any of their inputs are inexact (e.g. `min', `max', `floor', `ceiling', `round', `truncate') - `eql' and `equal' no longer ignore exactness when comparing numbers. `=', `/=', `<', `>', `<=' and `>=' _do_ ignore inexactness. E.g. (eql 2 2.) => nil (= 2 2.) => t * Support most of Scheme's read-syntax for numbers (i.e. `#b', `#o', `#d', `#x' radix prefixes, and `#e', `#i' exactness prefixes). * Implemented Scheme's `string->number' and `number->string' functions * Included a basic R4RS Scheme implementation (module: `scheme'). Do `,new foo ,open scheme' to test it in the repl, use `(open scheme)' instead of `(open rep)' to use it within modules. The compiler also knows enough about Scheme to be able to compile it. Also, use the `-s' or `--scheme' options to load a file of Scheme code. * The debugger works better (and can be used to walk the stack history somewhat) * Last arg of `append' and `nconc' may be a non-proper-list now * Implemented the Scheme `do' macro for iteration * `define' supports curried functions. E.g. `(define ((plus a) b) (+ a b))', then `(plus 1)' evaluates to the function that adds one to its argument. * Many performance improvements: - Allocates less memory (so garbage collects less often) - Much faster at bytecode-to-bytecode function calling - Much reduced VM overhead (when compiled with GCC) * Compiler improvements: - Supports the `(declare CLAUSES...)' form. See the "Compiler Declarations" section of the manual for details on the actual declarations supported. - Is cleverer about detecting when to create new bindings when tail recursing, and when the old bindings can just be overwritten - Groks the module system, and the language of the module being compiled (so that it can compile both rep and Scheme code) - Splices bodies of top-level `progn' and `begin' forms themselves into the top-level (for when macros expand into multiple definitions) - Compiling already defined functions (or whole modules of functions) now (mostly) works - Coalesce and compile non-defining top-level forms * Many bug fixes (see ChangeLog files for details) 0.11.3 ====== * Fixed bug of throwing uninitialized errors when autoloading * Fixed bug of interpreting `(let () ...)' as a named let 0.11.2 ====== * Replaced many special forms by macros--`let', `let*', `function', `if', `and', `or', `prog2', `defmacro', `defun', `defconst', `define-value', `setq-default' * `let' now supports Scheme's named-let construct for iteration via tail recursion * Parse some standard Common Lisp and Scheme syntax: `#| ... |#' block comments, `#\C' or `#\NAME' characters (where NAME may be one of: `space', `newline', `backspace', `tab', `linefeed', `return', `page', `rubout'), and `#(...)' vectors * When comparing symbols, compare their names as strings * Implemented Scheme's `dynamic-wind' function * Fixed bug of sometimes evaluating function arguments in the environment of the callee not the caller * Fixed bug when calculating how long to sleep for when no threads are available * Fixed bugs in mutex implementation (Damon Anderson) * Work around bugs in Tru64 `RTLD_GLOBAL'; everything should work on Tru64 now (Aron Griffis) * Fixed bug of not saving current regexp state across continuations 0.11.1 ====== * The compiler now eliminates single-function tail calls (instead of leaving it to the virtual machine) * Updated to use libtool-1.3.4 * Miscellaneous bug fixes and minor changes 0.11 ==== * Better support for numerical computing. Now supports bignums, rational numbers (numerator and denominator are bignums), and floating point values as well as the original fixnums. Many new numerical functions supporting these types. Promotes and demotes hopefully as you'd expect (never demotes an inexact number to an exact number). Tries to follow the Scheme numeric system as much as possible * Supports "guardian" objects through the `make-guardian' function (as described in Dybvig's paper). These are a clean mechanism for allowing the programmer to control when arbitrary lisp objects are finally deallocated. Also added a new hook: `after-gc-hook' * The default error handler can now be redefined. If the variable `error-handler-function' contains a function then it will be called to handle the error, with arguments `(ERROR DATA)'. * New special form `case', switches on a key value and sets of constants * New function `call/cc' (also available through the alias `call-with-current-continuation'). Provides scheme-like continuation functions. Special variables are now deep-bound to support this correctly * Supports "soft" preemptive threads using continuations and a general "barrier" mechanism (used either for restricting control flow, or for receiving notification when control passes across a barrier) * Parameter lists in lambda expressions now support improper lists, as in scheme. E.g. `(lambda (x . y) ...)' * Implements the scheme `define' syntax, with support for inner definitions * The `tables' plugin implements hash tables, with extensible hashing and comparison methods; supports both strongly and weakly keyed tables * Included a GDBM binding; DOC files are now stored in GDBM files (SDBM has limits on datum sizes) * `put' and `get' functions now use `equal' to compare property names * Virtual machine / compiler improvements: - Variable references and mutations are classified by type: lexical bindings use (one-dimensional) lexically addressed instructions, global non-special bindings have their own instructions, everything else uses the original instructions. Similar classification when creating new bindings - Eliminate tail-recursive function calls wherever possible in compiled code (when the calling function has no dynamic state) Compiled lisp code will need to be rebuilt to run on the modified virtual machine. * When expanding macros, bind `macro-environment' to the macro environment it was called with. This allows macros to reliably expand inner macro uses * New hook `before-exit-hook'. Called immediately before exiting * `rep-xgettext' now has an option `--c'. This makes it output pseudo C code containing the string constants found * Fixed misfeature of interpreting filenames `FOO//BAR' as `/BAR'. Contiguous path separators are now merged (i.e. `FOO/BAR') 0.10 ==== * Updated support for dumping (freezing) lisp definitions to handle lisp-1 nature with closures. Also now generates C code instead of assembler for portability; creates a plugin that may be loaded through the REP_DUMP_FILE environment variable * Plugin `.la' files may now contain rep-specific settings: `rep_open_globally=yes' and `rep_requires='FEATURES...'' * New function `define-value'. A combination of `set' and `defvar', but without implying dynamic scope * `load' scans AFTER-LOAD-ALIST for plugins as well as lisp libraries * `(if t)' now evaluates to `nil' not `t' * Fix regexp bug in matching simple non-greedy operators (Matt Krai) * Borrowed guile's bouncing parentheses for readline (Ceri Storey) * New C functions `rep_load_environment' and `rep_top_level_exit' * `defvar' allows symbols to be redefined in protected environments if they haven't also been defined by unprotected environments * Detect GCC's with broken `__builtin_return_address' functions (George Lebl) * Try to use libc `gettext' implementation, but only if it looks like it's the GNU implementation 0.9 === * Support for using GNU readline (give configure the `--with-readline' option) * New functions: `letrec', `caar', ..., `cddr', `caaar', ..., `cdddr', `in-hook-p', `make-variable-special' * Changed `unless' to have the Common Lisp semantics--return `nil' when the condition evaluates true, not the value of the condition * Fixed/added some compiler optimisations * Fixed `rep-xgettext' script to remove duplicated strings and to search exhaustively * `add-hook' forces the hook variable to be special (in case it wasn't declared using `defvar') 0.8.1 ===== Fixed some documentation bugs; fixed some build problems 0.8 === * Default scoping is now lexical, only variables declared using `defvar' are dynamically scoped. * There is now only a single namespace for symbols (excepting property lists), this means that the `fset', `symbol-function' and `fboundp' functions have been removed This allows all elements in procedure-call forms to be evaluated equally (as in scheme), so things like: ((if t + -) 1 2) now work. Related to this, function names (i.e. symbols and lambda expressions) are no longer dereferenced by any operations taking functions as arguments. Only built-in subroutines and closures are considered functions. This means that where before you'd write something like: (mapcar '+ '(1 2 3)) this is now illegal; the `+' function must be evaluated: (mapcar + '(1 2 3)) * `lambda' is now a special form evaluating to a closure (as in scheme); this means that the following are exactly equivalent: (lambda (x) x) == (function (lambda (x) x)) == #'(lambda (x) x) An alternative method of enclosing a lambda expression is to use the `make-closure' function. * `gaol' module providing semi-safe environment for untrusted code to evaluate in * Support for i18n through `gettext' module; also support for `%1$s' type format specifiers * New functions `string-equal' and `string-lessp' 0.7.1 ===== * Added `--with-rep-prefix' option to autoconf AM_PATH_REP macro * Fixed bug when inserting a new timer before an existing timer * Fix the malloc tracking code * Fix dlmalloc for FreeBSD * Use install when installing, not cp * Some fixes for compiling with SUN's C compiler on Solaris 0.7 === * Added file handler for read-only access to the contents of tar archives, access files like `foo.tar.gz#tar/bar' * `process-id' function now returns pid of lisp interpreter when called with zero arguments * Added (untested) support for loading dynamic objects via `shl_load' (HP-UX) * Added (untested) support for systems that prefix symbol names in dynamic objects with underscores * Fix bug when compiling `last' function * Fix bug of not closing files in the `load' function 0.6.2 ===== * Added `autoload-verbose' variable; set it to `nil' to turn off the messages when autoloading * Fix problems when `--prefix' option has a trailing slash * Updated libtool files to version 1.3.3 * Initial (incomplete) support for building under Tru64, from Aron Griffis 0.6.1 ===== No new features; minor portability tweaks and build changes. Fix bug of trying to load directories as Lisp scripts 0.6 === * Add `unsetenv' function * `system' now uses `process-environment' * Workaround compiler bug with GCC 2.95 on sparc * Fix build problem where libsdbm.la can't be located 0.5 === * New function `set-input-handler', registers an asynchronous input handler for a local file * Don't abort on receipt of unexpected `SIGCHLD' signals * Upgrade libtool to version 1.2f * The `rep' binary by default always loads a script named `rep', not named by it's `argv[0]' (this breaks under the newer libtool) 0.4 === * Sending a rep process a `SIGUSR2' prints all debug buffers * Added `--with-value-type', and `--with-malloc-alignment' configure options. Also added code to automatically detect the first of these options. * Fixed some 64-bit problems * Removed the difference between static and dynamic strings 0.3 === * New compiler command line option `--write-docs' 0.2 === * The variables `error-mode' and `interrupt-mode' control where errors and user-interrupts (i.e. `SIGINT' signals) are handled. The three possible values are: `top-level', `exit' and `nil' (denotes the current event loop). * Fixed bug where all dynamic types were erroneously `symbolp'. * `SIGINT', `SIGHUP' and `SIGTERM' signals should now be caught more successfully. * Added a new directory to `dl-load-path': `LIBEXECDIR/rep/ARCH' to contain third-party shared libraries. 0.1 === First public release. librep-0.90.2/configure0000755000175200017520000157225711245011167014015 0ustar chrischris#! /bin/sh # From configure.in Revision: 1.146 . # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.64. # # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, # 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software # Foundation, Inc. # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV export CONFIG_SHELL exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error ERROR [LINENO LOG_FD] # --------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with status $?, using 1 if that was 0. as_fn_error () { as_status=$?; test $as_status -eq 0 && as_status=1 if test "$3"; then as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 fi $as_echo "$as_me: error: $1" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in #( -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # Check that we are running under the correct shell. SHELL=${CONFIG_SHELL-/bin/sh} case X$lt_ECHO in X*--fallback-echo) # Remove one level of quotation (which was required for Make). ECHO=`echo "$lt_ECHO" | sed 's,\\\\\$\\$0,'$0','` ;; esac ECHO=${lt_ECHO-echo} if test "X$1" = X--no-reexec; then # Discard the --no-reexec flag, and continue. shift elif test "X$1" = X--fallback-echo; then # Avoid inline document here, it may be left over : elif test "X`{ $ECHO '\t'; } 2>/dev/null`" = 'X\t' ; then # Yippee, $ECHO works! : else # Restart under the correct shell. exec $SHELL "$0" --no-reexec ${1+"$@"} fi if test "X$1" = X--fallback-echo; then # used as fallback echo shift cat <<_LT_EOF $* _LT_EOF exit 0 fi # The HP-UX ksh and POSIX shell print the target directory to stdout # if CDPATH is set. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH if test -z "$lt_ECHO"; then if test "X${echo_test_string+set}" != Xset; then # find a string as large as possible, as long as the shell can cope with it for cmd in 'sed 50q "$0"' 'sed 20q "$0"' 'sed 10q "$0"' 'sed 2q "$0"' 'echo test'; do # expected sizes: less than 2Kb, 1Kb, 512 bytes, 16 bytes, ... if { echo_test_string=`eval $cmd`; } 2>/dev/null && { test "X$echo_test_string" = "X$echo_test_string"; } 2>/dev/null then break fi done fi if test "X`{ $ECHO '\t'; } 2>/dev/null`" = 'X\t' && echo_testing_string=`{ $ECHO "$echo_test_string"; } 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then : else # The Solaris, AIX, and Digital Unix default echo programs unquote # backslashes. This makes it impossible to quote backslashes using # echo "$something" | sed 's/\\/\\\\/g' # # So, first we look for a working echo in the user's PATH. lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR for dir in $PATH /usr/ucb; do IFS="$lt_save_ifs" if (test -f $dir/echo || test -f $dir/echo$ac_exeext) && test "X`($dir/echo '\t') 2>/dev/null`" = 'X\t' && echo_testing_string=`($dir/echo "$echo_test_string") 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then ECHO="$dir/echo" break fi done IFS="$lt_save_ifs" if test "X$ECHO" = Xecho; then # We didn't find a better echo, so look for alternatives. if test "X`{ print -r '\t'; } 2>/dev/null`" = 'X\t' && echo_testing_string=`{ print -r "$echo_test_string"; } 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then # This shell has a builtin print -r that does the trick. ECHO='print -r' elif { test -f /bin/ksh || test -f /bin/ksh$ac_exeext; } && test "X$CONFIG_SHELL" != X/bin/ksh; then # If we have ksh, try running configure again with it. ORIGINAL_CONFIG_SHELL=${CONFIG_SHELL-/bin/sh} export ORIGINAL_CONFIG_SHELL CONFIG_SHELL=/bin/ksh export CONFIG_SHELL exec $CONFIG_SHELL "$0" --no-reexec ${1+"$@"} else # Try using printf. ECHO='printf %s\n' if test "X`{ $ECHO '\t'; } 2>/dev/null`" = 'X\t' && echo_testing_string=`{ $ECHO "$echo_test_string"; } 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then # Cool, printf works : elif echo_testing_string=`($ORIGINAL_CONFIG_SHELL "$0" --fallback-echo '\t') 2>/dev/null` && test "X$echo_testing_string" = 'X\t' && echo_testing_string=`($ORIGINAL_CONFIG_SHELL "$0" --fallback-echo "$echo_test_string") 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then CONFIG_SHELL=$ORIGINAL_CONFIG_SHELL export CONFIG_SHELL SHELL="$CONFIG_SHELL" export SHELL ECHO="$CONFIG_SHELL $0 --fallback-echo" elif echo_testing_string=`($CONFIG_SHELL "$0" --fallback-echo '\t') 2>/dev/null` && test "X$echo_testing_string" = 'X\t' && echo_testing_string=`($CONFIG_SHELL "$0" --fallback-echo "$echo_test_string") 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then ECHO="$CONFIG_SHELL $0 --fallback-echo" else # maybe with a smaller string... prev=: for cmd in 'echo test' 'sed 2q "$0"' 'sed 10q "$0"' 'sed 20q "$0"' 'sed 50q "$0"'; do if { test "X$echo_test_string" = "X`eval $cmd`"; } 2>/dev/null then break fi prev="$cmd" done if test "$prev" != 'sed 50q "$0"'; then echo_test_string=`eval $prev` export echo_test_string exec ${ORIGINAL_CONFIG_SHELL-${CONFIG_SHELL-/bin/sh}} "$0" ${1+"$@"} else # Oops. We lost completely, so just stick with echo. ECHO=echo fi fi fi fi fi fi # Copy echo and quote the copy suitably for passing to libtool from # the Makefile, instead of quoting the original, which is used later. lt_ECHO=$ECHO if test "X$lt_ECHO" = "X$CONFIG_SHELL $0 --fallback-echo"; then lt_ECHO="$CONFIG_SHELL \\\$\$0 --fallback-echo" fi exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="src/rep_subrs.h" # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_subst_vars='LTLIBOBJS USE_INCLUDED_LIBINTL l GT_NO GT_YES INTLOBJS MKINSTALLDIRS DATADIRNAME PACKAGE VERSION HAVE_X11 HAVE_UNIX emacssitelispdir repdocfile replispdir repcommonexecdir repexecdir repdir libversion version aclocaldir MAKEDEP LIBOBJS ALLOCA LIBFFI_LIBS LIBFFI_CFLAGS PKG_CONFIG READLINE_LIBS GDBM_LIBS GMP_LIBS SET_MAKE INSTALL_DATA INSTALL_SCRIPT INSTALL_PROGRAM EXTRA_LIBOBJS CPP OTOOL64 OTOOL LIPO NMEDIT DSYMUTIL lt_ECHO RANLIB STRIP AR OBJDUMP LN_S NM ac_ct_DUMPBIN DUMPBIN LD FGREP EGREP GREP SED OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC host_os host_vendor host_cpu host build_os build_vendor build_cpu build LIBTOOL target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking enable_shared enable_static with_pic enable_fast_install with_gnu_ld enable_libtool_lock with_gmp with_gmp_prefix with_gdbm_prefix with_readline with_readline_prefix with_ffi with_extra_cflags with_aclocaldir enable_continuations enable_dballoc enable_dbsyms enable_gprof enable_full_name_terminator with_value_type with_value_sizeof with_malloc_alignment with_stack_direction enable_paranoia ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP PKG_CONFIG LIBFFI_CFLAGS LIBFFI_LIBS' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error "unrecognized option: \`$ac_option' Try \`$0 --help' for more information." ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF System types: --build=BUILD configure for building on BUILD [guessed] --host=HOST cross-compile to build programs to run on HOST [BUILD] _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-shared[=PKGS] build shared libraries [default=yes] --enable-static[=PKGS] build static libraries [default=yes] --enable-fast-install[=PKGS] optimize for fast installation [default=yes] --disable-libtool-lock avoid locking (might break parallel builds) --disable-continuations Don't include support for continuations or multi-threading --enable-dballoc Trace all memory allocations --disable-dbsyms When writing debug output, don't translate addresses to symbol names --enable-gprof Build for gprof (needs --enable-static) --enable-full-name-terminator=C Full name in gecos field of passwd file is terminated by first C character --enable-paranoia use wall, wno-error, ansi, pedantic compiler flags Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-pic try to use only PIC/non-PIC objects [default=use both] --with-gnu-ld assume the C compiler uses GNU ld [default=no] --without-gmp Don't use GMP for bignum/rational numbers --with-gmp-prefix=DIR path to GMP --with-gdbm-prefix=DIR path to GDBM --with-readline support fancy command input editing --without-readline Don't use readline --with-readline-prefix=DIR path to readline --with-ffi Support for ffi --without-ffi Don't use ffi --with-extra-cflags=FLAGS Extra flags to pass to C compiler --with-aclocaldir=DIR Directory in which to install autoconf macros --with-value-type=TYPE Implicitly signed integer type, at least as wide as a pointer. TYPE= (see README) --with-value-sizeof=N Size (in bytes) of value type. N= --with-malloc-alignment=BYTES Must be less than or equal to the alignment returned by the malloc function. BYTES=N --with-stack-direction=DIR Stack growth direction. -1 for downwards, +1 for upwards. Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS C/C++/Objective C preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor PKG_CONFIG path to pkg-config utility LIBFFI_CFLAGS C compiler flags for LIBFFI, overriding pkg-config LIBFFI_LIBS linker flags for LIBFFI, overriding pkg-config Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF configure generated by GNU Autoconf 2.64 Copyright (C) 2009 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} return $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} return $ac_retval } # ac_fn_c_try_link # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} } # ac_fn_c_check_header_compile # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} return $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_try_run LINENO # ---------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. Assumes # that executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then : ac_retval=0 else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} return $ac_retval } # ac_fn_c_try_run # ac_fn_c_check_func LINENO FUNC VAR # ---------------------------------- # Tests whether FUNC exists, setting the cache variable VAR accordingly ac_fn_c_check_func () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Define $2 to an innocuous variant, in case declares $2. For example, HP-UX 11i declares gettimeofday. */ #define $2 innocuous_$2 /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $2 (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $2 /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $2 (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$2 || defined __stub___$2 choke me #endif int main () { return $2 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} } # ac_fn_c_check_func # ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists, giving a warning if it cannot be compiled using # the include files in INCLUDES and setting the cache variable VAR # accordingly. ac_fn_c_check_header_mongrel () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 $as_echo_n "checking $2 usability... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_header_compiler=yes else ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 $as_echo_n "checking $2 presence... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include <$2> _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : ac_header_preproc=yes else ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( yes:no: ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; no:yes:* ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else eval "$3=\$ac_header_compiler" fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} } # ac_fn_c_check_header_mongrel # ac_fn_c_check_type LINENO TYPE VAR INCLUDES # ------------------------------------------- # Tests whether TYPE exists after having included INCLUDES, setting cache # variable VAR accordingly. ac_fn_c_check_type () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else eval "$3=no" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof ($2)) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof (($2))) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else eval "$3=yes" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} } # ac_fn_c_check_type # ac_fn_c_compute_int LINENO EXPR VAR INCLUDES # -------------------------------------------- # Tries to find the compile-time value of EXPR in a program that includes # INCLUDES, setting VAR accordingly. Returns whether the value could be # computed ac_fn_c_compute_int () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if test "$cross_compiling" = yes; then # Depending upon the size, compute the lo and hi bounds. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) >= 0)]; test_array [0] = 0 ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_lo=0 ac_mid=0 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0 ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=$ac_mid; break else as_fn_arith $ac_mid + 1 && ac_lo=$as_val if test $ac_lo -le $ac_mid; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) < 0)]; test_array [0] = 0 ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=-1 ac_mid=-1 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) >= $ac_mid)]; test_array [0] = 0 ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_lo=$ac_mid; break else as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val if test $ac_mid -le $ac_hi; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done else ac_lo= ac_hi= fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # Binary search between lo and hi bounds. while test "x$ac_lo" != "x$ac_hi"; do as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0 ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=$ac_mid else as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done case $ac_lo in #(( ?*) eval "$3=\$ac_lo"; ac_retval=0 ;; '') ac_retval=1 ;; esac else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 static long int longval () { return $2; } static unsigned long int ulongval () { return $2; } #include #include int main () { FILE *f = fopen ("conftest.val", "w"); if (! f) return 1; if (($2) < 0) { long int i = longval (); if (i != ($2)) return 1; fprintf (f, "%ld", i); } else { unsigned long int i = ulongval (); if (i != ($2)) return 1; fprintf (f, "%lu", i); } /* Do not output a trailing newline, as this causes \r\n confusion on some platforms. */ return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : echo >>conftest.val; read $3 config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.64. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo cat <<\_ASBOX ## ---------------- ## ## Cache variables. ## ## ---------------- ## _ASBOX echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo cat <<\_ASBOX ## ----------------- ## ## Output variables. ## ## ----------------- ## _ASBOX echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then cat <<\_ASBOX ## ------------------- ## ## File substitutions. ## ## ------------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then cat <<\_ASBOX ## ----------- ## ## confdefs.h. ## ## ----------- ## _ASBOX echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then ac_site_file1=$CONFIG_SITE elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special # files actually), so we avoid doing that. if test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_config_headers="$ac_config_headers config.h src/rep_config.h" case `pwd` in *\ * | *\ *) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Libtool does not cope well with whitespace in \`pwd\`" >&5 $as_echo "$as_me: WARNING: Libtool does not cope well with whitespace in \`pwd\`" >&2;} ;; esac macro_version='2.2.6' macro_revision='1.3012' ltmain="$ac_aux_dir/ltmain.sh" ac_aux_dir= for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do for ac_t in install-sh install.sh shtool; do if test -f "$ac_dir/$ac_t"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/$ac_t -c" break 2 fi done done if test -z "$ac_aux_dir"; then as_fn_error "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. # Make sure we can run config.sub. $SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || as_fn_error "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 { $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 $as_echo_n "checking build system type... " >&6; } if test "${ac_cv_build+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_build_alias=$build_alias test "x$ac_build_alias" = x && ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` test "x$ac_build_alias" = x && as_fn_error "cannot guess build type; you must specify one" "$LINENO" 5 ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || as_fn_error "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 $as_echo "$ac_cv_build" >&6; } case $ac_cv_build in *-*-*) ;; *) as_fn_error "invalid value of canonical build" "$LINENO" 5;; esac build=$ac_cv_build ac_save_IFS=$IFS; IFS='-' set x $ac_cv_build shift build_cpu=$1 build_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: build_os=$* IFS=$ac_save_IFS case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 $as_echo_n "checking host system type... " >&6; } if test "${ac_cv_host+set}" = set; then : $as_echo_n "(cached) " >&6 else if test "x$host_alias" = x; then ac_cv_host=$ac_cv_build else ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || as_fn_error "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 $as_echo "$ac_cv_host" >&6; } case $ac_cv_host in *-*-*) ;; *) as_fn_error "invalid value of canonical host" "$LINENO" 5;; esac host=$ac_cv_host ac_save_IFS=$IFS; IFS='-' set x $ac_cv_host shift host_cpu=$1 host_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: host_os=$* IFS=$ac_save_IFS case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "no acceptable C compiler found in \$PATH See \`config.log' for more details." "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 rm -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { FILE *f = fopen ("conftest.out", "w"); return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out conftest.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 $as_echo_n "checking for C compiler default output file name... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } if test -z "$ac_file"; then : $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { as_fn_set_status 77 as_fn_error "C compiler cannot create executables See \`config.log' for more details." "$LINENO" 5; }; } fi ac_exeext=$ac_cv_exeext # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 $as_echo_n "checking whether the C compiler works... " >&6; } # If not cross compiling, check that we can run a simple program. if test "$cross_compiling" != yes; then if { ac_try='./$ac_file' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details." "$LINENO" 5; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out conftest.out ac_clean_files=$ac_clean_files_save # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." "$LINENO" 5; } fi rm -f conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if test "${ac_cv_objext+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "cannot compute suffix of object files: cannot compile See \`config.log' for more details." "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if test "${ac_cv_c_compiler_gnu+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if test "${ac_cv_prog_cc_g+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if test "${ac_cv_prog_cc_c89+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a sed that does not truncate output" >&5 $as_echo_n "checking for a sed that does not truncate output... " >&6; } if test "${ac_cv_path_SED+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ for ac_i in 1 2 3 4 5 6 7; do ac_script="$ac_script$as_nl$ac_script" done echo "$ac_script" 2>/dev/null | sed 99q >conftest.sed { ac_script=; unset ac_script;} if test -z "$SED"; then ac_path_SED_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in sed gsed; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_SED="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_SED" && $as_test_x "$ac_path_SED"; } || continue # Check for GNU ac_path_SED and select it if it is found. # Check for GNU $ac_path_SED case `"$ac_path_SED" --version 2>&1` in *GNU*) ac_cv_path_SED="$ac_path_SED" ac_path_SED_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo '' >> "conftest.nl" "$ac_path_SED" -f conftest.sed < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_SED_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_SED="$ac_path_SED" ac_path_SED_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_SED_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_SED"; then as_fn_error "no acceptable sed could be found in \$PATH" "$LINENO" 5 fi else ac_cv_path_SED=$SED fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_SED" >&5 $as_echo "$ac_cv_path_SED" >&6; } SED="$ac_cv_path_SED" rm -f conftest.sed test -z "$SED" && SED=sed Xsed="$SED -e 1s/^X//" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if test "${ac_cv_path_GREP+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then as_fn_error "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if test "${ac_cv_path_EGREP+set}" = set; then : $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then as_fn_error "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for fgrep" >&5 $as_echo_n "checking for fgrep... " >&6; } if test "${ac_cv_path_FGREP+set}" = set; then : $as_echo_n "(cached) " >&6 else if echo 'ab*c' | $GREP -F 'ab*c' >/dev/null 2>&1 then ac_cv_path_FGREP="$GREP -F" else if test -z "$FGREP"; then ac_path_FGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in fgrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_FGREP="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_FGREP" && $as_test_x "$ac_path_FGREP"; } || continue # Check for GNU ac_path_FGREP and select it if it is found. # Check for GNU $ac_path_FGREP case `"$ac_path_FGREP" --version 2>&1` in *GNU*) ac_cv_path_FGREP="$ac_path_FGREP" ac_path_FGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'FGREP' >> "conftest.nl" "$ac_path_FGREP" FGREP < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_FGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_FGREP="$ac_path_FGREP" ac_path_FGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_FGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_FGREP"; then as_fn_error "no acceptable fgrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_FGREP=$FGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_FGREP" >&5 $as_echo "$ac_cv_path_FGREP" >&6; } FGREP="$ac_cv_path_FGREP" test -z "$GREP" && GREP=grep # Check whether --with-gnu-ld was given. if test "${with_gnu_ld+set}" = set; then : withval=$with_gnu_ld; test "$withval" = no || with_gnu_ld=yes else with_gnu_ld=no fi ac_prog=ld if test "$GCC" = yes; then # Check if gcc -print-prog-name=ld gives a path. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ld used by $CC" >&5 $as_echo_n "checking for ld used by $CC... " >&6; } case $host in *-*-mingw*) # gcc leaves a trailing carriage return which upsets mingw ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;; *) ac_prog=`($CC -print-prog-name=ld) 2>&5` ;; esac case $ac_prog in # Accept absolute paths. [\\/]* | ?:[\\/]*) re_direlt='/[^/][^/]*/\.\./' # Canonicalize the pathname of ld ac_prog=`$ECHO "$ac_prog"| $SED 's%\\\\%/%g'` while $ECHO "$ac_prog" | $GREP "$re_direlt" > /dev/null 2>&1; do ac_prog=`$ECHO $ac_prog| $SED "s%$re_direlt%/%"` done test -z "$LD" && LD="$ac_prog" ;; "") # If it fails, then pretend we aren't using GCC. ac_prog=ld ;; *) # If it is relative, then search for the first ld in PATH. with_gnu_ld=unknown ;; esac elif test "$with_gnu_ld" = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GNU ld" >&5 $as_echo_n "checking for GNU ld... " >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for non-GNU ld" >&5 $as_echo_n "checking for non-GNU ld... " >&6; } fi if test "${lt_cv_path_LD+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -z "$LD"; then lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR for ac_dir in $PATH; do IFS="$lt_save_ifs" test -z "$ac_dir" && ac_dir=. if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then lt_cv_path_LD="$ac_dir/$ac_prog" # Check to see if the program is GNU ld. I'd rather use --version, # but apparently some variants of GNU ld only accept -v. # Break only if it was the GNU/non-GNU ld that we prefer. case `"$lt_cv_path_LD" -v 2>&1 &5 $as_echo "$LD" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -z "$LD" && as_fn_error "no acceptable ld found in \$PATH" "$LINENO" 5 { $as_echo "$as_me:${as_lineno-$LINENO}: checking if the linker ($LD) is GNU ld" >&5 $as_echo_n "checking if the linker ($LD) is GNU ld... " >&6; } if test "${lt_cv_prog_gnu_ld+set}" = set; then : $as_echo_n "(cached) " >&6 else # I'd rather use --version here, but apparently some GNU lds only accept -v. case `$LD -v 2>&1 &5 $as_echo "$lt_cv_prog_gnu_ld" >&6; } with_gnu_ld=$lt_cv_prog_gnu_ld { $as_echo "$as_me:${as_lineno-$LINENO}: checking for BSD- or MS-compatible name lister (nm)" >&5 $as_echo_n "checking for BSD- or MS-compatible name lister (nm)... " >&6; } if test "${lt_cv_path_NM+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$NM"; then # Let the user override the test. lt_cv_path_NM="$NM" else lt_nm_to_check="${ac_tool_prefix}nm" if test -n "$ac_tool_prefix" && test "$build" = "$host"; then lt_nm_to_check="$lt_nm_to_check nm" fi for lt_tmp_nm in $lt_nm_to_check; do lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR for ac_dir in $PATH /usr/ccs/bin/elf /usr/ccs/bin /usr/ucb /bin; do IFS="$lt_save_ifs" test -z "$ac_dir" && ac_dir=. tmp_nm="$ac_dir/$lt_tmp_nm" if test -f "$tmp_nm" || test -f "$tmp_nm$ac_exeext" ; then # Check to see if the nm accepts a BSD-compat flag. # Adding the `sed 1q' prevents false positives on HP-UX, which says: # nm: unknown option "B" ignored # Tru64's nm complains that /dev/null is an invalid object file case `"$tmp_nm" -B /dev/null 2>&1 | sed '1q'` in */dev/null* | *'Invalid file or object type'*) lt_cv_path_NM="$tmp_nm -B" break ;; *) case `"$tmp_nm" -p /dev/null 2>&1 | sed '1q'` in */dev/null*) lt_cv_path_NM="$tmp_nm -p" break ;; *) lt_cv_path_NM=${lt_cv_path_NM="$tmp_nm"} # keep the first match, but continue # so that we can try to find one that supports BSD flags ;; esac ;; esac fi done IFS="$lt_save_ifs" done : ${lt_cv_path_NM=no} fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_NM" >&5 $as_echo "$lt_cv_path_NM" >&6; } if test "$lt_cv_path_NM" != "no"; then NM="$lt_cv_path_NM" else # Didn't find any BSD compatible name lister, look for dumpbin. if test -n "$ac_tool_prefix"; then for ac_prog in "dumpbin -symbols" "link -dump -symbols" do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_DUMPBIN+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$DUMPBIN"; then ac_cv_prog_DUMPBIN="$DUMPBIN" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_DUMPBIN="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi DUMPBIN=$ac_cv_prog_DUMPBIN if test -n "$DUMPBIN"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DUMPBIN" >&5 $as_echo "$DUMPBIN" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$DUMPBIN" && break done fi if test -z "$DUMPBIN"; then ac_ct_DUMPBIN=$DUMPBIN for ac_prog in "dumpbin -symbols" "link -dump -symbols" do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_DUMPBIN+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_DUMPBIN"; then ac_cv_prog_ac_ct_DUMPBIN="$ac_ct_DUMPBIN" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_DUMPBIN="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_DUMPBIN=$ac_cv_prog_ac_ct_DUMPBIN if test -n "$ac_ct_DUMPBIN"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DUMPBIN" >&5 $as_echo "$ac_ct_DUMPBIN" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_DUMPBIN" && break done if test "x$ac_ct_DUMPBIN" = x; then DUMPBIN=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac DUMPBIN=$ac_ct_DUMPBIN fi fi if test "$DUMPBIN" != ":"; then NM="$DUMPBIN" fi fi test -z "$NM" && NM=nm { $as_echo "$as_me:${as_lineno-$LINENO}: checking the name lister ($NM) interface" >&5 $as_echo_n "checking the name lister ($NM) interface... " >&6; } if test "${lt_cv_nm_interface+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_nm_interface="BSD nm" echo "int some_variable = 0;" > conftest.$ac_ext (eval echo "\"\$as_me:4040: $ac_compile\"" >&5) (eval "$ac_compile" 2>conftest.err) cat conftest.err >&5 (eval echo "\"\$as_me:4043: $NM \\\"conftest.$ac_objext\\\"\"" >&5) (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) cat conftest.err >&5 (eval echo "\"\$as_me:4046: output\"" >&5) cat conftest.out >&5 if $GREP 'External.*some_variable' conftest.out > /dev/null; then lt_cv_nm_interface="MS dumpbin" fi rm -f conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_nm_interface" >&5 $as_echo "$lt_cv_nm_interface" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ln -s works" >&5 $as_echo_n "checking whether ln -s works... " >&6; } LN_S=$as_ln_s if test "$LN_S" = "ln -s"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no, using $LN_S" >&5 $as_echo "no, using $LN_S" >&6; } fi # find the maximum length of command line arguments { $as_echo "$as_me:${as_lineno-$LINENO}: checking the maximum length of command line arguments" >&5 $as_echo_n "checking the maximum length of command line arguments... " >&6; } if test "${lt_cv_sys_max_cmd_len+set}" = set; then : $as_echo_n "(cached) " >&6 else i=0 teststring="ABCD" case $build_os in msdosdjgpp*) # On DJGPP, this test can blow up pretty badly due to problems in libc # (any single argument exceeding 2000 bytes causes a buffer overrun # during glob expansion). Even if it were fixed, the result of this # check would be larger than it should be. lt_cv_sys_max_cmd_len=12288; # 12K is about right ;; gnu*) # Under GNU Hurd, this test is not required because there is # no limit to the length of command line arguments. # Libtool will interpret -1 as no limit whatsoever lt_cv_sys_max_cmd_len=-1; ;; cygwin* | mingw* | cegcc*) # On Win9x/ME, this test blows up -- it succeeds, but takes # about 5 minutes as the teststring grows exponentially. # Worse, since 9x/ME are not pre-emptively multitasking, # you end up with a "frozen" computer, even though with patience # the test eventually succeeds (with a max line length of 256k). # Instead, let's just punt: use the minimum linelength reported by # all of the supported platforms: 8192 (on NT/2K/XP). lt_cv_sys_max_cmd_len=8192; ;; amigaos*) # On AmigaOS with pdksh, this test takes hours, literally. # So we just punt and use a minimum line length of 8192. lt_cv_sys_max_cmd_len=8192; ;; netbsd* | freebsd* | openbsd* | darwin* | dragonfly*) # This has been around since 386BSD, at least. Likely further. if test -x /sbin/sysctl; then lt_cv_sys_max_cmd_len=`/sbin/sysctl -n kern.argmax` elif test -x /usr/sbin/sysctl; then lt_cv_sys_max_cmd_len=`/usr/sbin/sysctl -n kern.argmax` else lt_cv_sys_max_cmd_len=65536 # usable default for all BSDs fi # And add a safety zone lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` ;; interix*) # We know the value 262144 and hardcode it with a safety zone (like BSD) lt_cv_sys_max_cmd_len=196608 ;; osf*) # Dr. Hans Ekkehard Plesser reports seeing a kernel panic running configure # due to this test when exec_disable_arg_limit is 1 on Tru64. It is not # nice to cause kernel panics so lets avoid the loop below. # First set a reasonable default. lt_cv_sys_max_cmd_len=16384 # if test -x /sbin/sysconfig; then case `/sbin/sysconfig -q proc exec_disable_arg_limit` in *1*) lt_cv_sys_max_cmd_len=-1 ;; esac fi ;; sco3.2v5*) lt_cv_sys_max_cmd_len=102400 ;; sysv5* | sco5v6* | sysv4.2uw2*) kargmax=`grep ARG_MAX /etc/conf/cf.d/stune 2>/dev/null` if test -n "$kargmax"; then lt_cv_sys_max_cmd_len=`echo $kargmax | sed 's/.*[ ]//'` else lt_cv_sys_max_cmd_len=32768 fi ;; *) lt_cv_sys_max_cmd_len=`(getconf ARG_MAX) 2> /dev/null` if test -n "$lt_cv_sys_max_cmd_len"; then lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` else # Make teststring a little bigger before we do anything with it. # a 1K string should be a reasonable start. for i in 1 2 3 4 5 6 7 8 ; do teststring=$teststring$teststring done SHELL=${SHELL-${CONFIG_SHELL-/bin/sh}} # If test is not a shell built-in, we'll probably end up computing a # maximum length that is only half of the actual maximum length, but # we can't tell. while { test "X"`$SHELL $0 --fallback-echo "X$teststring$teststring" 2>/dev/null` \ = "XX$teststring$teststring"; } >/dev/null 2>&1 && test $i != 17 # 1/2 MB should be enough do i=`expr $i + 1` teststring=$teststring$teststring done # Only check the string length outside the loop. lt_cv_sys_max_cmd_len=`expr "X$teststring" : ".*" 2>&1` teststring= # Add a significant safety factor because C++ compilers can tack on # massive amounts of additional arguments before passing them to the # linker. It appears as though 1/2 is a usable value. lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 2` fi ;; esac fi if test -n $lt_cv_sys_max_cmd_len ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sys_max_cmd_len" >&5 $as_echo "$lt_cv_sys_max_cmd_len" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5 $as_echo "none" >&6; } fi max_cmd_len=$lt_cv_sys_max_cmd_len : ${CP="cp -f"} : ${MV="mv -f"} : ${RM="rm -f"} { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the shell understands some XSI constructs" >&5 $as_echo_n "checking whether the shell understands some XSI constructs... " >&6; } # Try some XSI features xsi_shell=no ( _lt_dummy="a/b/c" test "${_lt_dummy##*/},${_lt_dummy%/*},"${_lt_dummy%"$_lt_dummy"}, \ = c,a/b,, \ && eval 'test $(( 1 + 1 )) -eq 2 \ && test "${#_lt_dummy}" -eq 5' ) >/dev/null 2>&1 \ && xsi_shell=yes { $as_echo "$as_me:${as_lineno-$LINENO}: result: $xsi_shell" >&5 $as_echo "$xsi_shell" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the shell understands \"+=\"" >&5 $as_echo_n "checking whether the shell understands \"+=\"... " >&6; } lt_shell_append=no ( foo=bar; set foo baz; eval "$1+=\$2" && test "$foo" = barbaz ) \ >/dev/null 2>&1 \ && lt_shell_append=yes { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_shell_append" >&5 $as_echo "$lt_shell_append" >&6; } if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then lt_unset=unset else lt_unset=false fi # test EBCDIC or ASCII case `echo X|tr X '\101'` in A) # ASCII based system # \n is not interpreted correctly by Solaris 8 /usr/ucb/tr lt_SP2NL='tr \040 \012' lt_NL2SP='tr \015\012 \040\040' ;; *) # EBCDIC based system lt_SP2NL='tr \100 \n' lt_NL2SP='tr \r\n \100\100' ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $LD option to reload object files" >&5 $as_echo_n "checking for $LD option to reload object files... " >&6; } if test "${lt_cv_ld_reload_flag+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_ld_reload_flag='-r' fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_reload_flag" >&5 $as_echo "$lt_cv_ld_reload_flag" >&6; } reload_flag=$lt_cv_ld_reload_flag case $reload_flag in "" | " "*) ;; *) reload_flag=" $reload_flag" ;; esac reload_cmds='$LD$reload_flag -o $output$reload_objs' case $host_os in darwin*) if test "$GCC" = yes; then reload_cmds='$LTCC $LTCFLAGS -nostdlib ${wl}-r -o $output$reload_objs' else reload_cmds='$LD$reload_flag -o $output$reload_objs' fi ;; esac if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}objdump", so it can be a program name with args. set dummy ${ac_tool_prefix}objdump; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_OBJDUMP+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$OBJDUMP"; then ac_cv_prog_OBJDUMP="$OBJDUMP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_OBJDUMP="${ac_tool_prefix}objdump" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OBJDUMP=$ac_cv_prog_OBJDUMP if test -n "$OBJDUMP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OBJDUMP" >&5 $as_echo "$OBJDUMP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_OBJDUMP"; then ac_ct_OBJDUMP=$OBJDUMP # Extract the first word of "objdump", so it can be a program name with args. set dummy objdump; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_OBJDUMP+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_OBJDUMP"; then ac_cv_prog_ac_ct_OBJDUMP="$ac_ct_OBJDUMP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_OBJDUMP="objdump" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_OBJDUMP=$ac_cv_prog_ac_ct_OBJDUMP if test -n "$ac_ct_OBJDUMP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OBJDUMP" >&5 $as_echo "$ac_ct_OBJDUMP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_OBJDUMP" = x; then OBJDUMP="false" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac OBJDUMP=$ac_ct_OBJDUMP fi else OBJDUMP="$ac_cv_prog_OBJDUMP" fi test -z "$OBJDUMP" && OBJDUMP=objdump { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to recognize dependent libraries" >&5 $as_echo_n "checking how to recognize dependent libraries... " >&6; } if test "${lt_cv_deplibs_check_method+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_file_magic_cmd='$MAGIC_CMD' lt_cv_file_magic_test_file= lt_cv_deplibs_check_method='unknown' # Need to set the preceding variable on all platforms that support # interlibrary dependencies. # 'none' -- dependencies not supported. # `unknown' -- same as none, but documents that we really don't know. # 'pass_all' -- all dependencies passed with no checks. # 'test_compile' -- check by making test program. # 'file_magic [[regex]]' -- check by looking for files in library path # which responds to the $file_magic_cmd with a given extended regex. # If you have `file' or equivalent on your system and you're not sure # whether `pass_all' will *always* work, you probably want this one. case $host_os in aix[4-9]*) lt_cv_deplibs_check_method=pass_all ;; beos*) lt_cv_deplibs_check_method=pass_all ;; bsdi[45]*) lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (shared object|dynamic lib)' lt_cv_file_magic_cmd='/usr/bin/file -L' lt_cv_file_magic_test_file=/shlib/libc.so ;; cygwin*) # func_win32_libid is a shell function defined in ltmain.sh lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL' lt_cv_file_magic_cmd='func_win32_libid' ;; mingw* | pw32*) # Base MSYS/MinGW do not provide the 'file' command needed by # func_win32_libid shell function, so use a weaker test based on 'objdump', # unless we find 'file', for example because we are cross-compiling. if ( file / ) >/dev/null 2>&1; then lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL' lt_cv_file_magic_cmd='func_win32_libid' else lt_cv_deplibs_check_method='file_magic file format pei*-i386(.*architecture: i386)?' lt_cv_file_magic_cmd='$OBJDUMP -f' fi ;; cegcc) # use the weaker test based on 'objdump'. See mingw*. lt_cv_deplibs_check_method='file_magic file format pe-arm-.*little(.*architecture: arm)?' lt_cv_file_magic_cmd='$OBJDUMP -f' ;; darwin* | rhapsody*) lt_cv_deplibs_check_method=pass_all ;; freebsd* | dragonfly*) if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then case $host_cpu in i*86 ) # Not sure whether the presence of OpenBSD here was a mistake. # Let's accept both of them until this is cleared up. lt_cv_deplibs_check_method='file_magic (FreeBSD|OpenBSD|DragonFly)/i[3-9]86 (compact )?demand paged shared library' lt_cv_file_magic_cmd=/usr/bin/file lt_cv_file_magic_test_file=`echo /usr/lib/libc.so.*` ;; esac else lt_cv_deplibs_check_method=pass_all fi ;; gnu*) lt_cv_deplibs_check_method=pass_all ;; hpux10.20* | hpux11*) lt_cv_file_magic_cmd=/usr/bin/file case $host_cpu in ia64*) lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF-[0-9][0-9]) shared object file - IA64' lt_cv_file_magic_test_file=/usr/lib/hpux32/libc.so ;; hppa*64*) lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF-[0-9][0-9]) shared object file - PA-RISC [0-9].[0-9]' lt_cv_file_magic_test_file=/usr/lib/pa20_64/libc.sl ;; *) lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|PA-RISC[0-9].[0-9]) shared library' lt_cv_file_magic_test_file=/usr/lib/libc.sl ;; esac ;; interix[3-9]*) # PIC code is broken on Interix 3.x, that's why |\.a not |_pic\.a here lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so|\.a)$' ;; irix5* | irix6* | nonstopux*) case $LD in *-32|*"-32 ") libmagic=32-bit;; *-n32|*"-n32 ") libmagic=N32;; *-64|*"-64 ") libmagic=64-bit;; *) libmagic=never-match;; esac lt_cv_deplibs_check_method=pass_all ;; # This must be Linux ELF. linux* | k*bsd*-gnu) lt_cv_deplibs_check_method=pass_all ;; netbsd* | netbsdelf*-gnu) if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|_pic\.a)$' else lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so|_pic\.a)$' fi ;; newos6*) lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (executable|dynamic lib)' lt_cv_file_magic_cmd=/usr/bin/file lt_cv_file_magic_test_file=/usr/lib/libnls.so ;; *nto* | *qnx*) lt_cv_deplibs_check_method=pass_all ;; openbsd*) if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|\.so|_pic\.a)$' else lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|_pic\.a)$' fi ;; osf3* | osf4* | osf5*) lt_cv_deplibs_check_method=pass_all ;; rdos*) lt_cv_deplibs_check_method=pass_all ;; solaris*) lt_cv_deplibs_check_method=pass_all ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) lt_cv_deplibs_check_method=pass_all ;; sysv4 | sysv4.3*) case $host_vendor in motorola) lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (shared object|dynamic lib) M[0-9][0-9]* Version [0-9]' lt_cv_file_magic_test_file=`echo /usr/lib/libc.so*` ;; ncr) lt_cv_deplibs_check_method=pass_all ;; sequent) lt_cv_file_magic_cmd='/bin/file' lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [LM]SB (shared object|dynamic lib )' ;; sni) lt_cv_file_magic_cmd='/bin/file' lt_cv_deplibs_check_method="file_magic ELF [0-9][0-9]*-bit [LM]SB dynamic lib" lt_cv_file_magic_test_file=/lib/libc.so ;; siemens) lt_cv_deplibs_check_method=pass_all ;; pc) lt_cv_deplibs_check_method=pass_all ;; esac ;; tpf*) lt_cv_deplibs_check_method=pass_all ;; esac fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_deplibs_check_method" >&5 $as_echo "$lt_cv_deplibs_check_method" >&6; } file_magic_cmd=$lt_cv_file_magic_cmd deplibs_check_method=$lt_cv_deplibs_check_method test -z "$deplibs_check_method" && deplibs_check_method=unknown if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args. set dummy ${ac_tool_prefix}ar; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_AR+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$AR"; then ac_cv_prog_AR="$AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_AR="${ac_tool_prefix}ar" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AR=$ac_cv_prog_AR if test -n "$AR"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 $as_echo "$AR" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_AR"; then ac_ct_AR=$AR # Extract the first word of "ar", so it can be a program name with args. set dummy ar; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_AR+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_AR"; then ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_AR="ar" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_AR=$ac_cv_prog_ac_ct_AR if test -n "$ac_ct_AR"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5 $as_echo "$ac_ct_AR" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_AR" = x; then AR="false" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac AR=$ac_ct_AR fi else AR="$ac_cv_prog_AR" fi test -z "$AR" && AR=ar test -z "$AR_FLAGS" && AR_FLAGS=cru if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. set dummy ${ac_tool_prefix}strip; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_STRIP+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$STRIP"; then ac_cv_prog_STRIP="$STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_STRIP="${ac_tool_prefix}strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5 $as_echo "$STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_STRIP"; then ac_ct_STRIP=$STRIP # Extract the first word of "strip", so it can be a program name with args. set dummy strip; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_STRIP+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_STRIP"; then ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_STRIP="strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5 $as_echo "$ac_ct_STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_STRIP" = x; then STRIP=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac STRIP=$ac_ct_STRIP fi else STRIP="$ac_cv_prog_STRIP" fi test -z "$STRIP" && STRIP=: if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_RANLIB+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 $as_echo "$RANLIB" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_RANLIB+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_RANLIB="ranlib" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 $as_echo "$ac_ct_RANLIB" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_RANLIB" = x; then RANLIB=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac RANLIB=$ac_ct_RANLIB fi else RANLIB="$ac_cv_prog_RANLIB" fi test -z "$RANLIB" && RANLIB=: # Determine commands to create old-style static archives. old_archive_cmds='$AR $AR_FLAGS $oldlib$oldobjs' old_postinstall_cmds='chmod 644 $oldlib' old_postuninstall_cmds= if test -n "$RANLIB"; then case $host_os in openbsd*) old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$oldlib" ;; *) old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$oldlib" ;; esac old_archive_cmds="$old_archive_cmds~\$RANLIB \$oldlib" fi # If no C compiler was specified, use CC. LTCC=${LTCC-"$CC"} # If no C compiler flags were specified, use CFLAGS. LTCFLAGS=${LTCFLAGS-"$CFLAGS"} # Allow CC to be a program name with arguments. compiler=$CC # Check for command to grab the raw symbol name followed by C symbol from nm. { $as_echo "$as_me:${as_lineno-$LINENO}: checking command to parse $NM output from $compiler object" >&5 $as_echo_n "checking command to parse $NM output from $compiler object... " >&6; } if test "${lt_cv_sys_global_symbol_pipe+set}" = set; then : $as_echo_n "(cached) " >&6 else # These are sane defaults that work on at least a few old systems. # [They come from Ultrix. What could be older than Ultrix?!! ;)] # Character class describing NM global symbol codes. symcode='[BCDEGRST]' # Regexp to match symbols that can be accessed directly from C. sympat='\([_A-Za-z][_A-Za-z0-9]*\)' # Define system-specific variables. case $host_os in aix*) symcode='[BCDT]' ;; cygwin* | mingw* | pw32* | cegcc*) symcode='[ABCDGISTW]' ;; hpux*) if test "$host_cpu" = ia64; then symcode='[ABCDEGRST]' fi ;; irix* | nonstopux*) symcode='[BCDEGRST]' ;; osf*) symcode='[BCDEGQRST]' ;; solaris*) symcode='[BDRT]' ;; sco3.2v5*) symcode='[DT]' ;; sysv4.2uw2*) symcode='[DT]' ;; sysv5* | sco5v6* | unixware* | OpenUNIX*) symcode='[ABDT]' ;; sysv4) symcode='[DFNSTU]' ;; esac # If we're using GNU nm, then use its standard symbol codes. case `$NM -V 2>&1` in *GNU* | *'with BFD'*) symcode='[ABCDGIRSTW]' ;; esac # Transform an extracted symbol line into a proper C declaration. # Some systems (esp. on ia64) link data and code symbols differently, # so use this general approach. lt_cv_sys_global_symbol_to_cdecl="sed -n -e 's/^T .* \(.*\)$/extern int \1();/p' -e 's/^$symcode* .* \(.*\)$/extern char \1;/p'" # Transform an extracted symbol line into symbol name and symbol address lt_cv_sys_global_symbol_to_c_name_address="sed -n -e 's/^: \([^ ]*\) $/ {\\\"\1\\\", (void *) 0},/p' -e 's/^$symcode* \([^ ]*\) \([^ ]*\)$/ {\"\2\", (void *) \&\2},/p'" lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="sed -n -e 's/^: \([^ ]*\) $/ {\\\"\1\\\", (void *) 0},/p' -e 's/^$symcode* \([^ ]*\) \(lib[^ ]*\)$/ {\"\2\", (void *) \&\2},/p' -e 's/^$symcode* \([^ ]*\) \([^ ]*\)$/ {\"lib\2\", (void *) \&\2},/p'" # Handle CRLF in mingw tool chain opt_cr= case $build_os in mingw*) opt_cr=`$ECHO 'x\{0,1\}' | tr x '\015'` # option cr in regexp ;; esac # Try without a prefix underscore, then with it. for ac_symprfx in "" "_"; do # Transform symcode, sympat, and symprfx into a raw symbol and a C symbol. symxfrm="\\1 $ac_symprfx\\2 \\2" # Write the raw and C identifiers. if test "$lt_cv_nm_interface" = "MS dumpbin"; then # Fake it for dumpbin and say T for any non-static function # and D for any global variable. # Also find C++ and __fastcall symbols from MSVC++, # which start with @ or ?. lt_cv_sys_global_symbol_pipe="$AWK '"\ " {last_section=section; section=\$ 3};"\ " /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\ " \$ 0!~/External *\|/{next};"\ " / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\ " {if(hide[section]) next};"\ " {f=0}; \$ 0~/\(\).*\|/{f=1}; {printf f ? \"T \" : \"D \"};"\ " {split(\$ 0, a, /\||\r/); split(a[2], s)};"\ " s[1]~/^[@?]/{print s[1], s[1]; next};"\ " s[1]~prfx {split(s[1],t,\"@\"); print t[1], substr(t[1],length(prfx))}"\ " ' prfx=^$ac_symprfx" else lt_cv_sys_global_symbol_pipe="sed -n -e 's/^.*[ ]\($symcode$symcode*\)[ ][ ]*$ac_symprfx$sympat$opt_cr$/$symxfrm/p'" fi # Check to see that the pipe works correctly. pipe_works=no rm -f conftest* cat > conftest.$ac_ext <<_LT_EOF #ifdef __cplusplus extern "C" { #endif char nm_test_var; void nm_test_func(void); void nm_test_func(void){} #ifdef __cplusplus } #endif int main(){nm_test_var='a';nm_test_func();return(0);} _LT_EOF if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then # Now try to grab the symbols. nlist=conftest.nm if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$NM conftest.$ac_objext \| $lt_cv_sys_global_symbol_pipe \> $nlist\""; } >&5 (eval $NM conftest.$ac_objext \| $lt_cv_sys_global_symbol_pipe \> $nlist) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && test -s "$nlist"; then # Try sorting and uniquifying the output. if sort "$nlist" | uniq > "$nlist"T; then mv -f "$nlist"T "$nlist" else rm -f "$nlist"T fi # Make sure that we snagged all the symbols we need. if $GREP ' nm_test_var$' "$nlist" >/dev/null; then if $GREP ' nm_test_func$' "$nlist" >/dev/null; then cat <<_LT_EOF > conftest.$ac_ext #ifdef __cplusplus extern "C" { #endif _LT_EOF # Now generate the symbol file. eval "$lt_cv_sys_global_symbol_to_cdecl"' < "$nlist" | $GREP -v main >> conftest.$ac_ext' cat <<_LT_EOF >> conftest.$ac_ext /* The mapping between symbol names and symbols. */ const struct { const char *name; void *address; } lt__PROGRAM__LTX_preloaded_symbols[] = { { "@PROGRAM@", (void *) 0 }, _LT_EOF $SED "s/^$symcode$symcode* \(.*\) \(.*\)$/ {\"\2\", (void *) \&\2},/" < "$nlist" | $GREP -v main >> conftest.$ac_ext cat <<\_LT_EOF >> conftest.$ac_ext {0, (void *) 0} }; /* This works around a problem in FreeBSD linker */ #ifdef FREEBSD_WORKAROUND static const void *lt_preloaded_setup() { return lt__PROGRAM__LTX_preloaded_symbols; } #endif #ifdef __cplusplus } #endif _LT_EOF # Now try linking the two files. mv conftest.$ac_objext conftstm.$ac_objext lt_save_LIBS="$LIBS" lt_save_CFLAGS="$CFLAGS" LIBS="conftstm.$ac_objext" CFLAGS="$CFLAGS$lt_prog_compiler_no_builtin_flag" if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 (eval $ac_link) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && test -s conftest${ac_exeext}; then pipe_works=yes fi LIBS="$lt_save_LIBS" CFLAGS="$lt_save_CFLAGS" else echo "cannot find nm_test_func in $nlist" >&5 fi else echo "cannot find nm_test_var in $nlist" >&5 fi else echo "cannot run $lt_cv_sys_global_symbol_pipe" >&5 fi else echo "$progname: failed program was:" >&5 cat conftest.$ac_ext >&5 fi rm -rf conftest* conftst* # Do not use the global_symbol_pipe unless it works. if test "$pipe_works" = yes; then break else lt_cv_sys_global_symbol_pipe= fi done fi if test -z "$lt_cv_sys_global_symbol_pipe"; then lt_cv_sys_global_symbol_to_cdecl= fi if test -z "$lt_cv_sys_global_symbol_pipe$lt_cv_sys_global_symbol_to_cdecl"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: failed" >&5 $as_echo "failed" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } fi # Check whether --enable-libtool-lock was given. if test "${enable_libtool_lock+set}" = set; then : enableval=$enable_libtool_lock; fi test "x$enable_libtool_lock" != xno && enable_libtool_lock=yes # Some flags need to be propagated to the compiler or linker for good # libtool support. case $host in ia64-*-hpux*) # Find out which ABI we are using. echo 'int i;' > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then case `/usr/bin/file conftest.$ac_objext` in *ELF-32*) HPUX_IA64_MODE="32" ;; *ELF-64*) HPUX_IA64_MODE="64" ;; esac fi rm -rf conftest* ;; *-*-irix6*) # Find out which ABI we are using. echo '#line 5252 "configure"' > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then if test "$lt_cv_prog_gnu_ld" = yes; then case `/usr/bin/file conftest.$ac_objext` in *32-bit*) LD="${LD-ld} -melf32bsmip" ;; *N32*) LD="${LD-ld} -melf32bmipn32" ;; *64-bit*) LD="${LD-ld} -melf64bmip" ;; esac else case `/usr/bin/file conftest.$ac_objext` in *32-bit*) LD="${LD-ld} -32" ;; *N32*) LD="${LD-ld} -n32" ;; *64-bit*) LD="${LD-ld} -64" ;; esac fi fi rm -rf conftest* ;; x86_64-*kfreebsd*-gnu|x86_64-*linux*|ppc*-*linux*|powerpc*-*linux*| \ s390*-*linux*|s390*-*tpf*|sparc*-*linux*) # Find out which ABI we are using. echo 'int i;' > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then case `/usr/bin/file conftest.o` in *32-bit*) case $host in x86_64-*kfreebsd*-gnu) LD="${LD-ld} -m elf_i386_fbsd" ;; x86_64-*linux*) LD="${LD-ld} -m elf_i386" ;; ppc64-*linux*|powerpc64-*linux*) LD="${LD-ld} -m elf32ppclinux" ;; s390x-*linux*) LD="${LD-ld} -m elf_s390" ;; sparc64-*linux*) LD="${LD-ld} -m elf32_sparc" ;; esac ;; *64-bit*) case $host in x86_64-*kfreebsd*-gnu) LD="${LD-ld} -m elf_x86_64_fbsd" ;; x86_64-*linux*) LD="${LD-ld} -m elf_x86_64" ;; ppc*-*linux*|powerpc*-*linux*) LD="${LD-ld} -m elf64ppc" ;; s390*-*linux*|s390*-*tpf*) LD="${LD-ld} -m elf64_s390" ;; sparc*-*linux*) LD="${LD-ld} -m elf64_sparc" ;; esac ;; esac fi rm -rf conftest* ;; *-*-sco3.2v5*) # On SCO OpenServer 5, we need -belf to get full-featured binaries. SAVE_CFLAGS="$CFLAGS" CFLAGS="$CFLAGS -belf" { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler needs -belf" >&5 $as_echo_n "checking whether the C compiler needs -belf... " >&6; } if test "${lt_cv_cc_needs_belf+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : lt_cv_cc_needs_belf=yes else lt_cv_cc_needs_belf=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_cc_needs_belf" >&5 $as_echo "$lt_cv_cc_needs_belf" >&6; } if test x"$lt_cv_cc_needs_belf" != x"yes"; then # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf CFLAGS="$SAVE_CFLAGS" fi ;; sparc*-*solaris*) # Find out which ABI we are using. echo 'int i;' > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then case `/usr/bin/file conftest.o` in *64-bit*) case $lt_cv_prog_gnu_ld in yes*) LD="${LD-ld} -m elf64_sparc" ;; *) if ${LD-ld} -64 -r -o conftest2.o conftest.o >/dev/null 2>&1; then LD="${LD-ld} -64" fi ;; esac ;; esac fi rm -rf conftest* ;; esac need_locks="$enable_libtool_lock" case $host_os in rhapsody* | darwin*) if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}dsymutil", so it can be a program name with args. set dummy ${ac_tool_prefix}dsymutil; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_DSYMUTIL+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$DSYMUTIL"; then ac_cv_prog_DSYMUTIL="$DSYMUTIL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_DSYMUTIL="${ac_tool_prefix}dsymutil" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi DSYMUTIL=$ac_cv_prog_DSYMUTIL if test -n "$DSYMUTIL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DSYMUTIL" >&5 $as_echo "$DSYMUTIL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_DSYMUTIL"; then ac_ct_DSYMUTIL=$DSYMUTIL # Extract the first word of "dsymutil", so it can be a program name with args. set dummy dsymutil; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_DSYMUTIL+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_DSYMUTIL"; then ac_cv_prog_ac_ct_DSYMUTIL="$ac_ct_DSYMUTIL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_DSYMUTIL="dsymutil" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_DSYMUTIL=$ac_cv_prog_ac_ct_DSYMUTIL if test -n "$ac_ct_DSYMUTIL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DSYMUTIL" >&5 $as_echo "$ac_ct_DSYMUTIL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_DSYMUTIL" = x; then DSYMUTIL=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac DSYMUTIL=$ac_ct_DSYMUTIL fi else DSYMUTIL="$ac_cv_prog_DSYMUTIL" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}nmedit", so it can be a program name with args. set dummy ${ac_tool_prefix}nmedit; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_NMEDIT+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$NMEDIT"; then ac_cv_prog_NMEDIT="$NMEDIT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_NMEDIT="${ac_tool_prefix}nmedit" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi NMEDIT=$ac_cv_prog_NMEDIT if test -n "$NMEDIT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $NMEDIT" >&5 $as_echo "$NMEDIT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_NMEDIT"; then ac_ct_NMEDIT=$NMEDIT # Extract the first word of "nmedit", so it can be a program name with args. set dummy nmedit; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_NMEDIT+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_NMEDIT"; then ac_cv_prog_ac_ct_NMEDIT="$ac_ct_NMEDIT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_NMEDIT="nmedit" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_NMEDIT=$ac_cv_prog_ac_ct_NMEDIT if test -n "$ac_ct_NMEDIT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_NMEDIT" >&5 $as_echo "$ac_ct_NMEDIT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_NMEDIT" = x; then NMEDIT=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac NMEDIT=$ac_ct_NMEDIT fi else NMEDIT="$ac_cv_prog_NMEDIT" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}lipo", so it can be a program name with args. set dummy ${ac_tool_prefix}lipo; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_LIPO+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$LIPO"; then ac_cv_prog_LIPO="$LIPO" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_LIPO="${ac_tool_prefix}lipo" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi LIPO=$ac_cv_prog_LIPO if test -n "$LIPO"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LIPO" >&5 $as_echo "$LIPO" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_LIPO"; then ac_ct_LIPO=$LIPO # Extract the first word of "lipo", so it can be a program name with args. set dummy lipo; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_LIPO+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_LIPO"; then ac_cv_prog_ac_ct_LIPO="$ac_ct_LIPO" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_LIPO="lipo" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_LIPO=$ac_cv_prog_ac_ct_LIPO if test -n "$ac_ct_LIPO"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_LIPO" >&5 $as_echo "$ac_ct_LIPO" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_LIPO" = x; then LIPO=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac LIPO=$ac_ct_LIPO fi else LIPO="$ac_cv_prog_LIPO" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}otool", so it can be a program name with args. set dummy ${ac_tool_prefix}otool; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_OTOOL+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$OTOOL"; then ac_cv_prog_OTOOL="$OTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_OTOOL="${ac_tool_prefix}otool" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OTOOL=$ac_cv_prog_OTOOL if test -n "$OTOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OTOOL" >&5 $as_echo "$OTOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_OTOOL"; then ac_ct_OTOOL=$OTOOL # Extract the first word of "otool", so it can be a program name with args. set dummy otool; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_OTOOL+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_OTOOL"; then ac_cv_prog_ac_ct_OTOOL="$ac_ct_OTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_OTOOL="otool" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_OTOOL=$ac_cv_prog_ac_ct_OTOOL if test -n "$ac_ct_OTOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OTOOL" >&5 $as_echo "$ac_ct_OTOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_OTOOL" = x; then OTOOL=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac OTOOL=$ac_ct_OTOOL fi else OTOOL="$ac_cv_prog_OTOOL" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}otool64", so it can be a program name with args. set dummy ${ac_tool_prefix}otool64; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_OTOOL64+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$OTOOL64"; then ac_cv_prog_OTOOL64="$OTOOL64" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_OTOOL64="${ac_tool_prefix}otool64" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OTOOL64=$ac_cv_prog_OTOOL64 if test -n "$OTOOL64"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OTOOL64" >&5 $as_echo "$OTOOL64" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_OTOOL64"; then ac_ct_OTOOL64=$OTOOL64 # Extract the first word of "otool64", so it can be a program name with args. set dummy otool64; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_OTOOL64+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_OTOOL64"; then ac_cv_prog_ac_ct_OTOOL64="$ac_ct_OTOOL64" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_OTOOL64="otool64" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_OTOOL64=$ac_cv_prog_ac_ct_OTOOL64 if test -n "$ac_ct_OTOOL64"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OTOOL64" >&5 $as_echo "$ac_ct_OTOOL64" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_OTOOL64" = x; then OTOOL64=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac OTOOL64=$ac_ct_OTOOL64 fi else OTOOL64="$ac_cv_prog_OTOOL64" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -single_module linker flag" >&5 $as_echo_n "checking for -single_module linker flag... " >&6; } if test "${lt_cv_apple_cc_single_mod+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_apple_cc_single_mod=no if test -z "${LT_MULTI_MODULE}"; then # By default we will add the -single_module flag. You can override # by either setting the environment variable LT_MULTI_MODULE # non-empty at configure time, or by adding -multi_module to the # link flags. rm -rf libconftest.dylib* echo "int foo(void){return 1;}" > conftest.c echo "$LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ -dynamiclib -Wl,-single_module conftest.c" >&5 $LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ -dynamiclib -Wl,-single_module conftest.c 2>conftest.err _lt_result=$? if test -f libconftest.dylib && test ! -s conftest.err && test $_lt_result = 0; then lt_cv_apple_cc_single_mod=yes else cat conftest.err >&5 fi rm -rf libconftest.dylib* rm -f conftest.* fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_apple_cc_single_mod" >&5 $as_echo "$lt_cv_apple_cc_single_mod" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -exported_symbols_list linker flag" >&5 $as_echo_n "checking for -exported_symbols_list linker flag... " >&6; } if test "${lt_cv_ld_exported_symbols_list+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_ld_exported_symbols_list=no save_LDFLAGS=$LDFLAGS echo "_main" > conftest.sym LDFLAGS="$LDFLAGS -Wl,-exported_symbols_list,conftest.sym" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : lt_cv_ld_exported_symbols_list=yes else lt_cv_ld_exported_symbols_list=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS="$save_LDFLAGS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_exported_symbols_list" >&5 $as_echo "$lt_cv_ld_exported_symbols_list" >&6; } case $host_os in rhapsody* | darwin1.[012]) _lt_dar_allow_undefined='${wl}-undefined ${wl}suppress' ;; darwin1.*) _lt_dar_allow_undefined='${wl}-flat_namespace ${wl}-undefined ${wl}suppress' ;; darwin*) # darwin 5.x on # if running on 10.5 or later, the deployment target defaults # to the OS version, if on x86, and 10.4, the deployment # target defaults to 10.4. Don't you love it? case ${MACOSX_DEPLOYMENT_TARGET-10.0},$host in 10.0,*86*-darwin8*|10.0,*-darwin[91]*) _lt_dar_allow_undefined='${wl}-undefined ${wl}dynamic_lookup' ;; 10.[012]*) _lt_dar_allow_undefined='${wl}-flat_namespace ${wl}-undefined ${wl}suppress' ;; 10.*) _lt_dar_allow_undefined='${wl}-undefined ${wl}dynamic_lookup' ;; esac ;; esac if test "$lt_cv_apple_cc_single_mod" = "yes"; then _lt_dar_single_mod='$single_module' fi if test "$lt_cv_ld_exported_symbols_list" = "yes"; then _lt_dar_export_syms=' ${wl}-exported_symbols_list,$output_objdir/${libname}-symbols.expsym' else _lt_dar_export_syms='~$NMEDIT -s $output_objdir/${libname}-symbols.expsym ${lib}' fi if test "$DSYMUTIL" != ":"; then _lt_dsymutil='~$DSYMUTIL $lib || :' else _lt_dsymutil= fi ;; esac ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test "${ac_cv_prog_CPP+set}" = set; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if test "${ac_cv_header_stdc+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : : else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default " eval as_val=\$$as_ac_Header if test "x$as_val" = x""yes; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in dlfcn.h do : ac_fn_c_check_header_compile "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default " if test "x$ac_cv_header_dlfcn_h" = x""yes; then : cat >>confdefs.h <<_ACEOF #define HAVE_DLFCN_H 1 _ACEOF fi done # Set options enable_dlopen=no enable_win32_dll=no # Check whether --enable-shared was given. if test "${enable_shared+set}" = set; then : enableval=$enable_shared; p=${PACKAGE-default} case $enableval in yes) enable_shared=yes ;; no) enable_shared=no ;; *) enable_shared=no # Look at the argument we got. We use all the common list separators. lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR," for pkg in $enableval; do IFS="$lt_save_ifs" if test "X$pkg" = "X$p"; then enable_shared=yes fi done IFS="$lt_save_ifs" ;; esac else enable_shared=yes fi # Check whether --enable-static was given. if test "${enable_static+set}" = set; then : enableval=$enable_static; p=${PACKAGE-default} case $enableval in yes) enable_static=yes ;; no) enable_static=no ;; *) enable_static=no # Look at the argument we got. We use all the common list separators. lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR," for pkg in $enableval; do IFS="$lt_save_ifs" if test "X$pkg" = "X$p"; then enable_static=yes fi done IFS="$lt_save_ifs" ;; esac else enable_static=yes fi # Check whether --with-pic was given. if test "${with_pic+set}" = set; then : withval=$with_pic; pic_mode="$withval" else pic_mode=default fi test -z "$pic_mode" && pic_mode=default # Check whether --enable-fast-install was given. if test "${enable_fast_install+set}" = set; then : enableval=$enable_fast_install; p=${PACKAGE-default} case $enableval in yes) enable_fast_install=yes ;; no) enable_fast_install=no ;; *) enable_fast_install=no # Look at the argument we got. We use all the common list separators. lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR," for pkg in $enableval; do IFS="$lt_save_ifs" if test "X$pkg" = "X$p"; then enable_fast_install=yes fi done IFS="$lt_save_ifs" ;; esac else enable_fast_install=yes fi # This can be used to rebuild libtool when needed LIBTOOL_DEPS="$ltmain" # Always use our own libtool. LIBTOOL='$(SHELL) $(top_builddir)/libtool' test -z "$LN_S" && LN_S="ln -s" if test -n "${ZSH_VERSION+set}" ; then setopt NO_GLOB_SUBST fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for objdir" >&5 $as_echo_n "checking for objdir... " >&6; } if test "${lt_cv_objdir+set}" = set; then : $as_echo_n "(cached) " >&6 else rm -f .libs 2>/dev/null mkdir .libs 2>/dev/null if test -d .libs; then lt_cv_objdir=.libs else # MS-DOS does not allow filenames that begin with a dot. lt_cv_objdir=_libs fi rmdir .libs 2>/dev/null fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_objdir" >&5 $as_echo "$lt_cv_objdir" >&6; } objdir=$lt_cv_objdir cat >>confdefs.h <<_ACEOF #define LT_OBJDIR "$lt_cv_objdir/" _ACEOF case $host_os in aix3*) # AIX sometimes has problems with the GCC collect2 program. For some # reason, if we set the COLLECT_NAMES environment variable, the problems # vanish in a puff of smoke. if test "X${COLLECT_NAMES+set}" != Xset; then COLLECT_NAMES= export COLLECT_NAMES fi ;; esac # Sed substitution that helps us do robust quoting. It backslashifies # metacharacters that are still active within double-quoted strings. sed_quote_subst='s/\(["`$\\]\)/\\\1/g' # Same as above, but do not quote variable references. double_quote_subst='s/\(["`\\]\)/\\\1/g' # Sed substitution to delay expansion of an escaped shell variable in a # double_quote_subst'ed string. delay_variable_subst='s/\\\\\\\\\\\$/\\\\\\$/g' # Sed substitution to delay expansion of an escaped single quote. delay_single_quote_subst='s/'\''/'\'\\\\\\\'\''/g' # Sed substitution to avoid accidental globbing in evaled expressions no_glob_subst='s/\*/\\\*/g' # Global variables: ofile=libtool can_build_shared=yes # All known linkers require a `.a' archive for static linking (except MSVC, # which needs '.lib'). libext=a with_gnu_ld="$lt_cv_prog_gnu_ld" old_CC="$CC" old_CFLAGS="$CFLAGS" # Set sane defaults for various variables test -z "$CC" && CC=cc test -z "$LTCC" && LTCC=$CC test -z "$LTCFLAGS" && LTCFLAGS=$CFLAGS test -z "$LD" && LD=ld test -z "$ac_objext" && ac_objext=o for cc_temp in $compiler""; do case $cc_temp in compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; \-*) ;; *) break;; esac done cc_basename=`$ECHO "X$cc_temp" | $Xsed -e 's%.*/%%' -e "s%^$host_alias-%%"` # Only perform the check for file, if the check method requires it test -z "$MAGIC_CMD" && MAGIC_CMD=file case $deplibs_check_method in file_magic*) if test "$file_magic_cmd" = '$MAGIC_CMD'; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ${ac_tool_prefix}file" >&5 $as_echo_n "checking for ${ac_tool_prefix}file... " >&6; } if test "${lt_cv_path_MAGIC_CMD+set}" = set; then : $as_echo_n "(cached) " >&6 else case $MAGIC_CMD in [\\/*] | ?:[\\/]*) lt_cv_path_MAGIC_CMD="$MAGIC_CMD" # Let the user override the test with a path. ;; *) lt_save_MAGIC_CMD="$MAGIC_CMD" lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR ac_dummy="/usr/bin$PATH_SEPARATOR$PATH" for ac_dir in $ac_dummy; do IFS="$lt_save_ifs" test -z "$ac_dir" && ac_dir=. if test -f $ac_dir/${ac_tool_prefix}file; then lt_cv_path_MAGIC_CMD="$ac_dir/${ac_tool_prefix}file" if test -n "$file_magic_test_file"; then case $deplibs_check_method in "file_magic "*) file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"` MAGIC_CMD="$lt_cv_path_MAGIC_CMD" if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null | $EGREP "$file_magic_regex" > /dev/null; then : else cat <<_LT_EOF 1>&2 *** Warning: the command libtool uses to detect shared libraries, *** $file_magic_cmd, produces output that libtool cannot recognize. *** The result is that libtool may fail to recognize shared libraries *** as such. This will affect the creation of libtool libraries that *** depend on shared libraries, but programs linked with such libtool *** libraries will work regardless of this problem. Nevertheless, you *** may want to report the problem to your system manager and/or to *** bug-libtool@gnu.org _LT_EOF fi ;; esac fi break fi done IFS="$lt_save_ifs" MAGIC_CMD="$lt_save_MAGIC_CMD" ;; esac fi MAGIC_CMD="$lt_cv_path_MAGIC_CMD" if test -n "$MAGIC_CMD"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAGIC_CMD" >&5 $as_echo "$MAGIC_CMD" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test -z "$lt_cv_path_MAGIC_CMD"; then if test -n "$ac_tool_prefix"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for file" >&5 $as_echo_n "checking for file... " >&6; } if test "${lt_cv_path_MAGIC_CMD+set}" = set; then : $as_echo_n "(cached) " >&6 else case $MAGIC_CMD in [\\/*] | ?:[\\/]*) lt_cv_path_MAGIC_CMD="$MAGIC_CMD" # Let the user override the test with a path. ;; *) lt_save_MAGIC_CMD="$MAGIC_CMD" lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR ac_dummy="/usr/bin$PATH_SEPARATOR$PATH" for ac_dir in $ac_dummy; do IFS="$lt_save_ifs" test -z "$ac_dir" && ac_dir=. if test -f $ac_dir/file; then lt_cv_path_MAGIC_CMD="$ac_dir/file" if test -n "$file_magic_test_file"; then case $deplibs_check_method in "file_magic "*) file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"` MAGIC_CMD="$lt_cv_path_MAGIC_CMD" if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null | $EGREP "$file_magic_regex" > /dev/null; then : else cat <<_LT_EOF 1>&2 *** Warning: the command libtool uses to detect shared libraries, *** $file_magic_cmd, produces output that libtool cannot recognize. *** The result is that libtool may fail to recognize shared libraries *** as such. This will affect the creation of libtool libraries that *** depend on shared libraries, but programs linked with such libtool *** libraries will work regardless of this problem. Nevertheless, you *** may want to report the problem to your system manager and/or to *** bug-libtool@gnu.org _LT_EOF fi ;; esac fi break fi done IFS="$lt_save_ifs" MAGIC_CMD="$lt_save_MAGIC_CMD" ;; esac fi MAGIC_CMD="$lt_cv_path_MAGIC_CMD" if test -n "$MAGIC_CMD"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAGIC_CMD" >&5 $as_echo "$MAGIC_CMD" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi else MAGIC_CMD=: fi fi fi ;; esac # Use C for the default configuration in the libtool script lt_save_CC="$CC" ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Source file extension for C test sources. ac_ext=c # Object file extension for compiled C test sources. objext=o objext=$objext # Code to be used in simple compile tests lt_simple_compile_test_code="int some_variable = 0;" # Code to be used in simple link tests lt_simple_link_test_code='int main(){return(0);}' # If no C compiler was specified, use CC. LTCC=${LTCC-"$CC"} # If no C compiler flags were specified, use CFLAGS. LTCFLAGS=${LTCFLAGS-"$CFLAGS"} # Allow CC to be a program name with arguments. compiler=$CC # Save the default compiler, since it gets overwritten when the other # tags are being tested, and _LT_TAGVAR(compiler, []) is a NOP. compiler_DEFAULT=$CC # save warnings/boilerplate of simple test code ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" >conftest.$ac_ext eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err _lt_compiler_boilerplate=`cat conftest.err` $RM conftest* ac_outfile=conftest.$ac_objext echo "$lt_simple_link_test_code" >conftest.$ac_ext eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err _lt_linker_boilerplate=`cat conftest.err` $RM -r conftest* ## CAVEAT EMPTOR: ## There is no encapsulation within the following macros, do not change ## the running order or otherwise move them around unless you know exactly ## what you are doing... if test -n "$compiler"; then lt_prog_compiler_no_builtin_flag= if test "$GCC" = yes; then lt_prog_compiler_no_builtin_flag=' -fno-builtin' { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -fno-rtti -fno-exceptions" >&5 $as_echo_n "checking if $compiler supports -fno-rtti -fno-exceptions... " >&6; } if test "${lt_cv_prog_compiler_rtti_exceptions+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_rtti_exceptions=no ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-fno-rtti -fno-exceptions" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. # The option is referenced via a variable to avoid confusing sed. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:6782: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 echo "$as_me:6786: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. $ECHO "X$_lt_compiler_boilerplate" | $Xsed -e '/^$/d' >conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then lt_cv_prog_compiler_rtti_exceptions=yes fi fi $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_rtti_exceptions" >&5 $as_echo "$lt_cv_prog_compiler_rtti_exceptions" >&6; } if test x"$lt_cv_prog_compiler_rtti_exceptions" = xyes; then lt_prog_compiler_no_builtin_flag="$lt_prog_compiler_no_builtin_flag -fno-rtti -fno-exceptions" else : fi fi lt_prog_compiler_wl= lt_prog_compiler_pic= lt_prog_compiler_static= { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $compiler option to produce PIC" >&5 $as_echo_n "checking for $compiler option to produce PIC... " >&6; } if test "$GCC" = yes; then lt_prog_compiler_wl='-Wl,' lt_prog_compiler_static='-static' case $host_os in aix*) # All AIX code is PIC. if test "$host_cpu" = ia64; then # AIX 5 now supports IA64 processor lt_prog_compiler_static='-Bstatic' fi ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support lt_prog_compiler_pic='-fPIC' ;; m68k) # FIXME: we need at least 68020 code to build shared libraries, but # adding the `-m68020' flag to GCC prevents building anything better, # like `-m68040'. lt_prog_compiler_pic='-m68020 -resident32 -malways-restore-a4' ;; esac ;; beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*) # PIC is the default for these OSes. ;; mingw* | cygwin* | pw32* | os2* | cegcc*) # This hack is so that the source file can tell whether it is being # built for inclusion in a dll (and should export symbols for example). # Although the cygwin gcc ignores -fPIC, still need this for old-style # (--disable-auto-import) libraries lt_prog_compiler_pic='-DDLL_EXPORT' ;; darwin* | rhapsody*) # PIC is the default on this platform # Common symbols not allowed in MH_DYLIB files lt_prog_compiler_pic='-fno-common' ;; hpux*) # PIC is the default for 64-bit PA HP-UX, but not for 32-bit # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag # sets the default TLS model and affects inlining. case $host_cpu in hppa*64*) # +Z the default ;; *) lt_prog_compiler_pic='-fPIC' ;; esac ;; interix[3-9]*) # Interix 3.x gcc -fpic/-fPIC options generate broken code. # Instead, we relocate shared libraries at runtime. ;; msdosdjgpp*) # Just because we use GCC doesn't mean we suddenly get shared libraries # on systems that don't support them. lt_prog_compiler_can_build_shared=no enable_shared=no ;; *nto* | *qnx*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. lt_prog_compiler_pic='-fPIC -shared' ;; sysv4*MP*) if test -d /usr/nec; then lt_prog_compiler_pic=-Kconform_pic fi ;; *) lt_prog_compiler_pic='-fPIC' ;; esac else # PORTME Check for flag to pass linker flags through the system compiler. case $host_os in aix*) lt_prog_compiler_wl='-Wl,' if test "$host_cpu" = ia64; then # AIX 5 now supports IA64 processor lt_prog_compiler_static='-Bstatic' else lt_prog_compiler_static='-bnso -bI:/lib/syscalls.exp' fi ;; mingw* | cygwin* | pw32* | os2* | cegcc*) # This hack is so that the source file can tell whether it is being # built for inclusion in a dll (and should export symbols for example). lt_prog_compiler_pic='-DDLL_EXPORT' ;; hpux9* | hpux10* | hpux11*) lt_prog_compiler_wl='-Wl,' # PIC is the default for IA64 HP-UX and 64-bit HP-UX, but # not for PA HP-UX. case $host_cpu in hppa*64*|ia64*) # +Z the default ;; *) lt_prog_compiler_pic='+Z' ;; esac # Is there a better lt_prog_compiler_static that works with the bundled CC? lt_prog_compiler_static='${wl}-a ${wl}archive' ;; irix5* | irix6* | nonstopux*) lt_prog_compiler_wl='-Wl,' # PIC (with -KPIC) is the default. lt_prog_compiler_static='-non_shared' ;; linux* | k*bsd*-gnu) case $cc_basename in # old Intel for x86_64 which still supported -KPIC. ecc*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-static' ;; # icc used to be incompatible with GCC. # ICC 10 doesn't accept -KPIC any more. icc* | ifort*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-fPIC' lt_prog_compiler_static='-static' ;; # Lahey Fortran 8.1. lf95*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='--shared' lt_prog_compiler_static='--static' ;; pgcc* | pgf77* | pgf90* | pgf95*) # Portland Group compilers (*not* the Pentium gcc compiler, # which looks to be a dead project) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-fpic' lt_prog_compiler_static='-Bstatic' ;; ccc*) lt_prog_compiler_wl='-Wl,' # All Alpha code is PIC. lt_prog_compiler_static='-non_shared' ;; xl*) # IBM XL C 8.0/Fortran 10.1 on PPC lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-qpic' lt_prog_compiler_static='-qstaticlink' ;; *) case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C 5.9 lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' lt_prog_compiler_wl='-Wl,' ;; *Sun\ F*) # Sun Fortran 8.3 passes all unrecognized flags to the linker lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' lt_prog_compiler_wl='' ;; esac ;; esac ;; newsos6) lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' ;; *nto* | *qnx*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. lt_prog_compiler_pic='-fPIC -shared' ;; osf3* | osf4* | osf5*) lt_prog_compiler_wl='-Wl,' # All OSF/1 code is PIC. lt_prog_compiler_static='-non_shared' ;; rdos*) lt_prog_compiler_static='-non_shared' ;; solaris*) lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' case $cc_basename in f77* | f90* | f95*) lt_prog_compiler_wl='-Qoption ld ';; *) lt_prog_compiler_wl='-Wl,';; esac ;; sunos4*) lt_prog_compiler_wl='-Qoption ld ' lt_prog_compiler_pic='-PIC' lt_prog_compiler_static='-Bstatic' ;; sysv4 | sysv4.2uw2* | sysv4.3*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' ;; sysv4*MP*) if test -d /usr/nec ;then lt_prog_compiler_pic='-Kconform_pic' lt_prog_compiler_static='-Bstatic' fi ;; sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' ;; unicos*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_can_build_shared=no ;; uts4*) lt_prog_compiler_pic='-pic' lt_prog_compiler_static='-Bstatic' ;; *) lt_prog_compiler_can_build_shared=no ;; esac fi case $host_os in # For platforms which do not support PIC, -DPIC is meaningless: *djgpp*) lt_prog_compiler_pic= ;; *) lt_prog_compiler_pic="$lt_prog_compiler_pic -DPIC" ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_prog_compiler_pic" >&5 $as_echo "$lt_prog_compiler_pic" >&6; } # # Check to make sure the PIC flag actually works. # if test -n "$lt_prog_compiler_pic"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler PIC flag $lt_prog_compiler_pic works" >&5 $as_echo_n "checking if $compiler PIC flag $lt_prog_compiler_pic works... " >&6; } if test "${lt_cv_prog_compiler_pic_works+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_pic_works=no ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="$lt_prog_compiler_pic -DPIC" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. # The option is referenced via a variable to avoid confusing sed. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:7121: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 echo "$as_me:7125: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. $ECHO "X$_lt_compiler_boilerplate" | $Xsed -e '/^$/d' >conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then lt_cv_prog_compiler_pic_works=yes fi fi $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_works" >&5 $as_echo "$lt_cv_prog_compiler_pic_works" >&6; } if test x"$lt_cv_prog_compiler_pic_works" = xyes; then case $lt_prog_compiler_pic in "" | " "*) ;; *) lt_prog_compiler_pic=" $lt_prog_compiler_pic" ;; esac else lt_prog_compiler_pic= lt_prog_compiler_can_build_shared=no fi fi # # Check to make sure the static flag actually works. # wl=$lt_prog_compiler_wl eval lt_tmp_static_flag=\"$lt_prog_compiler_static\" { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler static flag $lt_tmp_static_flag works" >&5 $as_echo_n "checking if $compiler static flag $lt_tmp_static_flag works... " >&6; } if test "${lt_cv_prog_compiler_static_works+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_static_works=no save_LDFLAGS="$LDFLAGS" LDFLAGS="$LDFLAGS $lt_tmp_static_flag" echo "$lt_simple_link_test_code" > conftest.$ac_ext if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then # The linker can only warn and ignore the option if not recognized # So say no if there are warnings if test -s conftest.err; then # Append any errors to the config.log. cat conftest.err 1>&5 $ECHO "X$_lt_linker_boilerplate" | $Xsed -e '/^$/d' > conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if diff conftest.exp conftest.er2 >/dev/null; then lt_cv_prog_compiler_static_works=yes fi else lt_cv_prog_compiler_static_works=yes fi fi $RM -r conftest* LDFLAGS="$save_LDFLAGS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_static_works" >&5 $as_echo "$lt_cv_prog_compiler_static_works" >&6; } if test x"$lt_cv_prog_compiler_static_works" = xyes; then : else lt_prog_compiler_static= fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5 $as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; } if test "${lt_cv_prog_compiler_c_o+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_c_o=no $RM -r conftest 2>/dev/null mkdir conftest cd conftest mkdir out echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-o out/conftest2.$ac_objext" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:7226: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 echo "$as_me:7230: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings $ECHO "X$_lt_compiler_boilerplate" | $Xsed -e '/^$/d' > out/conftest.exp $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then lt_cv_prog_compiler_c_o=yes fi fi chmod u+w . 2>&5 $RM conftest* # SGI C++ compiler will create directory out/ii_files/ for # template instantiation test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files $RM out/* && rmdir out cd .. $RM -r conftest $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5 $as_echo "$lt_cv_prog_compiler_c_o" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5 $as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; } if test "${lt_cv_prog_compiler_c_o+set}" = set; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_c_o=no $RM -r conftest 2>/dev/null mkdir conftest cd conftest mkdir out echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-o out/conftest2.$ac_objext" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:7281: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 echo "$as_me:7285: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings $ECHO "X$_lt_compiler_boilerplate" | $Xsed -e '/^$/d' > out/conftest.exp $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then lt_cv_prog_compiler_c_o=yes fi fi chmod u+w . 2>&5 $RM conftest* # SGI C++ compiler will create directory out/ii_files/ for # template instantiation test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files $RM out/* && rmdir out cd .. $RM -r conftest $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5 $as_echo "$lt_cv_prog_compiler_c_o" >&6; } hard_links="nottested" if test "$lt_cv_prog_compiler_c_o" = no && test "$need_locks" != no; then # do not overwrite the value of need_locks provided by the user { $as_echo "$as_me:${as_lineno-$LINENO}: checking if we can lock with hard links" >&5 $as_echo_n "checking if we can lock with hard links... " >&6; } hard_links=yes $RM conftest* ln conftest.a conftest.b 2>/dev/null && hard_links=no touch conftest.a ln conftest.a conftest.b 2>&5 || hard_links=no ln conftest.a conftest.b 2>/dev/null && hard_links=no { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hard_links" >&5 $as_echo "$hard_links" >&6; } if test "$hard_links" = no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \`$CC' does not support \`-c -o', so \`make -j' may be unsafe" >&5 $as_echo "$as_me: WARNING: \`$CC' does not support \`-c -o', so \`make -j' may be unsafe" >&2;} need_locks=warn fi else need_locks=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $compiler linker ($LD) supports shared libraries" >&5 $as_echo_n "checking whether the $compiler linker ($LD) supports shared libraries... " >&6; } runpath_var= allow_undefined_flag= always_export_symbols=no archive_cmds= archive_expsym_cmds= compiler_needs_object=no enable_shared_with_static_runtimes=no export_dynamic_flag_spec= export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' hardcode_automatic=no hardcode_direct=no hardcode_direct_absolute=no hardcode_libdir_flag_spec= hardcode_libdir_flag_spec_ld= hardcode_libdir_separator= hardcode_minus_L=no hardcode_shlibpath_var=unsupported inherit_rpath=no link_all_deplibs=unknown module_cmds= module_expsym_cmds= old_archive_from_new_cmds= old_archive_from_expsyms_cmds= thread_safe_flag_spec= whole_archive_flag_spec= # include_expsyms should be a list of space-separated symbols to be *always* # included in the symbol list include_expsyms= # exclude_expsyms can be an extended regexp of symbols to exclude # it will be wrapped by ` (' and `)$', so one must not match beginning or # end of line. Example: `a|bc|.*d.*' will exclude the symbols `a' and `bc', # as well as any symbol that contains `d'. exclude_expsyms='_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*' # Although _GLOBAL_OFFSET_TABLE_ is a valid symbol C name, most a.out # platforms (ab)use it in PIC code, but their linkers get confused if # the symbol is explicitly referenced. Since portable code cannot # rely on this symbol name, it's probably fine to never include it in # preloaded symbol tables. # Exclude shared library initialization/finalization symbols. extract_expsyms_cmds= case $host_os in cygwin* | mingw* | pw32* | cegcc*) # FIXME: the MSVC++ port hasn't been tested in a loooong time # When not using gcc, we currently assume that we are using # Microsoft Visual C++. if test "$GCC" != yes; then with_gnu_ld=no fi ;; interix*) # we just hope/assume this is gcc and not c89 (= MSVC++) with_gnu_ld=yes ;; openbsd*) with_gnu_ld=no ;; linux* | k*bsd*-gnu) link_all_deplibs=no ;; esac ld_shlibs=yes if test "$with_gnu_ld" = yes; then # If archive_cmds runs LD, not CC, wlarc should be empty wlarc='${wl}' # Set some defaults for GNU ld with shared library support. These # are reset later if shared libraries are not supported. Putting them # here allows them to be overridden if necessary. runpath_var=LD_RUN_PATH hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' export_dynamic_flag_spec='${wl}--export-dynamic' # ancient GNU ld didn't support --whole-archive et. al. if $LD --help 2>&1 | $GREP 'no-whole-archive' > /dev/null; then whole_archive_flag_spec="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive' else whole_archive_flag_spec= fi supports_anon_versioning=no case `$LD -v 2>&1` in *\ [01].* | *\ 2.[0-9].* | *\ 2.10.*) ;; # catch versions < 2.11 *\ 2.11.93.0.2\ *) supports_anon_versioning=yes ;; # RH7.3 ... *\ 2.11.92.0.12\ *) supports_anon_versioning=yes ;; # Mandrake 8.2 ... *\ 2.11.*) ;; # other 2.11 versions *) supports_anon_versioning=yes ;; esac # See if GNU ld supports shared libraries. case $host_os in aix[3-9]*) # On AIX/PPC, the GNU linker is very broken if test "$host_cpu" != ia64; then ld_shlibs=no cat <<_LT_EOF 1>&2 *** Warning: the GNU linker, at least up to release 2.9.1, is reported *** to be unable to reliably create shared libraries on AIX. *** Therefore, libtool is disabling shared libraries support. If you *** really care for shared libraries, you may want to modify your PATH *** so that a non-GNU linker is found, and then restart. _LT_EOF fi ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' archive_expsym_cmds='' ;; m68k) archive_cmds='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' hardcode_libdir_flag_spec='-L$libdir' hardcode_minus_L=yes ;; esac ;; beos*) if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then allow_undefined_flag=unsupported # Joseph Beckenbach says some releases of gcc # support --undefined. This deserves some investigation. FIXME archive_cmds='$CC -nostart $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' else ld_shlibs=no fi ;; cygwin* | mingw* | pw32* | cegcc*) # _LT_TAGVAR(hardcode_libdir_flag_spec, ) is actually meaningless, # as there is no search path for DLLs. hardcode_libdir_flag_spec='-L$libdir' allow_undefined_flag=unsupported always_export_symbols=no enable_shared_with_static_runtimes=yes export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1 DATA/'\'' | $SED -e '\''/^[AITW][ ]/s/.*[ ]//'\'' | sort | uniq > $export_symbols' if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' # If the export-symbols file already is a .def file (1st line # is EXPORTS), use it as is; otherwise, prepend... archive_expsym_cmds='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then cp $export_symbols $output_objdir/$soname.def; else echo EXPORTS > $output_objdir/$soname.def; cat $export_symbols >> $output_objdir/$soname.def; fi~ $CC -shared $output_objdir/$soname.def $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' else ld_shlibs=no fi ;; interix[3-9]*) hardcode_direct=no hardcode_shlibpath_var=no hardcode_libdir_flag_spec='${wl}-rpath,$libdir' export_dynamic_flag_spec='${wl}-E' # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc. # Instead, shared libraries are loaded at an image base (0x10000000 by # default) and relocated if they conflict, which is a slow very memory # consuming and fragmenting process. To avoid this, we pick a random, # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link # time. Moving up from 0x10000000 also allows more sbrk(2) space. archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' archive_expsym_cmds='sed "s,^,_," $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--retain-symbols-file,$output_objdir/$soname.expsym ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' ;; gnu* | linux* | tpf* | k*bsd*-gnu) tmp_diet=no if test "$host_os" = linux-dietlibc; then case $cc_basename in diet\ *) tmp_diet=yes;; # linux-dietlibc with static linking (!diet-dyn) esac fi if $LD --help 2>&1 | $EGREP ': supported targets:.* elf' > /dev/null \ && test "$tmp_diet" = no then tmp_addflag= tmp_sharedflag='-shared' case $cc_basename,$host_cpu in pgcc*) # Portland Group C compiler whole_archive_flag_spec='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; $ECHO \"$new_convenience\"` ${wl}--no-whole-archive' tmp_addflag=' $pic_flag' ;; pgf77* | pgf90* | pgf95*) # Portland Group f77 and f90 compilers whole_archive_flag_spec='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; $ECHO \"$new_convenience\"` ${wl}--no-whole-archive' tmp_addflag=' $pic_flag -Mnomain' ;; ecc*,ia64* | icc*,ia64*) # Intel C compiler on ia64 tmp_addflag=' -i_dynamic' ;; efc*,ia64* | ifort*,ia64*) # Intel Fortran compiler on ia64 tmp_addflag=' -i_dynamic -nofor_main' ;; ifc* | ifort*) # Intel Fortran compiler tmp_addflag=' -nofor_main' ;; lf95*) # Lahey Fortran 8.1 whole_archive_flag_spec= tmp_sharedflag='--shared' ;; xl[cC]*) # IBM XL C 8.0 on PPC (deal with xlf below) tmp_sharedflag='-qmkshrobj' tmp_addflag= ;; esac case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C 5.9 whole_archive_flag_spec='${wl}--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; $ECHO \"$new_convenience\"` ${wl}--no-whole-archive' compiler_needs_object=yes tmp_sharedflag='-G' ;; *Sun\ F*) # Sun Fortran 8.3 tmp_sharedflag='-G' ;; esac archive_cmds='$CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' if test "x$supports_anon_versioning" = xyes; then archive_expsym_cmds='echo "{ global:" > $output_objdir/$libname.ver~ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ echo "local: *; };" >> $output_objdir/$libname.ver~ $CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-version-script ${wl}$output_objdir/$libname.ver -o $lib' fi case $cc_basename in xlf*) # IBM XL Fortran 10.1 on PPC cannot create shared libs itself whole_archive_flag_spec='--whole-archive$convenience --no-whole-archive' hardcode_libdir_flag_spec= hardcode_libdir_flag_spec_ld='-rpath $libdir' archive_cmds='$LD -shared $libobjs $deplibs $compiler_flags -soname $soname -o $lib' if test "x$supports_anon_versioning" = xyes; then archive_expsym_cmds='echo "{ global:" > $output_objdir/$libname.ver~ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ echo "local: *; };" >> $output_objdir/$libname.ver~ $LD -shared $libobjs $deplibs $compiler_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib' fi ;; esac else ld_shlibs=no fi ;; netbsd* | netbsdelf*-gnu) if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then archive_cmds='$LD -Bshareable $libobjs $deplibs $linker_flags -o $lib' wlarc= else archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' fi ;; solaris*) if $LD -v 2>&1 | $GREP 'BFD 2\.8' > /dev/null; then ld_shlibs=no cat <<_LT_EOF 1>&2 *** Warning: The releases 2.8.* of the GNU linker cannot reliably *** create shared libraries on Solaris systems. Therefore, libtool *** is disabling shared libraries support. We urge you to upgrade GNU *** binutils to release 2.9.1 or newer. Another option is to modify *** your PATH or compiler configuration so that the native linker is *** used, and then restart. _LT_EOF elif $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' else ld_shlibs=no fi ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*) case `$LD -v 2>&1` in *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*) ld_shlibs=no cat <<_LT_EOF 1>&2 *** Warning: Releases of the GNU linker prior to 2.16.91.0.3 can not *** reliably create shared libraries on SCO systems. Therefore, libtool *** is disabling shared libraries support. We urge you to upgrade GNU *** binutils to release 2.16.91.0.3 or newer. Another option is to modify *** your PATH or compiler configuration so that the native linker is *** used, and then restart. _LT_EOF ;; *) # For security reasons, it is highly recommended that you always # use absolute paths for naming shared libraries, and exclude the # DT_RUNPATH tag from executables and libraries. But doing so # requires that you compile everything twice, which is a pain. if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' else ld_shlibs=no fi ;; esac ;; sunos4*) archive_cmds='$LD -assert pure-text -Bshareable -o $lib $libobjs $deplibs $linker_flags' wlarc= hardcode_direct=yes hardcode_shlibpath_var=no ;; *) if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' else ld_shlibs=no fi ;; esac if test "$ld_shlibs" = no; then runpath_var= hardcode_libdir_flag_spec= export_dynamic_flag_spec= whole_archive_flag_spec= fi else # PORTME fill in a description of your system's linker (not GNU ld) case $host_os in aix3*) allow_undefined_flag=unsupported always_export_symbols=yes archive_expsym_cmds='$LD -o $output_objdir/$soname $libobjs $deplibs $linker_flags -bE:$export_symbols -T512 -H512 -bM:SRE~$AR $AR_FLAGS $lib $output_objdir/$soname' # Note: this linker hardcodes the directories in LIBPATH if there # are no directories specified by -L. hardcode_minus_L=yes if test "$GCC" = yes && test -z "$lt_prog_compiler_static"; then # Neither direct hardcoding nor static linking is supported with a # broken collect2. hardcode_direct=unsupported fi ;; aix[4-9]*) if test "$host_cpu" = ia64; then # On IA64, the linker does run time linking by default, so we don't # have to do anything special. aix_use_runtimelinking=no exp_sym_flag='-Bexport' no_entry_flag="" else # If we're using GNU nm, then we don't want the "-C" option. # -C means demangle to AIX nm, but means don't demangle with GNU nm if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then export_symbols_cmds='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && (substr(\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols' else export_symbols_cmds='$NM -BCpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && (substr(\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols' fi aix_use_runtimelinking=no # Test if we are trying to use run time linking or normal # AIX style linking. If -brtl is somewhere in LDFLAGS, we # need to do runtime linking. case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*) for ld_flag in $LDFLAGS; do if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then aix_use_runtimelinking=yes break fi done ;; esac exp_sym_flag='-bexport' no_entry_flag='-bnoentry' fi # When large executables or shared objects are built, AIX ld can # have problems creating the table of contents. If linking a library # or program results in "error TOC overflow" add -mminimal-toc to # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS. archive_cmds='' hardcode_direct=yes hardcode_direct_absolute=yes hardcode_libdir_separator=':' link_all_deplibs=yes file_list_spec='${wl}-f,' if test "$GCC" = yes; then case $host_os in aix4.[012]|aix4.[012].*) # We only want to do this on AIX 4.2 and lower, the check # below for broken collect2 doesn't work under 4.3+ collect2name=`${CC} -print-prog-name=collect2` if test -f "$collect2name" && strings "$collect2name" | $GREP resolve_lib_name >/dev/null then # We have reworked collect2 : else # We have old collect2 hardcode_direct=unsupported # It fails to find uninstalled libraries when the uninstalled # path is not listed in the libpath. Setting hardcode_minus_L # to unsupported forces relinking hardcode_minus_L=yes hardcode_libdir_flag_spec='-L$libdir' hardcode_libdir_separator= fi ;; esac shared_flag='-shared' if test "$aix_use_runtimelinking" = yes; then shared_flag="$shared_flag "'${wl}-G' fi link_all_deplibs=no else # not using gcc if test "$host_cpu" = ia64; then # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release # chokes on -Wl,-G. The following line is correct: shared_flag='-G' else if test "$aix_use_runtimelinking" = yes; then shared_flag='${wl}-G' else shared_flag='${wl}-bM:SRE' fi fi fi export_dynamic_flag_spec='${wl}-bexpall' # It seems that -bexpall does not export symbols beginning with # underscore (_), so it is better to generate a list of symbols to export. always_export_symbols=yes if test "$aix_use_runtimelinking" = yes; then # Warning - without using the other runtime loading flags (-brtl), # -berok will link without error, but may produce a broken library. allow_undefined_flag='-berok' # Determine the default libpath from the value encoded in an # empty executable. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : lt_aix_libpath_sed=' /Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/ p } }' aix_libpath=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` # Check for a 64-bit object if we didn't find anything. if test -z "$aix_libpath"; then aix_libpath=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` fi fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext if test -z "$aix_libpath"; then aix_libpath="/usr/lib:/lib"; fi hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath" archive_expsym_cmds='$CC -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags `if test "x${allow_undefined_flag}" != "x"; then $ECHO "X${wl}${allow_undefined_flag}" | $Xsed; else :; fi` '"\${wl}$exp_sym_flag:\$export_symbols $shared_flag" else if test "$host_cpu" = ia64; then hardcode_libdir_flag_spec='${wl}-R $libdir:/usr/lib:/lib' allow_undefined_flag="-z nodefs" archive_expsym_cmds="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags ${wl}${allow_undefined_flag} '"\${wl}$exp_sym_flag:\$export_symbols" else # Determine the default libpath from the value encoded in an # empty executable. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : lt_aix_libpath_sed=' /Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/ p } }' aix_libpath=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` # Check for a 64-bit object if we didn't find anything. if test -z "$aix_libpath"; then aix_libpath=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` fi fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext if test -z "$aix_libpath"; then aix_libpath="/usr/lib:/lib"; fi hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath" # Warning - without using the other run time loading flags, # -berok will link without error, but may produce a broken library. no_undefined_flag=' ${wl}-bernotok' allow_undefined_flag=' ${wl}-berok' # Exported symbols can be pulled into shared objects from archives whole_archive_flag_spec='$convenience' archive_cmds_need_lc=yes # This is similar to how AIX traditionally builds its shared libraries. archive_expsym_cmds="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs ${wl}-bnoentry $compiler_flags ${wl}-bE:$export_symbols${allow_undefined_flag}~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$soname' fi fi ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' archive_expsym_cmds='' ;; m68k) archive_cmds='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' hardcode_libdir_flag_spec='-L$libdir' hardcode_minus_L=yes ;; esac ;; bsdi[45]*) export_dynamic_flag_spec=-rdynamic ;; cygwin* | mingw* | pw32* | cegcc*) # When not using gcc, we currently assume that we are using # Microsoft Visual C++. # hardcode_libdir_flag_spec is actually meaningless, as there is # no search path for DLLs. hardcode_libdir_flag_spec=' ' allow_undefined_flag=unsupported # Tell ltmain to make .lib files, not .a files. libext=lib # Tell ltmain to make .dll files, not .so files. shrext_cmds=".dll" # FIXME: Setting linknames here is a bad hack. archive_cmds='$CC -o $lib $libobjs $compiler_flags `$ECHO "X$deplibs" | $Xsed -e '\''s/ -lc$//'\''` -link -dll~linknames=' # The linker will automatically build a .lib file if we build a DLL. old_archive_from_new_cmds='true' # FIXME: Should let the user specify the lib program. old_archive_cmds='lib -OUT:$oldlib$oldobjs$old_deplibs' fix_srcfile_path='`cygpath -w "$srcfile"`' enable_shared_with_static_runtimes=yes ;; darwin* | rhapsody*) archive_cmds_need_lc=no hardcode_direct=no hardcode_automatic=yes hardcode_shlibpath_var=unsupported whole_archive_flag_spec='' link_all_deplibs=yes allow_undefined_flag="$_lt_dar_allow_undefined" case $cc_basename in ifort*) _lt_dar_can_shared=yes ;; *) _lt_dar_can_shared=$GCC ;; esac if test "$_lt_dar_can_shared" = "yes"; then output_verbose_link_cmd=echo archive_cmds="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod${_lt_dsymutil}" module_cmds="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dsymutil}" archive_expsym_cmds="sed 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring ${_lt_dar_single_mod}${_lt_dar_export_syms}${_lt_dsymutil}" module_expsym_cmds="sed -e 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dar_export_syms}${_lt_dsymutil}" else ld_shlibs=no fi ;; dgux*) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_libdir_flag_spec='-L$libdir' hardcode_shlibpath_var=no ;; freebsd1*) ld_shlibs=no ;; # FreeBSD 2.2.[012] allows us to include c++rt0.o to get C++ constructor # support. Future versions do this automatically, but an explicit c++rt0.o # does not break anything, and helps significantly (at the cost of a little # extra space). freebsd2.2*) archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags /usr/lib/c++rt0.o' hardcode_libdir_flag_spec='-R$libdir' hardcode_direct=yes hardcode_shlibpath_var=no ;; # Unfortunately, older versions of FreeBSD 2 do not have this feature. freebsd2*) archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' hardcode_direct=yes hardcode_minus_L=yes hardcode_shlibpath_var=no ;; # FreeBSD 3 and greater uses gcc -shared to do shared libraries. freebsd* | dragonfly*) archive_cmds='$CC -shared -o $lib $libobjs $deplibs $compiler_flags' hardcode_libdir_flag_spec='-R$libdir' hardcode_direct=yes hardcode_shlibpath_var=no ;; hpux9*) if test "$GCC" = yes; then archive_cmds='$RM $output_objdir/$soname~$CC -shared -fPIC ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib' else archive_cmds='$RM $output_objdir/$soname~$LD -b +b $install_libdir -o $output_objdir/$soname $libobjs $deplibs $linker_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib' fi hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir' hardcode_libdir_separator=: hardcode_direct=yes # hardcode_minus_L: Not really in the search PATH, # but as the default location of the library. hardcode_minus_L=yes export_dynamic_flag_spec='${wl}-E' ;; hpux10*) if test "$GCC" = yes -a "$with_gnu_ld" = no; then archive_cmds='$CC -shared -fPIC ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags' else archive_cmds='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags' fi if test "$with_gnu_ld" = no; then hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir' hardcode_libdir_flag_spec_ld='+b $libdir' hardcode_libdir_separator=: hardcode_direct=yes hardcode_direct_absolute=yes export_dynamic_flag_spec='${wl}-E' # hardcode_minus_L: Not really in the search PATH, # but as the default location of the library. hardcode_minus_L=yes fi ;; hpux11*) if test "$GCC" = yes -a "$with_gnu_ld" = no; then case $host_cpu in hppa*64*) archive_cmds='$CC -shared ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags' ;; ia64*) archive_cmds='$CC -shared -fPIC ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' ;; *) archive_cmds='$CC -shared -fPIC ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags' ;; esac else case $host_cpu in hppa*64*) archive_cmds='$CC -b ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags' ;; ia64*) archive_cmds='$CC -b ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' ;; *) archive_cmds='$CC -b ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags' ;; esac fi if test "$with_gnu_ld" = no; then hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir' hardcode_libdir_separator=: case $host_cpu in hppa*64*|ia64*) hardcode_direct=no hardcode_shlibpath_var=no ;; *) hardcode_direct=yes hardcode_direct_absolute=yes export_dynamic_flag_spec='${wl}-E' # hardcode_minus_L: Not really in the search PATH, # but as the default location of the library. hardcode_minus_L=yes ;; esac fi ;; irix5* | irix6* | nonstopux*) if test "$GCC" = yes; then archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib' # Try to use the -exported_symbol ld option, if it does not # work, assume that -exports_file does not work either and # implicitly export all symbols. save_LDFLAGS="$LDFLAGS" LDFLAGS="$LDFLAGS -shared ${wl}-exported_symbol ${wl}foo ${wl}-update_registry ${wl}/dev/null" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int foo(void) {} _ACEOF if ac_fn_c_try_link "$LINENO"; then : archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations ${wl}-exports_file ${wl}$export_symbols -o $lib' fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS="$save_LDFLAGS" else archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib' archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -exports_file $export_symbols -o $lib' fi archive_cmds_need_lc='no' hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' hardcode_libdir_separator=: inherit_rpath=yes link_all_deplibs=yes ;; netbsd* | netbsdelf*-gnu) if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' # a.out else archive_cmds='$LD -shared -o $lib $libobjs $deplibs $linker_flags' # ELF fi hardcode_libdir_flag_spec='-R$libdir' hardcode_direct=yes hardcode_shlibpath_var=no ;; newsos6) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_direct=yes hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' hardcode_libdir_separator=: hardcode_shlibpath_var=no ;; *nto* | *qnx*) ;; openbsd*) if test -f /usr/libexec/ld.so; then hardcode_direct=yes hardcode_shlibpath_var=no hardcode_direct_absolute=yes if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags ${wl}-retain-symbols-file,$export_symbols' hardcode_libdir_flag_spec='${wl}-rpath,$libdir' export_dynamic_flag_spec='${wl}-E' else case $host_os in openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*) archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' hardcode_libdir_flag_spec='-R$libdir' ;; *) archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' hardcode_libdir_flag_spec='${wl}-rpath,$libdir' ;; esac fi else ld_shlibs=no fi ;; os2*) hardcode_libdir_flag_spec='-L$libdir' hardcode_minus_L=yes allow_undefined_flag=unsupported archive_cmds='$ECHO "LIBRARY $libname INITINSTANCE" > $output_objdir/$libname.def~$ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~$ECHO DATA >> $output_objdir/$libname.def~$ECHO " SINGLE NONSHARED" >> $output_objdir/$libname.def~$ECHO EXPORTS >> $output_objdir/$libname.def~emxexp $libobjs >> $output_objdir/$libname.def~$CC -Zdll -Zcrtdll -o $lib $libobjs $deplibs $compiler_flags $output_objdir/$libname.def' old_archive_from_new_cmds='emximp -o $output_objdir/$libname.a $output_objdir/$libname.def' ;; osf3*) if test "$GCC" = yes; then allow_undefined_flag=' ${wl}-expect_unresolved ${wl}\*' archive_cmds='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib' else allow_undefined_flag=' -expect_unresolved \*' archive_cmds='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib' fi archive_cmds_need_lc='no' hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' hardcode_libdir_separator=: ;; osf4* | osf5*) # as osf3* with the addition of -msym flag if test "$GCC" = yes; then allow_undefined_flag=' ${wl}-expect_unresolved ${wl}\*' archive_cmds='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags ${wl}-msym ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib' hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' else allow_undefined_flag=' -expect_unresolved \*' archive_cmds='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -msym -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib' archive_expsym_cmds='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done; printf "%s\\n" "-hidden">> $lib.exp~ $CC -shared${allow_undefined_flag} ${wl}-input ${wl}$lib.exp $compiler_flags $libobjs $deplibs -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib~$RM $lib.exp' # Both c and cxx compiler support -rpath directly hardcode_libdir_flag_spec='-rpath $libdir' fi archive_cmds_need_lc='no' hardcode_libdir_separator=: ;; solaris*) no_undefined_flag=' -z defs' if test "$GCC" = yes; then wlarc='${wl}' archive_cmds='$CC -shared ${wl}-z ${wl}text ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -shared ${wl}-z ${wl}text ${wl}-M ${wl}$lib.exp ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' else case `$CC -V 2>&1` in *"Compilers 5.0"*) wlarc='' archive_cmds='$LD -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $linker_flags' archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $LD -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $linker_flags~$RM $lib.exp' ;; *) wlarc='${wl}' archive_cmds='$CC -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' ;; esac fi hardcode_libdir_flag_spec='-R$libdir' hardcode_shlibpath_var=no case $host_os in solaris2.[0-5] | solaris2.[0-5].*) ;; *) # The compiler driver will combine and reorder linker options, # but understands `-z linker_flag'. GCC discards it without `$wl', # but is careful enough not to reorder. # Supported since Solaris 2.6 (maybe 2.5.1?) if test "$GCC" = yes; then whole_archive_flag_spec='${wl}-z ${wl}allextract$convenience ${wl}-z ${wl}defaultextract' else whole_archive_flag_spec='-z allextract$convenience -z defaultextract' fi ;; esac link_all_deplibs=yes ;; sunos4*) if test "x$host_vendor" = xsequent; then # Use $CC to link under sequent, because it throws in some extra .o # files that make .init and .fini sections work. archive_cmds='$CC -G ${wl}-h $soname -o $lib $libobjs $deplibs $compiler_flags' else archive_cmds='$LD -assert pure-text -Bstatic -o $lib $libobjs $deplibs $linker_flags' fi hardcode_libdir_flag_spec='-L$libdir' hardcode_direct=yes hardcode_minus_L=yes hardcode_shlibpath_var=no ;; sysv4) case $host_vendor in sni) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_direct=yes # is this really true??? ;; siemens) ## LD is ld it makes a PLAMLIB ## CC just makes a GrossModule. archive_cmds='$LD -G -o $lib $libobjs $deplibs $linker_flags' reload_cmds='$CC -r -o $output$reload_objs' hardcode_direct=no ;; motorola) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_direct=no #Motorola manual says yes, but my tests say they lie ;; esac runpath_var='LD_RUN_PATH' hardcode_shlibpath_var=no ;; sysv4.3*) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_shlibpath_var=no export_dynamic_flag_spec='-Bexport' ;; sysv4*MP*) if test -d /usr/nec; then archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_shlibpath_var=no runpath_var=LD_RUN_PATH hardcode_runpath_var=yes ld_shlibs=yes fi ;; sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*) no_undefined_flag='${wl}-z,text' archive_cmds_need_lc=no hardcode_shlibpath_var=no runpath_var='LD_RUN_PATH' if test "$GCC" = yes; then archive_cmds='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' else archive_cmds='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' fi ;; sysv5* | sco3.2v5* | sco5v6*) # Note: We can NOT use -z defs as we might desire, because we do not # link with -lc, and that would cause any symbols used from libc to # always be unresolved, which means just about no library would # ever link correctly. If we're not using GNU ld we use -z text # though, which does catch some bad symbols but isn't as heavy-handed # as -z defs. no_undefined_flag='${wl}-z,text' allow_undefined_flag='${wl}-z,nodefs' archive_cmds_need_lc=no hardcode_shlibpath_var=no hardcode_libdir_flag_spec='${wl}-R,$libdir' hardcode_libdir_separator=':' link_all_deplibs=yes export_dynamic_flag_spec='${wl}-Bexport' runpath_var='LD_RUN_PATH' if test "$GCC" = yes; then archive_cmds='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' else archive_cmds='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' fi ;; uts4*) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_libdir_flag_spec='-L$libdir' hardcode_shlibpath_var=no ;; *) ld_shlibs=no ;; esac if test x$host_vendor = xsni; then case $host in sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*) export_dynamic_flag_spec='${wl}-Blargedynsym' ;; esac fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs" >&5 $as_echo "$ld_shlibs" >&6; } test "$ld_shlibs" = no && can_build_shared=no with_gnu_ld=$with_gnu_ld # # Do we need to explicitly link libc? # case "x$archive_cmds_need_lc" in x|xyes) # Assume -lc should be added archive_cmds_need_lc=yes if test "$enable_shared" = yes && test "$GCC" = yes; then case $archive_cmds in *'~'*) # FIXME: we may have to deal with multi-command sequences. ;; '$CC '*) # Test whether the compiler implicitly links with -lc since on some # systems, -lgcc has to come before -lc. If gcc already passes -lc # to ld, don't add -lc before -lgcc. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether -lc should be explicitly linked in" >&5 $as_echo_n "checking whether -lc should be explicitly linked in... " >&6; } $RM conftest* echo "$lt_simple_compile_test_code" > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } 2>conftest.err; then soname=conftest lib=conftest libobjs=conftest.$ac_objext deplibs= wl=$lt_prog_compiler_wl pic_flag=$lt_prog_compiler_pic compiler_flags=-v linker_flags=-v verstring= output_objdir=. libname=conftest lt_save_allow_undefined_flag=$allow_undefined_flag allow_undefined_flag= if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$archive_cmds 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1\""; } >&5 (eval $archive_cmds 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then archive_cmds_need_lc=no else archive_cmds_need_lc=yes fi allow_undefined_flag=$lt_save_allow_undefined_flag else cat conftest.err 1>&5 fi $RM conftest* { $as_echo "$as_me:${as_lineno-$LINENO}: result: $archive_cmds_need_lc" >&5 $as_echo "$archive_cmds_need_lc" >&6; } ;; esac fi ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking dynamic linker characteristics" >&5 $as_echo_n "checking dynamic linker characteristics... " >&6; } if test "$GCC" = yes; then case $host_os in darwin*) lt_awk_arg="/^libraries:/,/LR/" ;; *) lt_awk_arg="/^libraries:/" ;; esac lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e "s,=/,/,g"` if $ECHO "$lt_search_path_spec" | $GREP ';' >/dev/null ; then # if the path contains ";" then we assume it to be the separator # otherwise default to the standard path separator (i.e. ":") - it is # assumed that no part of a normal pathname contains ";" but that should # okay in the real world where ";" in dirpaths is itself problematic. lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED -e 's/;/ /g'` else lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` fi # Ok, now we have the path, separated by spaces, we can step through it # and add multilib dir if necessary. lt_tmp_lt_search_path_spec= lt_multi_os_dir=`$CC $CPPFLAGS $CFLAGS $LDFLAGS -print-multi-os-directory 2>/dev/null` for lt_sys_path in $lt_search_path_spec; do if test -d "$lt_sys_path/$lt_multi_os_dir"; then lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path/$lt_multi_os_dir" else test -d "$lt_sys_path" && \ lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path" fi done lt_search_path_spec=`$ECHO $lt_tmp_lt_search_path_spec | awk ' BEGIN {RS=" "; FS="/|\n";} { lt_foo=""; lt_count=0; for (lt_i = NF; lt_i > 0; lt_i--) { if ($lt_i != "" && $lt_i != ".") { if ($lt_i == "..") { lt_count++; } else { if (lt_count == 0) { lt_foo="/" $lt_i lt_foo; } else { lt_count--; } } } } if (lt_foo != "") { lt_freq[lt_foo]++; } if (lt_freq[lt_foo] == 1) { print lt_foo; } }'` sys_lib_search_path_spec=`$ECHO $lt_search_path_spec` else sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" fi library_names_spec= libname_spec='lib$name' soname_spec= shrext_cmds=".so" postinstall_cmds= postuninstall_cmds= finish_cmds= finish_eval= shlibpath_var= shlibpath_overrides_runpath=unknown version_type=none dynamic_linker="$host_os ld.so" sys_lib_dlsearch_path_spec="/lib /usr/lib" need_lib_prefix=unknown hardcode_into_libs=no # when you set need_version to no, make sure it does not cause -set_version # flags to be left without arguments need_version=unknown case $host_os in aix3*) version_type=linux library_names_spec='${libname}${release}${shared_ext}$versuffix $libname.a' shlibpath_var=LIBPATH # AIX 3 has no versioning support, so we append a major version to the name. soname_spec='${libname}${release}${shared_ext}$major' ;; aix[4-9]*) version_type=linux need_lib_prefix=no need_version=no hardcode_into_libs=yes if test "$host_cpu" = ia64; then # AIX 5 supports IA64 library_names_spec='${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext}$versuffix $libname${shared_ext}' shlibpath_var=LD_LIBRARY_PATH else # With GCC up to 2.95.x, collect2 would create an import file # for dependence libraries. The import file would start with # the line `#! .'. This would cause the generated library to # depend on `.', always an invalid library. This was fixed in # development snapshots of GCC prior to 3.0. case $host_os in aix4 | aix4.[01] | aix4.[01].*) if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)' echo ' yes ' echo '#endif'; } | ${CC} -E - | $GREP yes > /dev/null; then : else can_build_shared=no fi ;; esac # AIX (on Power*) has no versioning support, so currently we can not hardcode correct # soname into executable. Probably we can add versioning support to # collect2, so additional links can be useful in future. if test "$aix_use_runtimelinking" = yes; then # If using run time linking (on AIX 4.2 or later) use lib.so # instead of lib.a to let people know that these are not # typical AIX shared libraries. library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' else # We preserve .a as extension for shared libraries through AIX4.2 # and later when we are not doing run time linking. library_names_spec='${libname}${release}.a $libname.a' soname_spec='${libname}${release}${shared_ext}$major' fi shlibpath_var=LIBPATH fi ;; amigaos*) case $host_cpu in powerpc) # Since July 2007 AmigaOS4 officially supports .so libraries. # When compiling the executable, add -use-dynld -Lsobjs: to the compileline. library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' ;; m68k) library_names_spec='$libname.ixlibrary $libname.a' # Create ${libname}_ixlibrary.a entries in /sys/libs. finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`$ECHO "X$lib" | $Xsed -e '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; test $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done' ;; esac ;; beos*) library_names_spec='${libname}${shared_ext}' dynamic_linker="$host_os ld.so" shlibpath_var=LIBRARY_PATH ;; bsdi[45]*) version_type=linux need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir' shlibpath_var=LD_LIBRARY_PATH sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib" sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib" # the default ld.so.conf also contains /usr/contrib/lib and # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow # libtool to hard-code these into programs ;; cygwin* | mingw* | pw32* | cegcc*) version_type=windows shrext_cmds=".dll" need_version=no need_lib_prefix=no case $GCC,$host_os in yes,cygwin* | yes,mingw* | yes,pw32* | yes,cegcc*) library_names_spec='$libname.dll.a' # DLL is installed to $(libdir)/../bin by postinstall_cmds postinstall_cmds='base_file=`basename \${file}`~ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~ dldir=$destdir/`dirname \$dlpath`~ test -d \$dldir || mkdir -p \$dldir~ $install_prog $dir/$dlname \$dldir/$dlname~ chmod a+x \$dldir/$dlname~ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; fi' postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ dlpath=$dir/\$dldll~ $RM \$dlpath' shlibpath_overrides_runpath=yes case $host_os in cygwin*) # Cygwin DLLs use 'cyg' prefix rather than 'lib' soname_spec='`echo ${libname} | sed -e 's/^lib/cyg/'``echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}' sys_lib_search_path_spec="/usr/lib /lib/w32api /lib /usr/local/lib" ;; mingw* | cegcc*) # MinGW DLLs use traditional 'lib' prefix soname_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}' sys_lib_search_path_spec=`$CC -print-search-dirs | $GREP "^libraries:" | $SED -e "s/^libraries://" -e "s,=/,/,g"` if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then # It is most probably a Windows format PATH printed by # mingw gcc, but we are running on Cygwin. Gcc prints its search # path with ; separators, and with drive letters. We can handle the # drive letters (cygwin fileutils understands them), so leave them, # especially as we might pass files found there to a mingw objdump, # which wouldn't understand a cygwinified path. Ahh. sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'` else sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` fi ;; pw32*) # pw32 DLLs use 'pw' prefix rather than 'lib' library_names_spec='`echo ${libname} | sed -e 's/^lib/pw/'``echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}' ;; esac ;; *) library_names_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext} $libname.lib' ;; esac dynamic_linker='Win32 ld.exe' # FIXME: first we should search . and the directory the executable is in shlibpath_var=PATH ;; darwin* | rhapsody*) dynamic_linker="$host_os dyld" version_type=darwin need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${major}$shared_ext ${libname}$shared_ext' soname_spec='${libname}${release}${major}$shared_ext' shlibpath_overrides_runpath=yes shlibpath_var=DYLD_LIBRARY_PATH shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`' sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/local/lib" sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib' ;; dgux*) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname$shared_ext' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH ;; freebsd1*) dynamic_linker=no ;; freebsd* | dragonfly*) # DragonFly does not have aout. When/if they implement a new # versioning mechanism, adjust this. if test -x /usr/bin/objformat; then objformat=`/usr/bin/objformat` else case $host_os in freebsd[123]*) objformat=aout ;; *) objformat=elf ;; esac fi version_type=freebsd-$objformat case $version_type in freebsd-elf*) library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}' need_version=no need_lib_prefix=no ;; freebsd-*) library_names_spec='${libname}${release}${shared_ext}$versuffix $libname${shared_ext}$versuffix' need_version=yes ;; esac shlibpath_var=LD_LIBRARY_PATH case $host_os in freebsd2*) shlibpath_overrides_runpath=yes ;; freebsd3.[01]* | freebsdelf3.[01]*) shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; freebsd3.[2-9]* | freebsdelf3.[2-9]* | \ freebsd4.[0-5] | freebsdelf4.[0-5] | freebsd4.1.1 | freebsdelf4.1.1) shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; *) # from 4.6 on, and DragonFly shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; esac ;; gnu*) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH hardcode_into_libs=yes ;; hpux9* | hpux10* | hpux11*) # Give a soname corresponding to the major version so that dld.sl refuses to # link against other versions. version_type=sunos need_lib_prefix=no need_version=no case $host_cpu in ia64*) shrext_cmds='.so' hardcode_into_libs=yes dynamic_linker="$host_os dld.so" shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' if test "X$HPUX_IA64_MODE" = X32; then sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" else sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" fi sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec ;; hppa*64*) shrext_cmds='.sl' hardcode_into_libs=yes dynamic_linker="$host_os dld.sl" shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64" sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec ;; *) shrext_cmds='.sl' dynamic_linker="$host_os dld.sl" shlibpath_var=SHLIB_PATH shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' ;; esac # HP-UX runs *really* slowly unless shared libraries are mode 555. postinstall_cmds='chmod 555 $lib' ;; interix[3-9]*) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; irix5* | irix6* | nonstopux*) case $host_os in nonstopux*) version_type=nonstopux ;; *) if test "$lt_cv_prog_gnu_ld" = yes; then version_type=linux else version_type=irix fi ;; esac need_lib_prefix=no need_version=no soname_spec='${libname}${release}${shared_ext}$major' library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext} $libname${shared_ext}' case $host_os in irix5* | nonstopux*) libsuff= shlibsuff= ;; *) case $LD in # libtool.m4 will add one of these switches to LD *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= libmagic=32-bit;; *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 libmagic=N32;; *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 libmagic=64-bit;; *) libsuff= shlibsuff= libmagic=never-match;; esac ;; esac shlibpath_var=LD_LIBRARY${shlibsuff}_PATH shlibpath_overrides_runpath=no sys_lib_search_path_spec="/usr/lib${libsuff} /lib${libsuff} /usr/local/lib${libsuff}" sys_lib_dlsearch_path_spec="/usr/lib${libsuff} /lib${libsuff}" hardcode_into_libs=yes ;; # No shared lib support for Linux oldld, aout, or coff. linux*oldld* | linux*aout* | linux*coff*) dynamic_linker=no ;; # This must be Linux ELF. linux* | k*bsd*-gnu) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no # Some binutils ld are patched to set DT_RUNPATH save_LDFLAGS=$LDFLAGS save_libdir=$libdir eval "libdir=/foo; wl=\"$lt_prog_compiler_wl\"; \ LDFLAGS=\"\$LDFLAGS $hardcode_libdir_flag_spec\"" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : if ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null; then : shlibpath_overrides_runpath=yes fi fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$save_LDFLAGS libdir=$save_libdir # This implies no fast_install, which is unacceptable. # Some rework will be needed to allow for fast_install # before this can be enabled. hardcode_into_libs=yes # Append ld.so.conf contents to the search path if test -f /etc/ld.so.conf; then lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \$2)); skip = 1; } { if (!skip) print \$0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;/^$/d' | tr '\n' ' '` sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra" fi # We used to test for /lib/ld.so.1 and disable shared libraries on # powerpc, because MkLinux only supported shared libraries with the # GNU dynamic linker. Since this was broken with cross compilers, # most powerpc-linux boxes support dynamic linking these days and # people can always --disable-shared, the test was removed, and we # assume the GNU/Linux dynamic linker is in use. dynamic_linker='GNU/Linux ld.so' ;; netbsdelf*-gnu) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes dynamic_linker='NetBSD ld.elf_so' ;; netbsd*) version_type=sunos need_lib_prefix=no need_version=no if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix' finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' dynamic_linker='NetBSD (a.out) ld.so' else library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' dynamic_linker='NetBSD ld.elf_so' fi shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; newsos6) version_type=linux library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes ;; *nto* | *qnx*) version_type=qnx need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes dynamic_linker='ldqnx.so' ;; openbsd*) version_type=sunos sys_lib_dlsearch_path_spec="/usr/lib" need_lib_prefix=no # Some older versions of OpenBSD (3.3 at least) *do* need versioned libs. case $host_os in openbsd3.3 | openbsd3.3.*) need_version=yes ;; *) need_version=no ;; esac library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix' finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' shlibpath_var=LD_LIBRARY_PATH if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then case $host_os in openbsd2.[89] | openbsd2.[89].*) shlibpath_overrides_runpath=no ;; *) shlibpath_overrides_runpath=yes ;; esac else shlibpath_overrides_runpath=yes fi ;; os2*) libname_spec='$name' shrext_cmds=".dll" need_lib_prefix=no library_names_spec='$libname${shared_ext} $libname.a' dynamic_linker='OS/2 ld.exe' shlibpath_var=LIBPATH ;; osf3* | osf4* | osf5*) version_type=osf need_lib_prefix=no need_version=no soname_spec='${libname}${release}${shared_ext}$major' library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' shlibpath_var=LD_LIBRARY_PATH sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib" sys_lib_dlsearch_path_spec="$sys_lib_search_path_spec" ;; rdos*) dynamic_linker=no ;; solaris*) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes # ldd complains unless libraries are executable postinstall_cmds='chmod +x $lib' ;; sunos4*) version_type=sunos library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix' finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes if test "$with_gnu_ld" = yes; then need_lib_prefix=no fi need_version=yes ;; sysv4 | sysv4.3*) version_type=linux library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH case $host_vendor in sni) shlibpath_overrides_runpath=no need_lib_prefix=no runpath_var=LD_RUN_PATH ;; siemens) need_lib_prefix=no ;; motorola) need_lib_prefix=no need_version=no shlibpath_overrides_runpath=no sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib' ;; esac ;; sysv4*MP*) if test -d /usr/nec ;then version_type=linux library_names_spec='$libname${shared_ext}.$versuffix $libname${shared_ext}.$major $libname${shared_ext}' soname_spec='$libname${shared_ext}.$major' shlibpath_var=LD_LIBRARY_PATH fi ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) version_type=freebsd-elf need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes if test "$with_gnu_ld" = yes; then sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib' else sys_lib_search_path_spec='/usr/ccs/lib /usr/lib' case $host_os in sco3.2v5*) sys_lib_search_path_spec="$sys_lib_search_path_spec /lib" ;; esac fi sys_lib_dlsearch_path_spec='/usr/lib' ;; tpf*) # TPF is a cross-target only. Preferred cross-host = GNU/Linux. version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; uts4*) version_type=linux library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH ;; *) dynamic_linker=no ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: $dynamic_linker" >&5 $as_echo "$dynamic_linker" >&6; } test "$dynamic_linker" = no && can_build_shared=no variables_saved_for_relink="PATH $shlibpath_var $runpath_var" if test "$GCC" = yes; then variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" fi if test "${lt_cv_sys_lib_search_path_spec+set}" = set; then sys_lib_search_path_spec="$lt_cv_sys_lib_search_path_spec" fi if test "${lt_cv_sys_lib_dlsearch_path_spec+set}" = set; then sys_lib_dlsearch_path_spec="$lt_cv_sys_lib_dlsearch_path_spec" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to hardcode library paths into programs" >&5 $as_echo_n "checking how to hardcode library paths into programs... " >&6; } hardcode_action= if test -n "$hardcode_libdir_flag_spec" || test -n "$runpath_var" || test "X$hardcode_automatic" = "Xyes" ; then # We can hardcode non-existent directories. if test "$hardcode_direct" != no && # If the only mechanism to avoid hardcoding is shlibpath_var, we # have to relink, otherwise we might link with an installed library # when we should be linking with a yet-to-be-installed one ## test "$_LT_TAGVAR(hardcode_shlibpath_var, )" != no && test "$hardcode_minus_L" != no; then # Linking always hardcodes the temporary library directory. hardcode_action=relink else # We can link without hardcoding, and we can hardcode nonexisting dirs. hardcode_action=immediate fi else # We cannot hardcode anything, or else we can only hardcode existing # directories. hardcode_action=unsupported fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hardcode_action" >&5 $as_echo "$hardcode_action" >&6; } if test "$hardcode_action" = relink || test "$inherit_rpath" = yes; then # Fast installation is not supported enable_fast_install=no elif test "$shlibpath_overrides_runpath" = yes || test "$enable_shared" = no; then # Fast installation is not necessary enable_fast_install=needless fi if test "x$enable_dlopen" != xyes; then enable_dlopen=unknown enable_dlopen_self=unknown enable_dlopen_self_static=unknown else lt_cv_dlopen=no lt_cv_dlopen_libs= case $host_os in beos*) lt_cv_dlopen="load_add_on" lt_cv_dlopen_libs= lt_cv_dlopen_self=yes ;; mingw* | pw32* | cegcc*) lt_cv_dlopen="LoadLibrary" lt_cv_dlopen_libs= ;; cygwin*) lt_cv_dlopen="dlopen" lt_cv_dlopen_libs= ;; darwin*) # if libdl is installed we need to link against it { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlopen+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dl_dlopen=yes else ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = x""yes; then : lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-ldl" else lt_cv_dlopen="dyld" lt_cv_dlopen_libs= lt_cv_dlopen_self=yes fi ;; *) ac_fn_c_check_func "$LINENO" "shl_load" "ac_cv_func_shl_load" if test "x$ac_cv_func_shl_load" = x""yes; then : lt_cv_dlopen="shl_load" else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 $as_echo_n "checking for shl_load in -ldld... " >&6; } if test "${ac_cv_lib_dld_shl_load+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char shl_load (); int main () { return shl_load (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dld_shl_load=yes else ac_cv_lib_dld_shl_load=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 $as_echo "$ac_cv_lib_dld_shl_load" >&6; } if test "x$ac_cv_lib_dld_shl_load" = x""yes; then : lt_cv_dlopen="shl_load" lt_cv_dlopen_libs="-ldld" else ac_fn_c_check_func "$LINENO" "dlopen" "ac_cv_func_dlopen" if test "x$ac_cv_func_dlopen" = x""yes; then : lt_cv_dlopen="dlopen" else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlopen+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dl_dlopen=yes else ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = x""yes; then : lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-ldl" else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -lsvld" >&5 $as_echo_n "checking for dlopen in -lsvld... " >&6; } if test "${ac_cv_lib_svld_dlopen+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsvld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_svld_dlopen=yes else ac_cv_lib_svld_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_svld_dlopen" >&5 $as_echo "$ac_cv_lib_svld_dlopen" >&6; } if test "x$ac_cv_lib_svld_dlopen" = x""yes; then : lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-lsvld" else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dld_link in -ldld" >&5 $as_echo_n "checking for dld_link in -ldld... " >&6; } if test "${ac_cv_lib_dld_dld_link+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dld_link (); int main () { return dld_link (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dld_dld_link=yes else ac_cv_lib_dld_dld_link=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_dld_link" >&5 $as_echo "$ac_cv_lib_dld_dld_link" >&6; } if test "x$ac_cv_lib_dld_dld_link" = x""yes; then : lt_cv_dlopen="dld_link" lt_cv_dlopen_libs="-ldld" fi fi fi fi fi fi ;; esac if test "x$lt_cv_dlopen" != xno; then enable_dlopen=yes else enable_dlopen=no fi case $lt_cv_dlopen in dlopen) save_CPPFLAGS="$CPPFLAGS" test "x$ac_cv_header_dlfcn_h" = xyes && CPPFLAGS="$CPPFLAGS -DHAVE_DLFCN_H" save_LDFLAGS="$LDFLAGS" wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $export_dynamic_flag_spec\" save_LIBS="$LIBS" LIBS="$lt_cv_dlopen_libs $LIBS" { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether a program can dlopen itself" >&5 $as_echo_n "checking whether a program can dlopen itself... " >&6; } if test "${lt_cv_dlopen_self+set}" = set; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : lt_cv_dlopen_self=cross else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF #line 9664 "configure" #include "confdefs.h" #if HAVE_DLFCN_H #include #endif #include #ifdef RTLD_GLOBAL # define LT_DLGLOBAL RTLD_GLOBAL #else # ifdef DL_GLOBAL # define LT_DLGLOBAL DL_GLOBAL # else # define LT_DLGLOBAL 0 # endif #endif /* We may have to define LT_DLLAZY_OR_NOW in the command line if we find out it does not work in some platform. */ #ifndef LT_DLLAZY_OR_NOW # ifdef RTLD_LAZY # define LT_DLLAZY_OR_NOW RTLD_LAZY # else # ifdef DL_LAZY # define LT_DLLAZY_OR_NOW DL_LAZY # else # ifdef RTLD_NOW # define LT_DLLAZY_OR_NOW RTLD_NOW # else # ifdef DL_NOW # define LT_DLLAZY_OR_NOW DL_NOW # else # define LT_DLLAZY_OR_NOW 0 # endif # endif # endif # endif #endif void fnord() { int i=42;} int main () { void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW); int status = $lt_dlunknown; if (self) { if (dlsym (self,"fnord")) status = $lt_dlno_uscore; else if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore; /* dlclose (self); */ } else puts (dlerror ()); return status; } _LT_EOF if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 (eval $ac_link) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && test -s conftest${ac_exeext} 2>/dev/null; then (./conftest; exit; ) >&5 2>/dev/null lt_status=$? case x$lt_status in x$lt_dlno_uscore) lt_cv_dlopen_self=yes ;; x$lt_dlneed_uscore) lt_cv_dlopen_self=yes ;; x$lt_dlunknown|x*) lt_cv_dlopen_self=no ;; esac else : # compilation failed lt_cv_dlopen_self=no fi fi rm -fr conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self" >&5 $as_echo "$lt_cv_dlopen_self" >&6; } if test "x$lt_cv_dlopen_self" = xyes; then wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $lt_prog_compiler_static\" { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether a statically linked program can dlopen itself" >&5 $as_echo_n "checking whether a statically linked program can dlopen itself... " >&6; } if test "${lt_cv_dlopen_self_static+set}" = set; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : lt_cv_dlopen_self_static=cross else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF #line 9760 "configure" #include "confdefs.h" #if HAVE_DLFCN_H #include #endif #include #ifdef RTLD_GLOBAL # define LT_DLGLOBAL RTLD_GLOBAL #else # ifdef DL_GLOBAL # define LT_DLGLOBAL DL_GLOBAL # else # define LT_DLGLOBAL 0 # endif #endif /* We may have to define LT_DLLAZY_OR_NOW in the command line if we find out it does not work in some platform. */ #ifndef LT_DLLAZY_OR_NOW # ifdef RTLD_LAZY # define LT_DLLAZY_OR_NOW RTLD_LAZY # else # ifdef DL_LAZY # define LT_DLLAZY_OR_NOW DL_LAZY # else # ifdef RTLD_NOW # define LT_DLLAZY_OR_NOW RTLD_NOW # else # ifdef DL_NOW # define LT_DLLAZY_OR_NOW DL_NOW # else # define LT_DLLAZY_OR_NOW 0 # endif # endif # endif # endif #endif void fnord() { int i=42;} int main () { void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW); int status = $lt_dlunknown; if (self) { if (dlsym (self,"fnord")) status = $lt_dlno_uscore; else if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore; /* dlclose (self); */ } else puts (dlerror ()); return status; } _LT_EOF if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 (eval $ac_link) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && test -s conftest${ac_exeext} 2>/dev/null; then (./conftest; exit; ) >&5 2>/dev/null lt_status=$? case x$lt_status in x$lt_dlno_uscore) lt_cv_dlopen_self_static=yes ;; x$lt_dlneed_uscore) lt_cv_dlopen_self_static=yes ;; x$lt_dlunknown|x*) lt_cv_dlopen_self_static=no ;; esac else : # compilation failed lt_cv_dlopen_self_static=no fi fi rm -fr conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self_static" >&5 $as_echo "$lt_cv_dlopen_self_static" >&6; } fi CPPFLAGS="$save_CPPFLAGS" LDFLAGS="$save_LDFLAGS" LIBS="$save_LIBS" ;; esac case $lt_cv_dlopen_self in yes|no) enable_dlopen_self=$lt_cv_dlopen_self ;; *) enable_dlopen_self=unknown ;; esac case $lt_cv_dlopen_self_static in yes|no) enable_dlopen_self_static=$lt_cv_dlopen_self_static ;; *) enable_dlopen_self_static=unknown ;; esac fi striplib= old_striplib= { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether stripping libraries is possible" >&5 $as_echo_n "checking whether stripping libraries is possible... " >&6; } if test -n "$STRIP" && $STRIP -V 2>&1 | $GREP "GNU strip" >/dev/null; then test -z "$old_striplib" && old_striplib="$STRIP --strip-debug" test -z "$striplib" && striplib="$STRIP --strip-unneeded" { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else # FIXME - insert some real tests, host_os isn't really good enough case $host_os in darwin*) if test -n "$STRIP" ; then striplib="$STRIP -x" old_striplib="$STRIP -S" { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi ;; *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } ;; esac fi # Report which library types will actually be built { $as_echo "$as_me:${as_lineno-$LINENO}: checking if libtool supports shared libraries" >&5 $as_echo_n "checking if libtool supports shared libraries... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $can_build_shared" >&5 $as_echo "$can_build_shared" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries" >&5 $as_echo_n "checking whether to build shared libraries... " >&6; } test "$can_build_shared" = "no" && enable_shared=no # On AIX, shared libraries and static libraries use the same namespace, and # are all built from PIC. case $host_os in aix3*) test "$enable_shared" = yes && enable_static=no if test -n "$RANLIB"; then archive_cmds="$archive_cmds~\$RANLIB \$lib" postinstall_cmds='$RANLIB $lib' fi ;; aix[4-9]*) if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then test "$enable_shared" = yes && enable_static=no fi ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_shared" >&5 $as_echo "$enable_shared" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build static libraries" >&5 $as_echo_n "checking whether to build static libraries... " >&6; } # Make sure either enable_shared or enable_static is yes. test "$enable_shared" = yes || enable_static=yes { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_static" >&5 $as_echo "$enable_static" >&6; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu CC="$lt_save_CC" ac_config_commands="$ac_config_commands libtool" # Only expand once: version="0.90.2" libcurrent=13 librevision=0 libage=4 libversion="$libcurrent:$librevision:$libage" makefile_template="Makefile.in:Makedefs.in" output_files="src/Makefile:Makedefs.in:src/Makefile.in\ lisp/Makefile:Makedefs.in:lisp/Makefile.in\ Makefile:Makedefs.in:Makefile.in\ man/Makefile:Makedefs.in:man/Makefile.in\ intl/Makefile librep.spec librep.pc librep.ebuild" case "${prefix}" in */) prefix=`echo ${prefix} | sed -e 's/^\(.*\)\/$/\1/'` ;; esac repdir='${datadir}/rep' replispdir='${repdir}/${version}/lisp' repexecdir='${libexecdir}/rep/${version}/${host_type}' repcommonexecdir='${libexecdir}/rep/${host_type}' repdocfile='${repexecdir}/doc-strings' emacssitelispdir='${datadir}/emacs/site-lisp' case "$prefix" in /|/usr|/usr/local|NONE) ;; *) LDFLAGS="${LDFLAGS} -L$prefix/lib" CPPFLAGS="${CPPFLAGS} -I$prefix/include" ;; esac EXTRA_LIBOBJS="" ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_CC+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "no acceptable C compiler found in \$PATH See \`config.log' for more details." "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 rm -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if test "${ac_cv_c_compiler_gnu+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if test "${ac_cv_prog_cc_g+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if test "${ac_cv_prog_cc_c89+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing strerror" >&5 $as_echo_n "checking for library containing strerror... " >&6; } if test "${ac_cv_search_strerror+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char strerror (); int main () { return strerror (); ; return 0; } _ACEOF for ac_lib in '' cposix; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_strerror=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if test "${ac_cv_search_strerror+set}" = set; then : break fi done if test "${ac_cv_search_strerror+set}" = set; then : else ac_cv_search_strerror=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_strerror" >&5 $as_echo "$ac_cv_search_strerror" >&6; } ac_res=$ac_cv_search_strerror if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test "${ac_cv_prog_CPP+set}" = set; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if test "${ac_cv_path_install+set}" = set; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in #(( ./ | .// | /[cC]/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ln -s works" >&5 $as_echo_n "checking whether ln -s works... " >&6; } LN_S=$as_ln_s if test "$LN_S" = "ln -s"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no, using $LN_S" >&5 $as_echo "no, using $LN_S" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if { as_var=ac_cv_prog_make_${ac_make}_set; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi if test $ac_cv_c_compiler_gnu = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC needs -traditional" >&5 $as_echo_n "checking whether $CC needs -traditional... " >&6; } if test "${ac_cv_prog_gcc_traditional+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_pattern="Autoconf.*'x'" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Autoconf TIOCGETP _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "$ac_pattern" >/dev/null 2>&1; then : ac_cv_prog_gcc_traditional=yes else ac_cv_prog_gcc_traditional=no fi rm -f conftest* if test $ac_cv_prog_gcc_traditional = no; then cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Autoconf TCGETA _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "$ac_pattern" >/dev/null 2>&1; then : ac_cv_prog_gcc_traditional=yes fi rm -f conftest* fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_gcc_traditional" >&5 $as_echo "$ac_cv_prog_gcc_traditional" >&6; } if test $ac_cv_prog_gcc_traditional = yes; then CC="$CC -traditional" fi fi # Check whether --enable-static was given. if test "${enable_static+set}" = set; then : enableval=$enable_static; p=${PACKAGE-default} case $enableval in yes) enable_static=yes ;; no) enable_static=no ;; *) enable_static=no # Look at the argument we got. We use all the common list separators. lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR," for pkg in $enableval; do IFS="$lt_save_ifs" if test "X$pkg" = "X$p"; then enable_static=yes fi done IFS="$lt_save_ifs" ;; esac else enable_static=no fi if test "${enable_shared}" != "yes"; then as_fn_error "Need shared libraries enabled" "$LINENO" 5 fi ac_fn_c_check_func "$LINENO" "gethostent" "ac_cv_func_gethostent" if test "x$ac_cv_func_gethostent" = x""yes; then : else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostent in -lnsl" >&5 $as_echo_n "checking for gethostent in -lnsl... " >&6; } if test "${ac_cv_lib_nsl_gethostent+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lnsl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gethostent (); int main () { return gethostent (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_nsl_gethostent=yes else ac_cv_lib_nsl_gethostent=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_gethostent" >&5 $as_echo "$ac_cv_lib_nsl_gethostent" >&6; } if test "x$ac_cv_lib_nsl_gethostent" = x""yes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBNSL 1 _ACEOF LIBS="-lnsl $LIBS" fi fi ac_fn_c_check_func "$LINENO" "setsockopt" "ac_cv_func_setsockopt" if test "x$ac_cv_func_setsockopt" = x""yes; then : else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for setsockopt in -lsocket" >&5 $as_echo_n "checking for setsockopt in -lsocket... " >&6; } if test "${ac_cv_lib_socket_setsockopt+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char setsockopt (); int main () { return setsockopt (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_socket_setsockopt=yes else ac_cv_lib_socket_setsockopt=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_setsockopt" >&5 $as_echo "$ac_cv_lib_socket_setsockopt" >&6; } if test "x$ac_cv_lib_socket_setsockopt" = x""yes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBSOCKET 1 _ACEOF LIBS="-lsocket $LIBS" fi fi ac_fn_c_check_func "$LINENO" "dlopen" "ac_cv_func_dlopen" if test "x$ac_cv_func_dlopen" = x""yes; then : else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlopen+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dl_dlopen=yes else ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = x""yes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBDL 1 _ACEOF LIBS="-ldl $LIBS" fi fi ac_header_dirent=no for ac_hdr in dirent.h sys/ndir.h sys/dir.h ndir.h; do as_ac_Header=`$as_echo "ac_cv_header_dirent_$ac_hdr" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_hdr that defines DIR" >&5 $as_echo_n "checking for $ac_hdr that defines DIR... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include <$ac_hdr> int main () { if ((DIR *) 0) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$as_ac_Header=yes" else eval "$as_ac_Header=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$as_ac_Header { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_Header if test "x$as_val" = x""yes; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_hdr" | $as_tr_cpp` 1 _ACEOF ac_header_dirent=$ac_hdr; break fi done # Two versions of opendir et al. are in -ldir and -lx on SCO Xenix. if test $ac_header_dirent = dirent.h; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if test "${ac_cv_search_opendir+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char opendir (); int main () { return opendir (); ; return 0; } _ACEOF for ac_lib in '' dir; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_opendir=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if test "${ac_cv_search_opendir+set}" = set; then : break fi done if test "${ac_cv_search_opendir+set}" = set; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_opendir" >&5 $as_echo "$ac_cv_search_opendir" >&6; } ac_res=$ac_cv_search_opendir if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if test "${ac_cv_search_opendir+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char opendir (); int main () { return opendir (); ; return 0; } _ACEOF for ac_lib in '' x; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_opendir=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if test "${ac_cv_search_opendir+set}" = set; then : break fi done if test "${ac_cv_search_opendir+set}" = set; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_opendir" >&5 $as_echo "$ac_cv_search_opendir" >&6; } ac_res=$ac_cv_search_opendir if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if test "${ac_cv_header_stdc+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : : else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sys/wait.h that is POSIX.1 compatible" >&5 $as_echo_n "checking for sys/wait.h that is POSIX.1 compatible... " >&6; } if test "${ac_cv_header_sys_wait_h+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #ifndef WEXITSTATUS # define WEXITSTATUS(stat_val) ((unsigned int) (stat_val) >> 8) #endif #ifndef WIFEXITED # define WIFEXITED(stat_val) (((stat_val) & 255) == 0) #endif int main () { int s; wait (&s); s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_sys_wait_h=yes else ac_cv_header_sys_wait_h=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_sys_wait_h" >&5 $as_echo "$ac_cv_header_sys_wait_h" >&6; } if test $ac_cv_header_sys_wait_h = yes; then $as_echo "#define HAVE_SYS_WAIT_H 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether time.h and sys/time.h may both be included" >&5 $as_echo_n "checking whether time.h and sys/time.h may both be included... " >&6; } if test "${ac_cv_header_time+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include int main () { if ((struct tm *) 0) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_time=yes else ac_cv_header_time=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_time" >&5 $as_echo "$ac_cv_header_time" >&6; } if test $ac_cv_header_time = yes; then $as_echo "#define TIME_WITH_SYS_TIME 1" >>confdefs.h fi for ac_header in fcntl.h sys/ioctl.h sys/time.h sys/utsname.h unistd.h siginfo.h memory.h stropts.h termios.h string.h limits.h argz.h locale.h nl_types.h malloc.h sys/param.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" eval as_val=\$$as_ac_Header if test "x$as_val" = x""yes; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done # Check whether --with-gmp was given. if test "${with_gmp+set}" = set; then : withval=$with_gmp; else with_gmp=maybe fi GMP_LIBS="-lm" if test "$with_gmp" != "no"; then # Check whether --with-gmp-prefix was given. if test "${with_gmp_prefix+set}" = set; then : withval=$with_gmp_prefix; if test "$withval" != "no"; then CPPFLAGS="${CPPFLAGS} -I$withval/include" LDFLAGS="${LDFLAGS} -L$withval/lib" fi else if test -d /usr/include/gmp2; then CPPFLAGS="${CPPFLAGS} -I/usr/include/gmp2" fi fi found_gmp=no ac_fn_c_check_header_mongrel "$LINENO" "gmp.h" "ac_cv_header_gmp_h" "$ac_includes_default" if test "x$ac_cv_header_gmp_h" = x""yes; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpz_init in -lgmp" >&5 $as_echo_n "checking for mpz_init in -lgmp... " >&6; } if test "${ac_cv_lib_gmp_mpz_init+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgmp $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char mpz_init (); int main () { return mpz_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gmp_mpz_init=yes else ac_cv_lib_gmp_mpz_init=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp_mpz_init" >&5 $as_echo "$ac_cv_lib_gmp_mpz_init" >&6; } if test "x$ac_cv_lib_gmp_mpz_init" = x""yes; then : GMP_LIBS="-lgmp -lm"; found_gmp=yes else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for __gmpz_init in -lgmp" >&5 $as_echo_n "checking for __gmpz_init in -lgmp... " >&6; } if test "${ac_cv_lib_gmp___gmpz_init+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgmp $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char __gmpz_init (); int main () { return __gmpz_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gmp___gmpz_init=yes else ac_cv_lib_gmp___gmpz_init=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp___gmpz_init" >&5 $as_echo "$ac_cv_lib_gmp___gmpz_init" >&6; } if test "x$ac_cv_lib_gmp___gmpz_init" = x""yes; then : GMP_LIBS="-lgmp -lm"; found_gmp=yes fi fi fi if test "$found_gmp" = "yes"; then $as_echo "#define HAVE_GMP 1" >>confdefs.h _libs="$LIBS" LIBS="$LIBS $GMP_LIBS" ac_fn_c_check_func "$LINENO" "__gmp_randinit" "ac_cv_func___gmp_randinit" if test "x$ac_cv_func___gmp_randinit" = x""yes; then : $as_echo "#define HAVE_GMP_RANDINIT 1" >>confdefs.h fi LIBS="$_libs" elif test "$with_gmp" != "no"; then as_fn_error "Can't find GMP (--without-gmp for cut-down non-GMP build)" "$LINENO" 5 fi fi # Check whether --with-gdbm-prefix was given. if test "${with_gdbm_prefix+set}" = set; then : withval=$with_gdbm_prefix; if test "$withval" != "no"; then CPPFLAGS="${CPPFLAGS} -I$withval/include" LDFLAGS="${LDFLAGS} -L$withval/lib" fi fi ac_fn_c_check_header_mongrel "$LINENO" "gdbm.h" "ac_cv_header_gdbm_h" "$ac_includes_default" if test "x$ac_cv_header_gdbm_h" = x""yes; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gdbm_open in -lgdbm" >&5 $as_echo_n "checking for gdbm_open in -lgdbm... " >&6; } if test "${ac_cv_lib_gdbm_gdbm_open+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgdbm $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gdbm_open (); int main () { return gdbm_open (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gdbm_gdbm_open=yes else ac_cv_lib_gdbm_gdbm_open=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gdbm_gdbm_open" >&5 $as_echo "$ac_cv_lib_gdbm_gdbm_open" >&6; } if test "x$ac_cv_lib_gdbm_gdbm_open" = x""yes; then : GDBM_LIBS="-lgdbm" else as_fn_error "Cannot find GDBM library" "$LINENO" 5 fi else as_fn_error "Cannot find GDBM header" "$LINENO" 5 fi doug_lea_malloc=yes ac_fn_c_check_func "$LINENO" "malloc_get_state" "ac_cv_func_malloc_get_state" if test "x$ac_cv_func_malloc_get_state" = x""yes; then : else doug_lea_malloc=no fi ac_fn_c_check_func "$LINENO" "malloc_set_state" "ac_cv_func_malloc_set_state" if test "x$ac_cv_func_malloc_set_state" = x""yes; then : else doug_lea_malloc=no fi if test "$doug_lea_malloc" = "no"; then $as_echo "#define LIBC_MALLOC 1" >>confdefs.h else $as_echo "#define DOUG_LEA_MALLOC 1" >>confdefs.h $as_echo "#define LIBC_MALLOC 1" >>confdefs.h fi # Check whether --with-readline was given. if test "${with_readline+set}" = set; then : withval=$with_readline; else with_readline=maybe fi if test "$with_readline" != "no"; then _cppflags=${CPPFLAGS} _ldflags=${LDFLAGS} # Check whether --with-readline-prefix was given. if test "${with_readline_prefix+set}" = set; then : withval=$with_readline_prefix; if test "$withval" != "no" -a "$withval" != "yes"; then CPPFLAGS="${CPPFLAGS} -I$withval/include" LDFLAGS="${LDFLAGS} -L$withval/lib" fi fi unset tcap for termlib in ncurses curses termcap terminfo termlib; do as_ac_Lib=`$as_echo "ac_cv_lib_${termlib}''_tputs" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for tputs in -l${termlib}" >&5 $as_echo_n "checking for tputs in -l${termlib}... " >&6; } if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-l${termlib} $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char tputs (); int main () { return tputs (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : eval "$as_ac_Lib=yes" else eval "$as_ac_Lib=no" fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi eval ac_res=\$$as_ac_Lib { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_Lib if test "x$as_val" = x""yes; then : tcap="$tcap -l$termlib" fi case "$tcap" in *-l${termlib}*) break ;; esac done ac_fn_c_check_header_mongrel "$LINENO" "readline/readline.h" "ac_cv_header_readline_readline_h" "$ac_includes_default" if test "x$ac_cv_header_readline_readline_h" = x""yes; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for readline in -lreadline" >&5 $as_echo_n "checking for readline in -lreadline... " >&6; } if test "${ac_cv_lib_readline_readline+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lreadline $tcap $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char readline (); int main () { return readline (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_readline_readline=yes else ac_cv_lib_readline_readline=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_readline" >&5 $as_echo "$ac_cv_lib_readline_readline" >&6; } if test "x$ac_cv_lib_readline_readline" = x""yes; then : READLINE_LIBS=" -L/lib${libsuff} -lreadline $tcap" $as_echo "#define HAVE_LIBREADLINE 1" >>confdefs.h found_readline=yes fi fi if test -z "$READLINE_LIBS"; then if test "$with_readline_prefix" = "yes"; then as_fn_error "Can't find readline libraries" "$LINENO" 5 else CPPFLAGS=${_cppflags} LDFLAGS=${_ldflags} fi fi fi FFI_MIN_VER=3.0 # Check whether --with-ffi was given. if test "${with_ffi+set}" = set; then : withval=$with_ffi; else with_ffi=yes fi if test "$with_ffi" != "no"; then if test "x$ac_cv_env_PKG_CONFIG_set" != "xset"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_PKG_CONFIG+set}" = set; then : $as_echo_n "(cached) " >&6 else case $PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_PKG_CONFIG="$PKG_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_PKG_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi PKG_CONFIG=$ac_cv_path_PKG_CONFIG if test -n "$PKG_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PKG_CONFIG" >&5 $as_echo "$PKG_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_path_PKG_CONFIG"; then ac_pt_PKG_CONFIG=$PKG_CONFIG # Extract the first word of "pkg-config", so it can be a program name with args. set dummy pkg-config; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_ac_pt_PKG_CONFIG+set}" = set; then : $as_echo_n "(cached) " >&6 else case $ac_pt_PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_ac_pt_PKG_CONFIG="$ac_pt_PKG_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_ac_pt_PKG_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi ac_pt_PKG_CONFIG=$ac_cv_path_ac_pt_PKG_CONFIG if test -n "$ac_pt_PKG_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKG_CONFIG" >&5 $as_echo "$ac_pt_PKG_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_pt_PKG_CONFIG" = x; then PKG_CONFIG="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac PKG_CONFIG=$ac_pt_PKG_CONFIG fi else PKG_CONFIG="$ac_cv_path_PKG_CONFIG" fi fi if test -n "$PKG_CONFIG"; then _pkg_min_version=0.9.0 { $as_echo "$as_me:${as_lineno-$LINENO}: checking pkg-config is at least version $_pkg_min_version" >&5 $as_echo_n "checking pkg-config is at least version $_pkg_min_version... " >&6; } if $PKG_CONFIG --atleast-pkgconfig-version $_pkg_min_version; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } PKG_CONFIG="" fi fi pkg_failed=no { $as_echo "$as_me:${as_lineno-$LINENO}: checking for LIBFFI" >&5 $as_echo_n "checking for LIBFFI... " >&6; } if test -n "$PKG_CONFIG"; then if test -n "$LIBFFI_CFLAGS"; then pkg_cv_LIBFFI_CFLAGS="$LIBFFI_CFLAGS" else if test -n "$PKG_CONFIG" && \ { { $as_echo "$as_me:${as_lineno-$LINENO}: \$PKG_CONFIG --exists --print-errors \"libffi >= \$FFI_MIN_VER \""; } >&5 ($PKG_CONFIG --exists --print-errors "libffi >= $FFI_MIN_VER ") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then pkg_cv_LIBFFI_CFLAGS=`$PKG_CONFIG --cflags "libffi >= $FFI_MIN_VER " 2>/dev/null` else pkg_failed=yes fi fi else pkg_failed=untried fi if test -n "$PKG_CONFIG"; then if test -n "$LIBFFI_LIBS"; then pkg_cv_LIBFFI_LIBS="$LIBFFI_LIBS" else if test -n "$PKG_CONFIG" && \ { { $as_echo "$as_me:${as_lineno-$LINENO}: \$PKG_CONFIG --exists --print-errors \"libffi >= \$FFI_MIN_VER \""; } >&5 ($PKG_CONFIG --exists --print-errors "libffi >= $FFI_MIN_VER ") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then pkg_cv_LIBFFI_LIBS=`$PKG_CONFIG --libs "libffi >= $FFI_MIN_VER " 2>/dev/null` else pkg_failed=yes fi fi else pkg_failed=untried fi if test $pkg_failed = yes; then if $PKG_CONFIG --atleast-pkgconfig-version 0.20; then _pkg_short_errors_supported=yes else _pkg_short_errors_supported=no fi if test $_pkg_short_errors_supported = yes; then LIBFFI_PKG_ERRORS=`$PKG_CONFIG --short-errors --errors-to-stdout --print-errors "libffi >= $FFI_MIN_VER "` else LIBFFI_PKG_ERRORS=`$PKG_CONFIG --errors-to-stdout --print-errors "libffi >= $FFI_MIN_VER "` fi # Put the nasty error message in config.log where it belongs echo "$LIBFFI_PKG_ERRORS" >&5 { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } as_fn_error "can't locate libffi" "$LINENO" 5 elif test $pkg_failed = untried; then as_fn_error "can't locate libffi" "$LINENO" 5 else LIBFFI_CFLAGS=$pkg_cv_LIBFFI_CFLAGS LIBFFI_LIBS=$pkg_cv_LIBFFI_LIBS { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } found_ffi=yes fi fi ac_fn_c_check_header_mongrel "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default" if test "x$ac_cv_header_dlfcn_h" = x""yes; then : $as_echo "#define HAVE_DLFCN_H 1" >>confdefs.h fi ac_fn_c_check_header_mongrel "$LINENO" "dl.h" "ac_cv_header_dl_h" "$ac_includes_default" if test "x$ac_cv_header_dl_h" = x""yes; then : $as_echo "#define HAVE_DL_H 1" >>confdefs.h fi ac_fn_c_check_header_mongrel "$LINENO" "sys/dl.h" "ac_cv_header_sys_dl_h" "$ac_includes_default" if test "x$ac_cv_header_sys_dl_h" = x""yes; then : $as_echo "#define HAVE_SYS_DL_H 1" >>confdefs.h fi dl_ok=no ac_fn_c_check_func "$LINENO" "dlopen" "ac_cv_func_dlopen" if test "x$ac_cv_func_dlopen" = x""yes; then : $as_echo "#define HAVE_DLOPEN 1" >>confdefs.h dl_ok=dl else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlopen+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dl_dlopen=yes else ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = x""yes; then : $as_echo "#define HAVE_DLOPEN 1" >>confdefs.h dl_ok=dl fi fi ac_fn_c_check_func "$LINENO" "shl_load" "ac_cv_func_shl_load" if test "x$ac_cv_func_shl_load" = x""yes; then : $as_echo "#define HAVE_SHL_LOAD 1" >>confdefs.h dl_ok=shl else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 $as_echo_n "checking for shl_load in -ldld... " >&6; } if test "${ac_cv_lib_dld_shl_load+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char shl_load (); int main () { return shl_load (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dld_shl_load=yes else ac_cv_lib_dld_shl_load=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 $as_echo "$ac_cv_lib_dld_shl_load" >&6; } if test "x$ac_cv_lib_dld_shl_load" = x""yes; then : $as_echo "#define HAVE_DLOPEN 1" >>confdefs.h dl_ok=shl fi fi if test $dl_ok = dl; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for preceding underscore in symbols" >&5 $as_echo_n "checking for preceding underscore in symbols... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "cannot run test program while cross compiling See \`config.log' for more details." "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef HAVE_DLFCN_H # include #endif int glib_underscore_test (void) { return 42; } int main() { void *f1 = (void*)0, *f2 = (void*)0, *handle; handle = dlopen ((void*)0, 0); if (handle) { f1 = dlsym (handle, "glib_underscore_test"); f2 = dlsym (handle, "_glib_underscore_test"); } return (!f2 || f1); } _ACEOF if ac_fn_c_try_run "$LINENO"; then : $as_echo "#define DLSYM_NEED_USCORE 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi case ${host} in *-dec-osf5*) { $as_echo "$as_me:${as_lineno-$LINENO}: checking for broken RTLD_GLOBAL on Tru64" >&5 $as_echo_n "checking for broken RTLD_GLOBAL on Tru64... " >&6; } if /usr/sbin/sizer -v | grep -E -q -e 'UNIX [TVX]5\.0A?(-[[:digit:]]+)? '; then $as_echo "#define BROKEN_RTLD_GLOBAL 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi ;; esac fi if test $dl_ok != no; then $as_echo "#define HAVE_DYNAMIC_LOADING 1" >>confdefs.h else as_fn_error "can't figure out how to do dynamic loading" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for an ANSI C-conforming const" >&5 $as_echo_n "checking for an ANSI C-conforming const... " >&6; } if test "${ac_cv_c_const+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { /* FIXME: Include the comments suggested by Paul. */ #ifndef __cplusplus /* Ultrix mips cc rejects this. */ typedef int charset[2]; const charset cs; /* SunOS 4.1.1 cc rejects this. */ char const *const *pcpcc; char **ppc; /* NEC SVR4.0.2 mips cc rejects this. */ struct point {int x, y;}; static struct point const zero = {0,0}; /* AIX XL C 1.02.0.0 rejects this. It does not let you subtract one const X* pointer from another in an arm of an if-expression whose if-part is not a constant expression */ const char *g = "string"; pcpcc = &g + (g ? g-g : 0); /* HPUX 7.0 cc rejects these. */ ++pcpcc; ppc = (char**) pcpcc; pcpcc = (char const *const *) ppc; { /* SCO 3.2v4 cc rejects this. */ char *t; char const *s = 0 ? (char *) 0 : (char const *) 0; *t++ = 0; if (s) return 0; } { /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ int x[] = {25, 17}; const int *foo = &x[0]; ++foo; } { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ typedef const int *iptr; iptr p = 0; ++p; } { /* AIX XL C 1.02.0.0 rejects this saying "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ struct s { int j; const int *ap[3]; }; struct s *b; b->j = 5; } { /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ const int foo = 10; if (!foo) return 0; } return !cs[0] && !zero.x; #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_c_const=yes else ac_cv_c_const=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_const" >&5 $as_echo "$ac_cv_c_const" >&6; } if test $ac_cv_c_const = no; then $as_echo "#define const /**/" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inline" >&5 $as_echo_n "checking for inline... " >&6; } if test "${ac_cv_c_inline+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifndef __cplusplus typedef int foo_t; static $ac_kw foo_t static_foo () {return 0; } $ac_kw foo_t foo () {return 0; } #endif _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_c_inline=$ac_kw fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext test "$ac_cv_c_inline" != no && break done fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5 $as_echo "$ac_cv_c_inline" >&6; } case $ac_cv_c_inline in inline | yes) ;; *) case $ac_cv_c_inline in no) ac_val=;; *) ac_val=$ac_cv_c_inline;; esac cat >>confdefs.h <<_ACEOF #ifndef __cplusplus #define inline $ac_val #endif _ACEOF ;; esac ac_fn_c_check_type "$LINENO" "off_t" "ac_cv_type_off_t" "$ac_includes_default" if test "x$ac_cv_type_off_t" = x""yes; then : else cat >>confdefs.h <<_ACEOF #define off_t long int _ACEOF fi ac_fn_c_check_type "$LINENO" "pid_t" "ac_cv_type_pid_t" "$ac_includes_default" if test "x$ac_cv_type_pid_t" = x""yes; then : else cat >>confdefs.h <<_ACEOF #define pid_t int _ACEOF fi ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" if test "x$ac_cv_type_size_t" = x""yes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned int _ACEOF fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking return type of signal handlers" >&5 $as_echo_n "checking return type of signal handlers... " >&6; } if test "${ac_cv_type_signal+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main () { return *(signal (0, 0)) (0) == 1; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_type_signal=int else ac_cv_type_signal=void fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_type_signal" >&5 $as_echo "$ac_cv_type_signal" >&6; } cat >>confdefs.h <<_ACEOF #define RETSIGTYPE $ac_cv_type_signal _ACEOF # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works # for constant arguments. Useless! { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working alloca.h" >&5 $as_echo_n "checking for working alloca.h... " >&6; } if test "${ac_cv_working_alloca_h+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { char *p = (char *) alloca (2 * sizeof (int)); if (p) return 0; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_working_alloca_h=yes else ac_cv_working_alloca_h=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_working_alloca_h" >&5 $as_echo "$ac_cv_working_alloca_h" >&6; } if test $ac_cv_working_alloca_h = yes; then $as_echo "#define HAVE_ALLOCA_H 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for alloca" >&5 $as_echo_n "checking for alloca... " >&6; } if test "${ac_cv_func_alloca_works+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __GNUC__ # define alloca __builtin_alloca #else # ifdef _MSC_VER # include # define alloca _alloca # else # ifdef HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif # endif #endif int main () { char *p = (char *) alloca (1); if (p) return 0; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_func_alloca_works=yes else ac_cv_func_alloca_works=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_alloca_works" >&5 $as_echo "$ac_cv_func_alloca_works" >&6; } if test $ac_cv_func_alloca_works = yes; then $as_echo "#define HAVE_ALLOCA 1" >>confdefs.h else # The SVR3 libPW and SVR4 libucb both contain incompatible functions # that cause trouble. Some versions do not even contain alloca or # contain a buggy version. If you still want to use their alloca, # use ar to extract alloca.o from them instead of compiling alloca.c. ALLOCA=\${LIBOBJDIR}alloca.$ac_objext $as_echo "#define C_ALLOCA 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether \`alloca.c' needs Cray hooks" >&5 $as_echo_n "checking whether \`alloca.c' needs Cray hooks... " >&6; } if test "${ac_cv_os_cray+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #if defined CRAY && ! defined CRAY2 webecray #else wenotbecray #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "webecray" >/dev/null 2>&1; then : ac_cv_os_cray=yes else ac_cv_os_cray=no fi rm -f conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_os_cray" >&5 $as_echo "$ac_cv_os_cray" >&6; } if test $ac_cv_os_cray = yes; then for ac_func in _getb67 GETB67 getb67; do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" eval as_val=\$$as_ac_var if test "x$as_val" = x""yes; then : cat >>confdefs.h <<_ACEOF #define CRAY_STACKSEG_END $ac_func _ACEOF break fi done fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking stack direction for C alloca" >&5 $as_echo_n "checking stack direction for C alloca... " >&6; } if test "${ac_cv_c_stack_direction+set}" = set; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_c_stack_direction=0 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int find_stack_direction () { static char *addr = 0; auto char dummy; if (addr == 0) { addr = &dummy; return find_stack_direction (); } else return (&dummy > addr) ? 1 : -1; } int main () { return find_stack_direction () < 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_c_stack_direction=1 else ac_cv_c_stack_direction=-1 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_stack_direction" >&5 $as_echo "$ac_cv_c_stack_direction" >&6; } cat >>confdefs.h <<_ACEOF #define STACK_DIRECTION $ac_cv_c_stack_direction _ACEOF fi for ac_header in stdlib.h unistd.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" eval as_val=\$$as_ac_Header if test "x$as_val" = x""yes; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in getpagesize do : ac_fn_c_check_func "$LINENO" "getpagesize" "ac_cv_func_getpagesize" if test "x$ac_cv_func_getpagesize" = x""yes; then : cat >>confdefs.h <<_ACEOF #define HAVE_GETPAGESIZE 1 _ACEOF fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working mmap" >&5 $as_echo_n "checking for working mmap... " >&6; } if test "${ac_cv_func_mmap_fixed_mapped+set}" = set; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_func_mmap_fixed_mapped=no else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default /* malloc might have been renamed as rpl_malloc. */ #undef malloc /* Thanks to Mike Haertel and Jim Avera for this test. Here is a matrix of mmap possibilities: mmap private not fixed mmap private fixed at somewhere currently unmapped mmap private fixed at somewhere already mapped mmap shared not fixed mmap shared fixed at somewhere currently unmapped mmap shared fixed at somewhere already mapped For private mappings, we should verify that changes cannot be read() back from the file, nor mmap's back from the file at a different address. (There have been systems where private was not correctly implemented like the infamous i386 svr4.0, and systems where the VM page cache was not coherent with the file system buffer cache like early versions of FreeBSD and possibly contemporary NetBSD.) For shared mappings, we should conversely verify that changes get propagated back to all the places they're supposed to be. Grep wants private fixed already mapped. The main things grep needs to know about mmap are: * does it exist and is it safe to write into the mmap'd area * how to use it (BSD variants) */ #include #include #if !defined STDC_HEADERS && !defined HAVE_STDLIB_H char *malloc (); #endif /* This mess was copied from the GNU getpagesize.h. */ #ifndef HAVE_GETPAGESIZE /* Assume that all systems that can run configure have sys/param.h. */ # ifndef HAVE_SYS_PARAM_H # define HAVE_SYS_PARAM_H 1 # endif # ifdef _SC_PAGESIZE # define getpagesize() sysconf(_SC_PAGESIZE) # else /* no _SC_PAGESIZE */ # ifdef HAVE_SYS_PARAM_H # include # ifdef EXEC_PAGESIZE # define getpagesize() EXEC_PAGESIZE # else /* no EXEC_PAGESIZE */ # ifdef NBPG # define getpagesize() NBPG * CLSIZE # ifndef CLSIZE # define CLSIZE 1 # endif /* no CLSIZE */ # else /* no NBPG */ # ifdef NBPC # define getpagesize() NBPC # else /* no NBPC */ # ifdef PAGESIZE # define getpagesize() PAGESIZE # endif /* PAGESIZE */ # endif /* no NBPC */ # endif /* no NBPG */ # endif /* no EXEC_PAGESIZE */ # else /* no HAVE_SYS_PARAM_H */ # define getpagesize() 8192 /* punt totally */ # endif /* no HAVE_SYS_PARAM_H */ # endif /* no _SC_PAGESIZE */ #endif /* no HAVE_GETPAGESIZE */ int main () { char *data, *data2, *data3; int i, pagesize; int fd; pagesize = getpagesize (); /* First, make a file with some known garbage in it. */ data = (char *) malloc (pagesize); if (!data) return 1; for (i = 0; i < pagesize; ++i) *(data + i) = rand (); umask (0); fd = creat ("conftest.mmap", 0600); if (fd < 0) return 1; if (write (fd, data, pagesize) != pagesize) return 1; close (fd); /* Next, try to mmap the file at a fixed address which already has something else allocated at it. If we can, also make sure that we see the same garbage. */ fd = open ("conftest.mmap", O_RDWR); if (fd < 0) return 1; data2 = (char *) malloc (2 * pagesize); if (!data2) return 1; data2 += (pagesize - ((long int) data2 & (pagesize - 1))) & (pagesize - 1); if (data2 != mmap (data2, pagesize, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_FIXED, fd, 0L)) return 1; for (i = 0; i < pagesize; ++i) if (*(data + i) != *(data2 + i)) return 1; /* Finally, make sure that changes to the mapped area do not percolate back to the file as seen by read(). (This is a bug on some variants of i386 svr4.0.) */ for (i = 0; i < pagesize; ++i) *(data2 + i) = *(data2 + i) + 1; data3 = (char *) malloc (pagesize); if (!data3) return 1; if (read (fd, data3, pagesize) != pagesize) return 1; for (i = 0; i < pagesize; ++i) if (*(data + i) != *(data3 + i)) return 1; close (fd); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_func_mmap_fixed_mapped=yes else ac_cv_func_mmap_fixed_mapped=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_mmap_fixed_mapped" >&5 $as_echo "$ac_cv_func_mmap_fixed_mapped" >&6; } if test $ac_cv_func_mmap_fixed_mapped = yes; then $as_echo "#define HAVE_MMAP 1" >>confdefs.h fi rm -f conftest.mmap { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working memcmp" >&5 $as_echo_n "checking for working memcmp... " >&6; } if test "${ac_cv_func_memcmp_working+set}" = set; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_func_memcmp_working=no else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { /* Some versions of memcmp are not 8-bit clean. */ char c0 = '\100', c1 = '\200', c2 = '\201'; if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0) return 1; /* The Next x86 OpenStep bug shows up only when comparing 16 bytes or more and with at least one buffer not starting on a 4-byte boundary. William Lewis provided this test program. */ { char foo[21]; char bar[21]; int i; for (i = 0; i < 4; i++) { char *a = foo + i; char *b = bar + i; strcpy (a, "--------01111111"); strcpy (b, "--------10000000"); if (memcmp (a, b, 16) >= 0) return 1; } return 0; } ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_func_memcmp_working=yes else ac_cv_func_memcmp_working=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_memcmp_working" >&5 $as_echo "$ac_cv_func_memcmp_working" >&6; } test $ac_cv_func_memcmp_working = no && case " $LIBOBJS " in *" memcmp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS memcmp.$ac_objext" ;; esac for ac_func in vprintf do : ac_fn_c_check_func "$LINENO" "vprintf" "ac_cv_func_vprintf" if test "x$ac_cv_func_vprintf" = x""yes; then : cat >>confdefs.h <<_ACEOF #define HAVE_VPRINTF 1 _ACEOF ac_fn_c_check_func "$LINENO" "_doprnt" "ac_cv_func__doprnt" if test "x$ac_cv_func__doprnt" = x""yes; then : $as_echo "#define HAVE_DOPRNT 1" >>confdefs.h fi fi done for ac_func in getcwd gethostname select socket strcspn strerror strstr stpcpy strtol psignal strsignal snprintf grantpt lrand48 getpagesize setitimer dladdr dlerror munmap putenv setenv setlocale strchr strcasecmp strncasecmp strdup __argz_count __argz_stringify __argz_next siginterrupt gettimeofday strtoll strtoq do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" eval as_val=\$$as_ac_var if test "x$as_val" = x""yes; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in realpath do : ac_fn_c_check_func "$LINENO" "realpath" "ac_cv_func_realpath" if test "x$ac_cv_func_realpath" = x""yes; then : cat >>confdefs.h <<_ACEOF #define HAVE_REALPATH 1 _ACEOF else case " $LIBOBJS " in *" $ac_func.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS $ac_func.$ac_objext" ;; esac fi done ac_fn_c_check_func "$LINENO" "crypt" "ac_cv_func_crypt" if test "x$ac_cv_func_crypt" = x""yes; then : $as_echo "#define HAVE_CRYPT 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for crypt in -lcrypt" >&5 $as_echo_n "checking for crypt in -lcrypt... " >&6; } if test "${ac_cv_lib_crypt_crypt+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lcrypt $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char crypt (); int main () { return crypt (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_crypt_crypt=yes else ac_cv_lib_crypt_crypt=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_crypt_crypt" >&5 $as_echo "$ac_cv_lib_crypt_crypt" >&6; } if test "x$ac_cv_lib_crypt_crypt" = x""yes; then : $as_echo "#define HAVE_CRYPT 1" >>confdefs.h LIBS="$LIBS -lcrypt" fi fi if test "x${GCC}" = "xyes"; then MAKEDEP='$(CC) -MM' else case ${host} in *-dec-osf*) MAKEDEP='$(CC) -M' ;; *-sun-solaris*) MAKEDEP='/usr/ccs/lib/cpp -M' ;; *) MAKEDEP='true' ;; esac fi if test "x${GCC}" = "xyes" -a "x$CFLAGS" = "x-g -O2"; then CFLAGS="${CFLAGS} -Wall -Wpointer-arith -Wmissing-prototypes" case ${host} in *-sun-solaris*) CFLAGS="${CFLAGS} -Wno-implicit-int" ;; *-apple-darwin) CFLAGS="${CFLAGS} -no-cpp-precomp" ;; esac fi # Check whether --with-extra-cflags was given. if test "${with_extra_cflags+set}" = set; then : withval=$with_extra_cflags; CFLAGS="${CFLAGS} $with_extra_cflags" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether unistd.h declares environ" >&5 $as_echo_n "checking whether unistd.h declares environ... " >&6; } if test "${jade_cv_decl_environ+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { char **foo = environ; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : jade_cv_decl_environ=yes else jade_cv_decl_environ=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $jade_cv_decl_environ" >&5 $as_echo "$jade_cv_decl_environ" >&6; } if test ${jade_cv_decl_environ} = no; then $as_echo "#define ENVIRON_UNDECLARED 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether /dev/ptmx exists" >&5 $as_echo_n "checking whether /dev/ptmx exists... " >&6; } if test -r /dev/ptmx; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_PTYS 1" >>confdefs.h $as_echo "#define HAVE_DEV_PTMX 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether /dev/ptyXN devices exist" >&5 $as_echo_n "checking whether /dev/ptyXN devices exist... " >&6; } if test "${jade_cv_sys_dev_pty+set}" = set; then : $as_echo_n "(cached) " >&6 else jade_cv_sys_dev_pty=no for c in p q r s t u v w x y z a b c d e f g h i j k l m n o; do if test -r "/dev/pty${c}0"; then jade_cv_sys_dev_pty=${c} break fi done fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $jade_cv_sys_dev_pty" >&5 $as_echo "$jade_cv_sys_dev_pty" >&6; } if test ${jade_cv_sys_dev_pty} != no; then $as_echo "#define HAVE_PTYS 1" >>confdefs.h cat >>confdefs.h <<_ACEOF #define FIRST_PTY_LETTER '${jade_cv_sys_dev_pty}' _ACEOF fi aclocaldir=none # Check whether --with-aclocaldir was given. if test "${with_aclocaldir+set}" = set; then : withval=$with_aclocaldir; aclocaldir=$withval fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for aclocal directory" >&5 $as_echo_n "checking for aclocal directory... " >&6; } if test "$aclocaldir" = none; then aclocaldir="`aclocal --print-ac-dir 2>/dev/null`" if test "x${aclocaldir}" = "x"; then aclocaldir='${datadir}/aclocal' fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${aclocaldir}" >&5 $as_echo "${aclocaldir}" >&6; } # Check whether --enable-continuations was given. if test "${enable_continuations+set}" = set; then : enableval=$enable_continuations; if test "$enableval" != "no"; then $as_echo "#define WITH_CONTINUATIONS 1" >>confdefs.h fi else $as_echo "#define WITH_CONTINUATIONS 1" >>confdefs.h fi # Check whether --enable-dballoc was given. if test "${enable_dballoc+set}" = set; then : enableval=$enable_dballoc; if test "$enableval" != "no"; then $as_echo "#define DEBUG_SYS_ALLOC 1" >>confdefs.h fi fi # Check whether --enable-dbsyms was given. if test "${enable_dbsyms+set}" = set; then : enableval=$enable_dbsyms; if test "$enableval" != "no"; then $as_echo "#define DB_RESOLVE_SYMBOLS 1" >>confdefs.h fi else $as_echo "#define DB_RESOLVE_SYMBOLS 1" >>confdefs.h fi # Check whether --enable-gprof was given. if test "${enable_gprof+set}" = set; then : enableval=$enable_gprof; CFLAGS="${CFLAGS} -pg"; LDFLAGS="${LDFLAGS} -pg" fi # Check whether --enable-full-name-terminator was given. if test "${enable_full_name_terminator+set}" = set; then : enableval=$enable_full_name_terminator; if test "$enableval" != "no"; then enableval="'$enableval'" cat >>confdefs.h <<_ACEOF #define FULL_NAME_TERMINATOR $enableval _ACEOF fi fi HAVE_UNIX=1 $as_echo "#define rep_HAVE_UNIX 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: checking for data type to store Lisp values" >&5 $as_echo_n "checking for data type to store Lisp values... " >&6; } # Check whether --with-value-type was given. if test "${with_value_type+set}" = set; then : withval=$with_value_type; else with_value_type="undef" fi if test "${with_value_type}" = "undef"; then if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "cannot run test program while cross compiling See \`config.log' for more details." "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ main () { exit (!(sizeof (int) >= sizeof (void *)));} _ACEOF if ac_fn_c_try_run "$LINENO"; then : with_value_type=int fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi if test "${with_value_type}" = "undef"; then if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "cannot run test program while cross compiling See \`config.log' for more details." "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ main () { exit (!(sizeof (long int) >= sizeof (void *)));} _ACEOF if ac_fn_c_try_run "$LINENO"; then : with_value_type="long int" fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi if test "${with_value_type}" = "undef"; then if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "cannot run test program while cross compiling See \`config.log' for more details." "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ main () { exit (!(sizeof (long long int) >= sizeof (void *)));} _ACEOF if ac_fn_c_try_run "$LINENO"; then : with_value_type="long long int" fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi if test "${with_value_type}" = "undef"; then as_fn_error "can't find Lisp value type; set --with-value-type (see README)" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${with_value_type}" >&5 $as_echo "${with_value_type}" >&6; } cat >>confdefs.h <<_ACEOF #define rep_PTR_SIZED_INT ${with_value_type} _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for size of Lisp value type" >&5 $as_echo_n "checking for size of Lisp value type... " >&6; } # Check whether --with-value-sizeof was given. if test "${with_value_sizeof+set}" = set; then : withval=$with_value_sizeof; else with_value_sizeof="undef" fi if test "${with_value_sizeof}" = "undef"; then if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "cannot run test program while cross compiling See \`config.log' for more details." "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include main () { FILE *f = fopen ("conftestval", "w"); if (!f) exit (1); fprintf (f, "%d\n", sizeof (${with_value_type})); exit (0); } _ACEOF if ac_fn_c_try_run "$LINENO"; then : with_value_sizeof=`cat conftestval`; rm -f conftestval fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${with_value_sizeof} bytes" >&5 $as_echo "${with_value_sizeof} bytes" >&6; } cat >>confdefs.h <<_ACEOF #define rep_PTR_SIZED_INT_SIZEOF ${with_value_sizeof} _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for value type constant suffix" >&5 $as_echo_n "checking for value type constant suffix... " >&6; } case "${with_value_type}" in "long long int"|"long long") rep_value_suffix=LL ;; *) rep_value_suffix=L ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${rep_value_suffix}" >&5 $as_echo "${rep_value_suffix}" >&6; } cat >>confdefs.h <<_ACEOF #define rep_PTR_SIZED_INT_SUFFIX ${rep_value_suffix} _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for value type printf conversion" >&5 $as_echo_n "checking for value type printf conversion... " >&6; } case "${with_value_type}" in "long long int"|"long long") rep_value_conv=ll ;; long|"long int") rep_value_conv=l ;; *) rep_value_conv= ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${rep_value_conv}" >&5 $as_echo "${rep_value_conv}" >&6; } cat >>confdefs.h <<_ACEOF #define rep_PTR_SIZED_INT_CONV "${rep_value_conv}" _ACEOF # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 $as_echo_n "checking size of long... " >&6; } if test "${ac_cv_sizeof_long+set}" = set; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default"; then : else if test "$ac_cv_type_long" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { as_fn_set_status 77 as_fn_error "cannot compute sizeof (long) See \`config.log' for more details." "$LINENO" 5; }; } else ac_cv_sizeof_long=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 $as_echo "$ac_cv_sizeof_long" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_LONG $ac_cv_sizeof_long _ACEOF # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long long" >&5 $as_echo_n "checking size of long long... " >&6; } if test "${ac_cv_sizeof_long_long+set}" = set; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long long))" "ac_cv_sizeof_long_long" "$ac_includes_default"; then : else if test "$ac_cv_type_long_long" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { as_fn_set_status 77 as_fn_error "cannot compute sizeof (long long) See \`config.log' for more details." "$LINENO" 5; }; } else ac_cv_sizeof_long_long=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long_long" >&5 $as_echo "$ac_cv_sizeof_long_long" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_LONG_LONG $ac_cv_sizeof_long_long _ACEOF # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of void *" >&5 $as_echo_n "checking size of void *... " >&6; } if test "${ac_cv_sizeof_void_p+set}" = set; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (void *))" "ac_cv_sizeof_void_p" "$ac_includes_default"; then : else if test "$ac_cv_type_void_p" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { as_fn_set_status 77 as_fn_error "cannot compute sizeof (void *) See \`config.log' for more details." "$LINENO" 5; }; } else ac_cv_sizeof_void_p=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_void_p" >&5 $as_echo "$ac_cv_sizeof_void_p" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_VOID_P $ac_cv_sizeof_void_p _ACEOF if test "x$ac_cv_sizeof_long_long" != "x0"; then $as_echo "#define rep_HAVE_LONG_LONG 1" >>confdefs.h fi # Check whether --with-malloc-alignment was given. if test "${with_malloc_alignment+set}" = set; then : withval=$with_malloc_alignment; else with_malloc_alignment=${with_value_sizeof} fi cat >>confdefs.h <<_ACEOF #define rep_MALLOC_ALIGNMENT ${with_malloc_alignment} _ACEOF if test "x${GCC}" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for broken alpha gcc" >&5 $as_echo_n "checking for broken alpha gcc... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { __builtin_return_address(1); ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } else $as_echo "#define BROKEN_ALPHA_GCC 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Backtrace support will not be compiled" >&5 $as_echo "$as_me: WARNING: Backtrace support will not be compiled" >&2;} fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for stack growth direction" >&5 $as_echo_n "checking for stack growth direction... " >&6; } # Check whether --with-stack-direction was given. if test "${with_stack_direction+set}" = set; then : withval=$with_stack_direction; { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${with_stack_direction}" >&5 $as_echo "${with_stack_direction}" >&6; } else with_stack_direction=unknown fi if test "${with_stack_direction}" = unknown; then case ${host_cpu} in sparc|i?86|powerpc) { $as_echo "$as_me:${as_lineno-$LINENO}: result: assuming downwards" >&5 $as_echo "assuming downwards" >&6; } with_stack_direction="-1" ;; esac fi if test "${with_stack_direction}" = unknown; then if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error "cannot run test program while cross compiling See \`config.log' for more details." "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ void inner (char *foo) { char bar; exit (!(foo >= &bar)); } void main () { char foo; inner (&foo); } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: downwards" >&5 $as_echo "downwards" >&6; } with_stack_direction=-1 else { $as_echo "$as_me:${as_lineno-$LINENO}: result: upwards" >&5 $as_echo "upwards" >&6; } with_stack_direction=+1 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi if test "${with_stack_direction}" != unknown; then cat >>confdefs.h <<_ACEOF #define STACK_DIRECTION ${with_stack_direction} _ACEOF fi # Check whether --enable-paranoia was given. if test "${enable_paranoia+set}" = set; then : enableval=$enable_paranoia; paranoia=$enableval else paranoia="no" fi if test $paranoia = "yes"; then CFLAGS+=" -Wall -ansi -pedantic" fi cat >>confdefs.h <<_ACEOF #define rep_VERSION "${version}" _ACEOF cat >>confdefs.h <<_ACEOF #define rep_INTERFACE ${libcurrent} _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for LC_MESSAGES" >&5 $as_echo_n "checking for LC_MESSAGES... " >&6; } if test "${gt_cv_val_LC_MESSAGES+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { return LC_MESSAGES ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : gt_cv_val_LC_MESSAGES=yes else gt_cv_val_LC_MESSAGES=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $gt_cv_val_LC_MESSAGES" >&5 $as_echo "$gt_cv_val_LC_MESSAGES" >&6; } if test $gt_cv_val_LC_MESSAGES = yes; then $as_echo "#define HAVE_LC_MESSAGES 1" >>confdefs.h fi VERSION="$version" PACKAGE="librep" DATADIRNAME="share" MKINSTALLDIRS='${top_srcdir}/mkinstalldirs' INTLOBJS="\$(GETTOBJS)" GT_YES='#' GT_NO='' l=l USE_INCLUDED_LIBINTL=yes ac_fn_c_check_func "$LINENO" "_nl_msg_cat_cntr" "ac_cv_func__nl_msg_cat_cntr" if test "x$ac_cv_func__nl_msg_cat_cntr" = x""yes; then : $as_echo "#define LIBC_GETTEXT 1" >>confdefs.h for ac_header in libintl.h do : ac_fn_c_check_header_mongrel "$LINENO" "libintl.h" "ac_cv_header_libintl_h" "$ac_includes_default" if test "x$ac_cv_header_libintl_h" = x""yes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBINTL_H 1 _ACEOF fi done USE_INCLUDED_LIBINTL=no fi ac_config_files="$ac_config_files ${output_files}" ac_config_commands="$ac_config_commands default" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then test "x$cache_file" != "x/dev/null" && { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} cat confcache >$cache_file else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : ${CONFIG_STATUS=./config.status} ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error ERROR [LINENO LOG_FD] # --------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with status $?, using 1 if that was 0. as_fn_error () { as_status=$?; test $as_status -eq 0 && as_status=1 if test "$3"; then as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 fi $as_echo "$as_me: error: $1" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in #( -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.64. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" config_commands="$ac_config_commands" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Configuration commands: $config_commands Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.64, with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" Copyright (C) 2009 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' INSTALL='$INSTALL' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_HEADERS " '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header as_fn_error "ambiguous option: \`$1' Try \`$0 --help' for more information.";; --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # # INIT-COMMANDS # # The HP-UX ksh and POSIX shell print the target directory to stdout # if CDPATH is set. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH sed_quote_subst='$sed_quote_subst' double_quote_subst='$double_quote_subst' delay_variable_subst='$delay_variable_subst' macro_version='`$ECHO "X$macro_version" | $Xsed -e "$delay_single_quote_subst"`' macro_revision='`$ECHO "X$macro_revision" | $Xsed -e "$delay_single_quote_subst"`' enable_shared='`$ECHO "X$enable_shared" | $Xsed -e "$delay_single_quote_subst"`' enable_static='`$ECHO "X$enable_static" | $Xsed -e "$delay_single_quote_subst"`' pic_mode='`$ECHO "X$pic_mode" | $Xsed -e "$delay_single_quote_subst"`' enable_fast_install='`$ECHO "X$enable_fast_install" | $Xsed -e "$delay_single_quote_subst"`' host_alias='`$ECHO "X$host_alias" | $Xsed -e "$delay_single_quote_subst"`' host='`$ECHO "X$host" | $Xsed -e "$delay_single_quote_subst"`' host_os='`$ECHO "X$host_os" | $Xsed -e "$delay_single_quote_subst"`' build_alias='`$ECHO "X$build_alias" | $Xsed -e "$delay_single_quote_subst"`' build='`$ECHO "X$build" | $Xsed -e "$delay_single_quote_subst"`' build_os='`$ECHO "X$build_os" | $Xsed -e "$delay_single_quote_subst"`' SED='`$ECHO "X$SED" | $Xsed -e "$delay_single_quote_subst"`' Xsed='`$ECHO "X$Xsed" | $Xsed -e "$delay_single_quote_subst"`' GREP='`$ECHO "X$GREP" | $Xsed -e "$delay_single_quote_subst"`' EGREP='`$ECHO "X$EGREP" | $Xsed -e "$delay_single_quote_subst"`' FGREP='`$ECHO "X$FGREP" | $Xsed -e "$delay_single_quote_subst"`' LD='`$ECHO "X$LD" | $Xsed -e "$delay_single_quote_subst"`' NM='`$ECHO "X$NM" | $Xsed -e "$delay_single_quote_subst"`' LN_S='`$ECHO "X$LN_S" | $Xsed -e "$delay_single_quote_subst"`' max_cmd_len='`$ECHO "X$max_cmd_len" | $Xsed -e "$delay_single_quote_subst"`' ac_objext='`$ECHO "X$ac_objext" | $Xsed -e "$delay_single_quote_subst"`' exeext='`$ECHO "X$exeext" | $Xsed -e "$delay_single_quote_subst"`' lt_unset='`$ECHO "X$lt_unset" | $Xsed -e "$delay_single_quote_subst"`' lt_SP2NL='`$ECHO "X$lt_SP2NL" | $Xsed -e "$delay_single_quote_subst"`' lt_NL2SP='`$ECHO "X$lt_NL2SP" | $Xsed -e "$delay_single_quote_subst"`' reload_flag='`$ECHO "X$reload_flag" | $Xsed -e "$delay_single_quote_subst"`' reload_cmds='`$ECHO "X$reload_cmds" | $Xsed -e "$delay_single_quote_subst"`' OBJDUMP='`$ECHO "X$OBJDUMP" | $Xsed -e "$delay_single_quote_subst"`' deplibs_check_method='`$ECHO "X$deplibs_check_method" | $Xsed -e "$delay_single_quote_subst"`' file_magic_cmd='`$ECHO "X$file_magic_cmd" | $Xsed -e "$delay_single_quote_subst"`' AR='`$ECHO "X$AR" | $Xsed -e "$delay_single_quote_subst"`' AR_FLAGS='`$ECHO "X$AR_FLAGS" | $Xsed -e "$delay_single_quote_subst"`' STRIP='`$ECHO "X$STRIP" | $Xsed -e "$delay_single_quote_subst"`' RANLIB='`$ECHO "X$RANLIB" | $Xsed -e "$delay_single_quote_subst"`' old_postinstall_cmds='`$ECHO "X$old_postinstall_cmds" | $Xsed -e "$delay_single_quote_subst"`' old_postuninstall_cmds='`$ECHO "X$old_postuninstall_cmds" | $Xsed -e "$delay_single_quote_subst"`' old_archive_cmds='`$ECHO "X$old_archive_cmds" | $Xsed -e "$delay_single_quote_subst"`' CC='`$ECHO "X$CC" | $Xsed -e "$delay_single_quote_subst"`' CFLAGS='`$ECHO "X$CFLAGS" | $Xsed -e "$delay_single_quote_subst"`' compiler='`$ECHO "X$compiler" | $Xsed -e "$delay_single_quote_subst"`' GCC='`$ECHO "X$GCC" | $Xsed -e "$delay_single_quote_subst"`' lt_cv_sys_global_symbol_pipe='`$ECHO "X$lt_cv_sys_global_symbol_pipe" | $Xsed -e "$delay_single_quote_subst"`' lt_cv_sys_global_symbol_to_cdecl='`$ECHO "X$lt_cv_sys_global_symbol_to_cdecl" | $Xsed -e "$delay_single_quote_subst"`' lt_cv_sys_global_symbol_to_c_name_address='`$ECHO "X$lt_cv_sys_global_symbol_to_c_name_address" | $Xsed -e "$delay_single_quote_subst"`' lt_cv_sys_global_symbol_to_c_name_address_lib_prefix='`$ECHO "X$lt_cv_sys_global_symbol_to_c_name_address_lib_prefix" | $Xsed -e "$delay_single_quote_subst"`' objdir='`$ECHO "X$objdir" | $Xsed -e "$delay_single_quote_subst"`' SHELL='`$ECHO "X$SHELL" | $Xsed -e "$delay_single_quote_subst"`' ECHO='`$ECHO "X$ECHO" | $Xsed -e "$delay_single_quote_subst"`' MAGIC_CMD='`$ECHO "X$MAGIC_CMD" | $Xsed -e "$delay_single_quote_subst"`' lt_prog_compiler_no_builtin_flag='`$ECHO "X$lt_prog_compiler_no_builtin_flag" | $Xsed -e "$delay_single_quote_subst"`' lt_prog_compiler_wl='`$ECHO "X$lt_prog_compiler_wl" | $Xsed -e "$delay_single_quote_subst"`' lt_prog_compiler_pic='`$ECHO "X$lt_prog_compiler_pic" | $Xsed -e "$delay_single_quote_subst"`' lt_prog_compiler_static='`$ECHO "X$lt_prog_compiler_static" | $Xsed -e "$delay_single_quote_subst"`' lt_cv_prog_compiler_c_o='`$ECHO "X$lt_cv_prog_compiler_c_o" | $Xsed -e "$delay_single_quote_subst"`' need_locks='`$ECHO "X$need_locks" | $Xsed -e "$delay_single_quote_subst"`' DSYMUTIL='`$ECHO "X$DSYMUTIL" | $Xsed -e "$delay_single_quote_subst"`' NMEDIT='`$ECHO "X$NMEDIT" | $Xsed -e "$delay_single_quote_subst"`' LIPO='`$ECHO "X$LIPO" | $Xsed -e "$delay_single_quote_subst"`' OTOOL='`$ECHO "X$OTOOL" | $Xsed -e "$delay_single_quote_subst"`' OTOOL64='`$ECHO "X$OTOOL64" | $Xsed -e "$delay_single_quote_subst"`' libext='`$ECHO "X$libext" | $Xsed -e "$delay_single_quote_subst"`' shrext_cmds='`$ECHO "X$shrext_cmds" | $Xsed -e "$delay_single_quote_subst"`' extract_expsyms_cmds='`$ECHO "X$extract_expsyms_cmds" | $Xsed -e "$delay_single_quote_subst"`' archive_cmds_need_lc='`$ECHO "X$archive_cmds_need_lc" | $Xsed -e "$delay_single_quote_subst"`' enable_shared_with_static_runtimes='`$ECHO "X$enable_shared_with_static_runtimes" | $Xsed -e "$delay_single_quote_subst"`' export_dynamic_flag_spec='`$ECHO "X$export_dynamic_flag_spec" | $Xsed -e "$delay_single_quote_subst"`' whole_archive_flag_spec='`$ECHO "X$whole_archive_flag_spec" | $Xsed -e "$delay_single_quote_subst"`' compiler_needs_object='`$ECHO "X$compiler_needs_object" | $Xsed -e "$delay_single_quote_subst"`' old_archive_from_new_cmds='`$ECHO "X$old_archive_from_new_cmds" | $Xsed -e "$delay_single_quote_subst"`' old_archive_from_expsyms_cmds='`$ECHO "X$old_archive_from_expsyms_cmds" | $Xsed -e "$delay_single_quote_subst"`' archive_cmds='`$ECHO "X$archive_cmds" | $Xsed -e "$delay_single_quote_subst"`' archive_expsym_cmds='`$ECHO "X$archive_expsym_cmds" | $Xsed -e "$delay_single_quote_subst"`' module_cmds='`$ECHO "X$module_cmds" | $Xsed -e "$delay_single_quote_subst"`' module_expsym_cmds='`$ECHO "X$module_expsym_cmds" | $Xsed -e "$delay_single_quote_subst"`' with_gnu_ld='`$ECHO "X$with_gnu_ld" | $Xsed -e "$delay_single_quote_subst"`' allow_undefined_flag='`$ECHO "X$allow_undefined_flag" | $Xsed -e "$delay_single_quote_subst"`' no_undefined_flag='`$ECHO "X$no_undefined_flag" | $Xsed -e "$delay_single_quote_subst"`' hardcode_libdir_flag_spec='`$ECHO "X$hardcode_libdir_flag_spec" | $Xsed -e "$delay_single_quote_subst"`' hardcode_libdir_flag_spec_ld='`$ECHO "X$hardcode_libdir_flag_spec_ld" | $Xsed -e "$delay_single_quote_subst"`' hardcode_libdir_separator='`$ECHO "X$hardcode_libdir_separator" | $Xsed -e "$delay_single_quote_subst"`' hardcode_direct='`$ECHO "X$hardcode_direct" | $Xsed -e "$delay_single_quote_subst"`' hardcode_direct_absolute='`$ECHO "X$hardcode_direct_absolute" | $Xsed -e "$delay_single_quote_subst"`' hardcode_minus_L='`$ECHO "X$hardcode_minus_L" | $Xsed -e "$delay_single_quote_subst"`' hardcode_shlibpath_var='`$ECHO "X$hardcode_shlibpath_var" | $Xsed -e "$delay_single_quote_subst"`' hardcode_automatic='`$ECHO "X$hardcode_automatic" | $Xsed -e "$delay_single_quote_subst"`' inherit_rpath='`$ECHO "X$inherit_rpath" | $Xsed -e "$delay_single_quote_subst"`' link_all_deplibs='`$ECHO "X$link_all_deplibs" | $Xsed -e "$delay_single_quote_subst"`' fix_srcfile_path='`$ECHO "X$fix_srcfile_path" | $Xsed -e "$delay_single_quote_subst"`' always_export_symbols='`$ECHO "X$always_export_symbols" | $Xsed -e "$delay_single_quote_subst"`' export_symbols_cmds='`$ECHO "X$export_symbols_cmds" | $Xsed -e "$delay_single_quote_subst"`' exclude_expsyms='`$ECHO "X$exclude_expsyms" | $Xsed -e "$delay_single_quote_subst"`' include_expsyms='`$ECHO "X$include_expsyms" | $Xsed -e "$delay_single_quote_subst"`' prelink_cmds='`$ECHO "X$prelink_cmds" | $Xsed -e "$delay_single_quote_subst"`' file_list_spec='`$ECHO "X$file_list_spec" | $Xsed -e "$delay_single_quote_subst"`' variables_saved_for_relink='`$ECHO "X$variables_saved_for_relink" | $Xsed -e "$delay_single_quote_subst"`' need_lib_prefix='`$ECHO "X$need_lib_prefix" | $Xsed -e "$delay_single_quote_subst"`' need_version='`$ECHO "X$need_version" | $Xsed -e "$delay_single_quote_subst"`' version_type='`$ECHO "X$version_type" | $Xsed -e "$delay_single_quote_subst"`' runpath_var='`$ECHO "X$runpath_var" | $Xsed -e "$delay_single_quote_subst"`' shlibpath_var='`$ECHO "X$shlibpath_var" | $Xsed -e "$delay_single_quote_subst"`' shlibpath_overrides_runpath='`$ECHO "X$shlibpath_overrides_runpath" | $Xsed -e "$delay_single_quote_subst"`' libname_spec='`$ECHO "X$libname_spec" | $Xsed -e "$delay_single_quote_subst"`' library_names_spec='`$ECHO "X$library_names_spec" | $Xsed -e "$delay_single_quote_subst"`' soname_spec='`$ECHO "X$soname_spec" | $Xsed -e "$delay_single_quote_subst"`' postinstall_cmds='`$ECHO "X$postinstall_cmds" | $Xsed -e "$delay_single_quote_subst"`' postuninstall_cmds='`$ECHO "X$postuninstall_cmds" | $Xsed -e "$delay_single_quote_subst"`' finish_cmds='`$ECHO "X$finish_cmds" | $Xsed -e "$delay_single_quote_subst"`' finish_eval='`$ECHO "X$finish_eval" | $Xsed -e "$delay_single_quote_subst"`' hardcode_into_libs='`$ECHO "X$hardcode_into_libs" | $Xsed -e "$delay_single_quote_subst"`' sys_lib_search_path_spec='`$ECHO "X$sys_lib_search_path_spec" | $Xsed -e "$delay_single_quote_subst"`' sys_lib_dlsearch_path_spec='`$ECHO "X$sys_lib_dlsearch_path_spec" | $Xsed -e "$delay_single_quote_subst"`' hardcode_action='`$ECHO "X$hardcode_action" | $Xsed -e "$delay_single_quote_subst"`' enable_dlopen='`$ECHO "X$enable_dlopen" | $Xsed -e "$delay_single_quote_subst"`' enable_dlopen_self='`$ECHO "X$enable_dlopen_self" | $Xsed -e "$delay_single_quote_subst"`' enable_dlopen_self_static='`$ECHO "X$enable_dlopen_self_static" | $Xsed -e "$delay_single_quote_subst"`' old_striplib='`$ECHO "X$old_striplib" | $Xsed -e "$delay_single_quote_subst"`' striplib='`$ECHO "X$striplib" | $Xsed -e "$delay_single_quote_subst"`' LTCC='$LTCC' LTCFLAGS='$LTCFLAGS' compiler='$compiler_DEFAULT' # Quote evaled strings. for var in SED \ GREP \ EGREP \ FGREP \ LD \ NM \ LN_S \ lt_SP2NL \ lt_NL2SP \ reload_flag \ OBJDUMP \ deplibs_check_method \ file_magic_cmd \ AR \ AR_FLAGS \ STRIP \ RANLIB \ CC \ CFLAGS \ compiler \ lt_cv_sys_global_symbol_pipe \ lt_cv_sys_global_symbol_to_cdecl \ lt_cv_sys_global_symbol_to_c_name_address \ lt_cv_sys_global_symbol_to_c_name_address_lib_prefix \ SHELL \ ECHO \ lt_prog_compiler_no_builtin_flag \ lt_prog_compiler_wl \ lt_prog_compiler_pic \ lt_prog_compiler_static \ lt_cv_prog_compiler_c_o \ need_locks \ DSYMUTIL \ NMEDIT \ LIPO \ OTOOL \ OTOOL64 \ shrext_cmds \ export_dynamic_flag_spec \ whole_archive_flag_spec \ compiler_needs_object \ with_gnu_ld \ allow_undefined_flag \ no_undefined_flag \ hardcode_libdir_flag_spec \ hardcode_libdir_flag_spec_ld \ hardcode_libdir_separator \ fix_srcfile_path \ exclude_expsyms \ include_expsyms \ file_list_spec \ variables_saved_for_relink \ libname_spec \ library_names_spec \ soname_spec \ finish_eval \ old_striplib \ striplib; do case \`eval \\\\\$ECHO "X\\\\\$\$var"\` in *[\\\\\\\`\\"\\\$]*) eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"X\\\$\$var\\" | \\\$Xsed -e \\"\\\$sed_quote_subst\\"\\\`\\\\\\"" ;; *) eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" ;; esac done # Double-quote double-evaled strings. for var in reload_cmds \ old_postinstall_cmds \ old_postuninstall_cmds \ old_archive_cmds \ extract_expsyms_cmds \ old_archive_from_new_cmds \ old_archive_from_expsyms_cmds \ archive_cmds \ archive_expsym_cmds \ module_cmds \ module_expsym_cmds \ export_symbols_cmds \ prelink_cmds \ postinstall_cmds \ postuninstall_cmds \ finish_cmds \ sys_lib_search_path_spec \ sys_lib_dlsearch_path_spec; do case \`eval \\\\\$ECHO "X\\\\\$\$var"\` in *[\\\\\\\`\\"\\\$]*) eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"X\\\$\$var\\" | \\\$Xsed -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\"" ;; *) eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" ;; esac done # Fix-up fallback echo if it was mangled by the above quoting rules. case \$lt_ECHO in *'\\\$0 --fallback-echo"') lt_ECHO=\`\$ECHO "X\$lt_ECHO" | \$Xsed -e 's/\\\\\\\\\\\\\\\$0 --fallback-echo"\$/\$0 --fallback-echo"/'\` ;; esac ac_aux_dir='$ac_aux_dir' xsi_shell='$xsi_shell' lt_shell_append='$lt_shell_append' # See if we are running on zsh, and set the options which allow our # commands through without removal of \ escapes INIT. if test -n "\${ZSH_VERSION+set}" ; then setopt NO_GLOB_SUBST fi PACKAGE='$PACKAGE' VERSION='$VERSION' TIMESTAMP='$TIMESTAMP' RM='$RM' ofile='$ofile' _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; "src/rep_config.h") CONFIG_HEADERS="$CONFIG_HEADERS src/rep_config.h" ;; "libtool") CONFIG_COMMANDS="$CONFIG_COMMANDS libtool" ;; "${output_files}") CONFIG_FILES="$CONFIG_FILES ${output_files}" ;; "default") CONFIG_COMMANDS="$CONFIG_COMMANDS default" ;; *) as_fn_error "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= trap 'exit_status=$? { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error "cannot create a temporary directory in ." "$LINENO" 5 # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '$'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\).*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\).*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \ || as_fn_error "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/ s/:*\${srcdir}:*/:/ s/:*@srcdir@:*/:/ s/^\([^=]*=[ ]*\):*/\1/ s/:*$// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_t=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_t"; then break elif $ac_last_try; then as_fn_error "could not make $CONFIG_HEADERS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 as_fn_error "could not setup config headers machinery" "$LINENO" 5 fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS :C $CONFIG_COMMANDS" shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$tmp/stdin" \ || as_fn_error "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; esac _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t s&@INSTALL@&$ac_INSTALL&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \ || as_fn_error "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined." >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined." >&2;} rm -f "$tmp/stdin" case $ac_file in -) cat "$tmp/out" && rm -f "$tmp/out";; *) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; esac \ || as_fn_error "could not create $ac_file" "$LINENO" 5 ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { $as_echo "/* $configure_input */" \ && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" } >"$tmp/config.h" \ || as_fn_error "could not create $ac_file" "$LINENO" 5 if diff "$ac_file" "$tmp/config.h" >/dev/null 2>&1; then { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$tmp/config.h" "$ac_file" \ || as_fn_error "could not create $ac_file" "$LINENO" 5 fi else $as_echo "/* $configure_input */" \ && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error "could not create -" "$LINENO" 5 fi ;; :C) { $as_echo "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5 $as_echo "$as_me: executing $ac_file commands" >&6;} ;; esac case $ac_file$ac_mode in "libtool":C) # See if we are running on zsh, and set the options which allow our # commands through without removal of \ escapes. if test -n "${ZSH_VERSION+set}" ; then setopt NO_GLOB_SUBST fi cfgfile="${ofile}T" trap "$RM \"$cfgfile\"; exit 1" 1 2 15 $RM "$cfgfile" cat <<_LT_EOF >> "$cfgfile" #! $SHELL # `$ECHO "$ofile" | sed 's%^.*/%%'` - Provide generalized library-building support services. # Generated automatically by $as_me ($PACKAGE$TIMESTAMP) $VERSION # Libtool was configured on host `(hostname || uname -n) 2>/dev/null | sed 1q`: # NOTE: Changes made to this file will be lost: look at ltmain.sh. # # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2005, # 2006, 2007, 2008 Free Software Foundation, Inc. # Written by Gordon Matzigkeit, 1996 # # This file is part of GNU Libtool. # # GNU Libtool is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License as # published by the Free Software Foundation; either version 2 of # the License, or (at your option) any later version. # # As a special exception to the GNU General Public License, # if you distribute this file as part of a program or library that # is built using GNU Libtool, you may include this file under the # same distribution terms that you use for the rest of that program. # # GNU Libtool is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with GNU Libtool; see the file COPYING. If not, a copy # can be downloaded from http://www.gnu.org/licenses/gpl.html, or # obtained by writing to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. # The names of the tagged configurations supported by this script. available_tags="" # ### BEGIN LIBTOOL CONFIG # Which release of libtool.m4 was used? macro_version=$macro_version macro_revision=$macro_revision # Whether or not to build shared libraries. build_libtool_libs=$enable_shared # Whether or not to build static libraries. build_old_libs=$enable_static # What type of objects to build. pic_mode=$pic_mode # Whether or not to optimize for fast installation. fast_install=$enable_fast_install # The host system. host_alias=$host_alias host=$host host_os=$host_os # The build system. build_alias=$build_alias build=$build build_os=$build_os # A sed program that does not truncate output. SED=$lt_SED # Sed that helps us avoid accidentally triggering echo(1) options like -n. Xsed="\$SED -e 1s/^X//" # A grep program that handles long lines. GREP=$lt_GREP # An ERE matcher. EGREP=$lt_EGREP # A literal string matcher. FGREP=$lt_FGREP # A BSD- or MS-compatible name lister. NM=$lt_NM # Whether we need soft or hard links. LN_S=$lt_LN_S # What is the maximum length of a command? max_cmd_len=$max_cmd_len # Object file suffix (normally "o"). objext=$ac_objext # Executable file suffix (normally ""). exeext=$exeext # whether the shell understands "unset". lt_unset=$lt_unset # turn spaces into newlines. SP2NL=$lt_lt_SP2NL # turn newlines into spaces. NL2SP=$lt_lt_NL2SP # How to create reloadable object files. reload_flag=$lt_reload_flag reload_cmds=$lt_reload_cmds # An object symbol dumper. OBJDUMP=$lt_OBJDUMP # Method to check whether dependent libraries are shared objects. deplibs_check_method=$lt_deplibs_check_method # Command to use when deplibs_check_method == "file_magic". file_magic_cmd=$lt_file_magic_cmd # The archiver. AR=$lt_AR AR_FLAGS=$lt_AR_FLAGS # A symbol stripping program. STRIP=$lt_STRIP # Commands used to install an old-style archive. RANLIB=$lt_RANLIB old_postinstall_cmds=$lt_old_postinstall_cmds old_postuninstall_cmds=$lt_old_postuninstall_cmds # A C compiler. LTCC=$lt_CC # LTCC compiler flags. LTCFLAGS=$lt_CFLAGS # Take the output of nm and produce a listing of raw symbols and C names. global_symbol_pipe=$lt_lt_cv_sys_global_symbol_pipe # Transform the output of nm in a proper C declaration. global_symbol_to_cdecl=$lt_lt_cv_sys_global_symbol_to_cdecl # Transform the output of nm in a C name address pair. global_symbol_to_c_name_address=$lt_lt_cv_sys_global_symbol_to_c_name_address # Transform the output of nm in a C name address pair when lib prefix is needed. global_symbol_to_c_name_address_lib_prefix=$lt_lt_cv_sys_global_symbol_to_c_name_address_lib_prefix # The name of the directory that contains temporary libtool files. objdir=$objdir # Shell to use when invoking shell scripts. SHELL=$lt_SHELL # An echo program that does not interpret backslashes. ECHO=$lt_ECHO # Used to examine libraries when file_magic_cmd begins with "file". MAGIC_CMD=$MAGIC_CMD # Must we lock files when doing compilation? need_locks=$lt_need_locks # Tool to manipulate archived DWARF debug symbol files on Mac OS X. DSYMUTIL=$lt_DSYMUTIL # Tool to change global to local symbols on Mac OS X. NMEDIT=$lt_NMEDIT # Tool to manipulate fat objects and archives on Mac OS X. LIPO=$lt_LIPO # ldd/readelf like tool for Mach-O binaries on Mac OS X. OTOOL=$lt_OTOOL # ldd/readelf like tool for 64 bit Mach-O binaries on Mac OS X 10.4. OTOOL64=$lt_OTOOL64 # Old archive suffix (normally "a"). libext=$libext # Shared library suffix (normally ".so"). shrext_cmds=$lt_shrext_cmds # The commands to extract the exported symbol list from a shared archive. extract_expsyms_cmds=$lt_extract_expsyms_cmds # Variables whose values should be saved in libtool wrapper scripts and # restored at link time. variables_saved_for_relink=$lt_variables_saved_for_relink # Do we need the "lib" prefix for modules? need_lib_prefix=$need_lib_prefix # Do we need a version for libraries? need_version=$need_version # Library versioning type. version_type=$version_type # Shared library runtime path variable. runpath_var=$runpath_var # Shared library path variable. shlibpath_var=$shlibpath_var # Is shlibpath searched before the hard-coded library search path? shlibpath_overrides_runpath=$shlibpath_overrides_runpath # Format of library name prefix. libname_spec=$lt_libname_spec # List of archive names. First name is the real one, the rest are links. # The last name is the one that the linker finds with -lNAME library_names_spec=$lt_library_names_spec # The coded name of the library, if different from the real name. soname_spec=$lt_soname_spec # Command to use after installation of a shared archive. postinstall_cmds=$lt_postinstall_cmds # Command to use after uninstallation of a shared archive. postuninstall_cmds=$lt_postuninstall_cmds # Commands used to finish a libtool library installation in a directory. finish_cmds=$lt_finish_cmds # As "finish_cmds", except a single script fragment to be evaled but # not shown. finish_eval=$lt_finish_eval # Whether we should hardcode library paths into libraries. hardcode_into_libs=$hardcode_into_libs # Compile-time system search path for libraries. sys_lib_search_path_spec=$lt_sys_lib_search_path_spec # Run-time system search path for libraries. sys_lib_dlsearch_path_spec=$lt_sys_lib_dlsearch_path_spec # Whether dlopen is supported. dlopen_support=$enable_dlopen # Whether dlopen of programs is supported. dlopen_self=$enable_dlopen_self # Whether dlopen of statically linked programs is supported. dlopen_self_static=$enable_dlopen_self_static # Commands to strip libraries. old_striplib=$lt_old_striplib striplib=$lt_striplib # The linker used to build libraries. LD=$lt_LD # Commands used to build an old-style archive. old_archive_cmds=$lt_old_archive_cmds # A language specific compiler. CC=$lt_compiler # Is the compiler the GNU compiler? with_gcc=$GCC # Compiler flag to turn off builtin functions. no_builtin_flag=$lt_lt_prog_compiler_no_builtin_flag # How to pass a linker flag through the compiler. wl=$lt_lt_prog_compiler_wl # Additional compiler flags for building library objects. pic_flag=$lt_lt_prog_compiler_pic # Compiler flag to prevent dynamic linking. link_static_flag=$lt_lt_prog_compiler_static # Does compiler simultaneously support -c and -o options? compiler_c_o=$lt_lt_cv_prog_compiler_c_o # Whether or not to add -lc for building shared libraries. build_libtool_need_lc=$archive_cmds_need_lc # Whether or not to disallow shared libs when runtime libs are static. allow_libtool_libs_with_static_runtimes=$enable_shared_with_static_runtimes # Compiler flag to allow reflexive dlopens. export_dynamic_flag_spec=$lt_export_dynamic_flag_spec # Compiler flag to generate shared objects directly from archives. whole_archive_flag_spec=$lt_whole_archive_flag_spec # Whether the compiler copes with passing no objects directly. compiler_needs_object=$lt_compiler_needs_object # Create an old-style archive from a shared archive. old_archive_from_new_cmds=$lt_old_archive_from_new_cmds # Create a temporary old-style archive to link instead of a shared archive. old_archive_from_expsyms_cmds=$lt_old_archive_from_expsyms_cmds # Commands used to build a shared archive. archive_cmds=$lt_archive_cmds archive_expsym_cmds=$lt_archive_expsym_cmds # Commands used to build a loadable module if different from building # a shared archive. module_cmds=$lt_module_cmds module_expsym_cmds=$lt_module_expsym_cmds # Whether we are building with GNU ld or not. with_gnu_ld=$lt_with_gnu_ld # Flag that allows shared libraries with undefined symbols to be built. allow_undefined_flag=$lt_allow_undefined_flag # Flag that enforces no undefined symbols. no_undefined_flag=$lt_no_undefined_flag # Flag to hardcode \$libdir into a binary during linking. # This must work even if \$libdir does not exist hardcode_libdir_flag_spec=$lt_hardcode_libdir_flag_spec # If ld is used when linking, flag to hardcode \$libdir into a binary # during linking. This must work even if \$libdir does not exist. hardcode_libdir_flag_spec_ld=$lt_hardcode_libdir_flag_spec_ld # Whether we need a single "-rpath" flag with a separated argument. hardcode_libdir_separator=$lt_hardcode_libdir_separator # Set to "yes" if using DIR/libNAME\${shared_ext} during linking hardcodes # DIR into the resulting binary. hardcode_direct=$hardcode_direct # Set to "yes" if using DIR/libNAME\${shared_ext} during linking hardcodes # DIR into the resulting binary and the resulting library dependency is # "absolute",i.e impossible to change by setting \${shlibpath_var} if the # library is relocated. hardcode_direct_absolute=$hardcode_direct_absolute # Set to "yes" if using the -LDIR flag during linking hardcodes DIR # into the resulting binary. hardcode_minus_L=$hardcode_minus_L # Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR # into the resulting binary. hardcode_shlibpath_var=$hardcode_shlibpath_var # Set to "yes" if building a shared library automatically hardcodes DIR # into the library and all subsequent libraries and executables linked # against it. hardcode_automatic=$hardcode_automatic # Set to yes if linker adds runtime paths of dependent libraries # to runtime path list. inherit_rpath=$inherit_rpath # Whether libtool must link a program against all its dependency libraries. link_all_deplibs=$link_all_deplibs # Fix the shell variable \$srcfile for the compiler. fix_srcfile_path=$lt_fix_srcfile_path # Set to "yes" if exported symbols are required. always_export_symbols=$always_export_symbols # The commands to list exported symbols. export_symbols_cmds=$lt_export_symbols_cmds # Symbols that should not be listed in the preloaded symbols. exclude_expsyms=$lt_exclude_expsyms # Symbols that must always be exported. include_expsyms=$lt_include_expsyms # Commands necessary for linking programs (against libraries) with templates. prelink_cmds=$lt_prelink_cmds # Specify filename containing input files. file_list_spec=$lt_file_list_spec # How to hardcode a shared library path into an executable. hardcode_action=$hardcode_action # ### END LIBTOOL CONFIG _LT_EOF case $host_os in aix3*) cat <<\_LT_EOF >> "$cfgfile" # AIX sometimes has problems with the GCC collect2 program. For some # reason, if we set the COLLECT_NAMES environment variable, the problems # vanish in a puff of smoke. if test "X${COLLECT_NAMES+set}" != Xset; then COLLECT_NAMES= export COLLECT_NAMES fi _LT_EOF ;; esac ltmain="$ac_aux_dir/ltmain.sh" # We use sed instead of cat because bash on DJGPP gets confused if # if finds mixed CR/LF and LF-only lines. Since sed operates in # text mode, it properly converts lines to CR/LF. This bash problem # is reportedly fixed, but why not run on old versions too? sed '/^# Generated shell functions inserted here/q' "$ltmain" >> "$cfgfile" \ || (rm -f "$cfgfile"; exit 1) case $xsi_shell in yes) cat << \_LT_EOF >> "$cfgfile" # func_dirname file append nondir_replacement # Compute the dirname of FILE. If nonempty, add APPEND to the result, # otherwise set result to NONDIR_REPLACEMENT. func_dirname () { case ${1} in */*) func_dirname_result="${1%/*}${2}" ;; * ) func_dirname_result="${3}" ;; esac } # func_basename file func_basename () { func_basename_result="${1##*/}" } # func_dirname_and_basename file append nondir_replacement # perform func_basename and func_dirname in a single function # call: # dirname: Compute the dirname of FILE. If nonempty, # add APPEND to the result, otherwise set result # to NONDIR_REPLACEMENT. # value returned in "$func_dirname_result" # basename: Compute filename of FILE. # value retuned in "$func_basename_result" # Implementation must be kept synchronized with func_dirname # and func_basename. For efficiency, we do not delegate to # those functions but instead duplicate the functionality here. func_dirname_and_basename () { case ${1} in */*) func_dirname_result="${1%/*}${2}" ;; * ) func_dirname_result="${3}" ;; esac func_basename_result="${1##*/}" } # func_stripname prefix suffix name # strip PREFIX and SUFFIX off of NAME. # PREFIX and SUFFIX must not contain globbing or regex special # characters, hashes, percent signs, but SUFFIX may contain a leading # dot (in which case that matches only a dot). func_stripname () { # pdksh 5.2.14 does not do ${X%$Y} correctly if both X and Y are # positional parameters, so assign one to ordinary parameter first. func_stripname_result=${3} func_stripname_result=${func_stripname_result#"${1}"} func_stripname_result=${func_stripname_result%"${2}"} } # func_opt_split func_opt_split () { func_opt_split_opt=${1%%=*} func_opt_split_arg=${1#*=} } # func_lo2o object func_lo2o () { case ${1} in *.lo) func_lo2o_result=${1%.lo}.${objext} ;; *) func_lo2o_result=${1} ;; esac } # func_xform libobj-or-source func_xform () { func_xform_result=${1%.*}.lo } # func_arith arithmetic-term... func_arith () { func_arith_result=$(( $* )) } # func_len string # STRING may not start with a hyphen. func_len () { func_len_result=${#1} } _LT_EOF ;; *) # Bourne compatible functions. cat << \_LT_EOF >> "$cfgfile" # func_dirname file append nondir_replacement # Compute the dirname of FILE. If nonempty, add APPEND to the result, # otherwise set result to NONDIR_REPLACEMENT. func_dirname () { # Extract subdirectory from the argument. func_dirname_result=`$ECHO "X${1}" | $Xsed -e "$dirname"` if test "X$func_dirname_result" = "X${1}"; then func_dirname_result="${3}" else func_dirname_result="$func_dirname_result${2}" fi } # func_basename file func_basename () { func_basename_result=`$ECHO "X${1}" | $Xsed -e "$basename"` } # func_stripname prefix suffix name # strip PREFIX and SUFFIX off of NAME. # PREFIX and SUFFIX must not contain globbing or regex special # characters, hashes, percent signs, but SUFFIX may contain a leading # dot (in which case that matches only a dot). # func_strip_suffix prefix name func_stripname () { case ${2} in .*) func_stripname_result=`$ECHO "X${3}" \ | $Xsed -e "s%^${1}%%" -e "s%\\\\${2}\$%%"`;; *) func_stripname_result=`$ECHO "X${3}" \ | $Xsed -e "s%^${1}%%" -e "s%${2}\$%%"`;; esac } # sed scripts: my_sed_long_opt='1s/^\(-[^=]*\)=.*/\1/;q' my_sed_long_arg='1s/^-[^=]*=//' # func_opt_split func_opt_split () { func_opt_split_opt=`$ECHO "X${1}" | $Xsed -e "$my_sed_long_opt"` func_opt_split_arg=`$ECHO "X${1}" | $Xsed -e "$my_sed_long_arg"` } # func_lo2o object func_lo2o () { func_lo2o_result=`$ECHO "X${1}" | $Xsed -e "$lo2o"` } # func_xform libobj-or-source func_xform () { func_xform_result=`$ECHO "X${1}" | $Xsed -e 's/\.[^.]*$/.lo/'` } # func_arith arithmetic-term... func_arith () { func_arith_result=`expr "$@"` } # func_len string # STRING may not start with a hyphen. func_len () { func_len_result=`expr "$1" : ".*" 2>/dev/null || echo $max_cmd_len` } _LT_EOF esac case $lt_shell_append in yes) cat << \_LT_EOF >> "$cfgfile" # func_append var value # Append VALUE to the end of shell variable VAR. func_append () { eval "$1+=\$2" } _LT_EOF ;; *) cat << \_LT_EOF >> "$cfgfile" # func_append var value # Append VALUE to the end of shell variable VAR. func_append () { eval "$1=\$$1\$2" } _LT_EOF ;; esac sed -n '/^# Generated shell functions inserted here/,$p' "$ltmain" >> "$cfgfile" \ || (rm -f "$cfgfile"; exit 1) mv -f "$cfgfile" "$ofile" || (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile") chmod +x "$ofile" ;; "default":C) rm -f rules.mk ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit $? fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi mv librep.ebuild librep-$version.ebuild if test "$with_gmp" != "no" && test "$found_gmp" == "yes" ; then with_gmp=yes else with_gmp=no fi if test "$with_readline" != "no" && test "$found_readline" == "yes"; then with_readline=yes else with_readline=no fi if test "$with_libffi" != "no" && test "$found_ffi" == "yes"; then with_ffi=yes else with_ffi=no fi echo " == == == == == == == == == == == == == librep: $version == == == == == == == == == == == == == prefix: $prefix exec_prefix: $exec_prefix libdir: $libdir libexecdir: $libexecdir == == == == == == == == == == == == == compiler: $CC cflags: $CFLAGS $DEVELOPMENT_CFLAGS preprocessor: $CPP cppflags: $CPPFLAGS ldflags: $LDFLAGS makeflags: $MAKEFLAGS == == == == == == == == == == == == == libgmp: $with_gmp libgdbm: yes readline: $with_readline libffi: $with_ffi == == == == == == == == == == == == == " tem=`make --version -f /dev/null 2>&1 | grep GNU` if test "x$tem" = "x"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: You need to use GNU Make when compiling" >&5 $as_echo "$as_me: WARNING: You need to use GNU Make when compiling" >&2;} fi librep-0.90.2/ltmain.sh0000755000175200017520000073337411245011162013722 0ustar chrischris# Generated from ltmain.m4sh. # ltmain.sh (GNU libtool) 2.2.6 # Written by Gordon Matzigkeit , 1996 # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007 2008 Free Software Foundation, Inc. # This is free software; see the source for copying conditions. There is NO # warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # GNU Libtool is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # As a special exception to the GNU General Public License, # if you distribute this file as part of a program or library that # is built using GNU Libtool, you may include this file under the # same distribution terms that you use for the rest of that program. # # GNU Libtool is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with GNU Libtool; see the file COPYING. If not, a copy # can be downloaded from http://www.gnu.org/licenses/gpl.html, # or obtained by writing to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. # Usage: $progname [OPTION]... [MODE-ARG]... # # Provide generalized library-building support services. # # --config show all configuration variables # --debug enable verbose shell tracing # -n, --dry-run display commands without modifying any files # --features display basic configuration information and exit # --mode=MODE use operation mode MODE # --preserve-dup-deps don't remove duplicate dependency libraries # --quiet, --silent don't print informational messages # --tag=TAG use configuration variables from tag TAG # -v, --verbose print informational messages (default) # --version print version information # -h, --help print short or long help message # # MODE must be one of the following: # # clean remove files from the build directory # compile compile a source file into a libtool object # execute automatically set library path, then run a program # finish complete the installation of libtool libraries # install install libraries or executables # link create a library or an executable # uninstall remove libraries from an installed directory # # MODE-ARGS vary depending on the MODE. # Try `$progname --help --mode=MODE' for a more detailed description of MODE. # # When reporting a bug, please describe a test case to reproduce it and # include the following information: # # host-triplet: $host # shell: $SHELL # compiler: $LTCC # compiler flags: $LTCFLAGS # linker: $LD (gnu? $with_gnu_ld) # $progname: (GNU libtool) 2.2.6 Debian-2.2.6a-4 # automake: $automake_version # autoconf: $autoconf_version # # Report bugs to . PROGRAM=ltmain.sh PACKAGE=libtool VERSION="2.2.6 Debian-2.2.6a-4" TIMESTAMP="" package_revision=1.3012 # Be Bourne compatible if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in *posix*) set -o posix;; esac fi BIN_SH=xpg4; export BIN_SH # for Tru64 DUALCASE=1; export DUALCASE # for MKS sh # NLS nuisances: We save the old values to restore during execute mode. # Only set LANG and LC_ALL to C if already set. # These must not be set unconditionally because not all systems understand # e.g. LANG=C (notably SCO). lt_user_locale= lt_safe_locale= for lt_var in LANG LANGUAGE LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES do eval "if test \"\${$lt_var+set}\" = set; then save_$lt_var=\$$lt_var $lt_var=C export $lt_var lt_user_locale=\"$lt_var=\\\$save_\$lt_var; \$lt_user_locale\" lt_safe_locale=\"$lt_var=C; \$lt_safe_locale\" fi" done $lt_unset CDPATH : ${CP="cp -f"} : ${ECHO="echo"} : ${EGREP="/bin/grep -E"} : ${FGREP="/bin/grep -F"} : ${GREP="/bin/grep"} : ${LN_S="ln -s"} : ${MAKE="make"} : ${MKDIR="mkdir"} : ${MV="mv -f"} : ${RM="rm -f"} : ${SED="/bin/sed"} : ${SHELL="${CONFIG_SHELL-/bin/sh}"} : ${Xsed="$SED -e 1s/^X//"} # Global variables: EXIT_SUCCESS=0 EXIT_FAILURE=1 EXIT_MISMATCH=63 # $? = 63 is used to indicate version mismatch to missing. EXIT_SKIP=77 # $? = 77 is used to indicate a skipped test to automake. exit_status=$EXIT_SUCCESS # Make sure IFS has a sensible default lt_nl=' ' IFS=" $lt_nl" dirname="s,/[^/]*$,," basename="s,^.*/,," # func_dirname_and_basename file append nondir_replacement # perform func_basename and func_dirname in a single function # call: # dirname: Compute the dirname of FILE. If nonempty, # add APPEND to the result, otherwise set result # to NONDIR_REPLACEMENT. # value returned in "$func_dirname_result" # basename: Compute filename of FILE. # value retuned in "$func_basename_result" # Implementation must be kept synchronized with func_dirname # and func_basename. For efficiency, we do not delegate to # those functions but instead duplicate the functionality here. func_dirname_and_basename () { # Extract subdirectory from the argument. func_dirname_result=`$ECHO "X${1}" | $Xsed -e "$dirname"` if test "X$func_dirname_result" = "X${1}"; then func_dirname_result="${3}" else func_dirname_result="$func_dirname_result${2}" fi func_basename_result=`$ECHO "X${1}" | $Xsed -e "$basename"` } # Generated shell functions inserted here. # Work around backward compatibility issue on IRIX 6.5. On IRIX 6.4+, sh # is ksh but when the shell is invoked as "sh" and the current value of # the _XPG environment variable is not equal to 1 (one), the special # positional parameter $0, within a function call, is the name of the # function. progpath="$0" # The name of this program: # In the unlikely event $progname began with a '-', it would play havoc with # func_echo (imagine progname=-n), so we prepend ./ in that case: func_dirname_and_basename "$progpath" progname=$func_basename_result case $progname in -*) progname=./$progname ;; esac # Make sure we have an absolute path for reexecution: case $progpath in [\\/]*|[A-Za-z]:\\*) ;; *[\\/]*) progdir=$func_dirname_result progdir=`cd "$progdir" && pwd` progpath="$progdir/$progname" ;; *) save_IFS="$IFS" IFS=: for progdir in $PATH; do IFS="$save_IFS" test -x "$progdir/$progname" && break done IFS="$save_IFS" test -n "$progdir" || progdir=`pwd` progpath="$progdir/$progname" ;; esac # Sed substitution that helps us do robust quoting. It backslashifies # metacharacters that are still active within double-quoted strings. Xsed="${SED}"' -e 1s/^X//' sed_quote_subst='s/\([`"$\\]\)/\\\1/g' # Same as above, but do not quote variable references. double_quote_subst='s/\(["`\\]\)/\\\1/g' # Re-`\' parameter expansions in output of double_quote_subst that were # `\'-ed in input to the same. If an odd number of `\' preceded a '$' # in input to double_quote_subst, that '$' was protected from expansion. # Since each input `\' is now two `\'s, look for any number of runs of # four `\'s followed by two `\'s and then a '$'. `\' that '$'. bs='\\' bs2='\\\\' bs4='\\\\\\\\' dollar='\$' sed_double_backslash="\ s/$bs4/&\\ /g s/^$bs2$dollar/$bs&/ s/\\([^$bs]\\)$bs2$dollar/\\1$bs2$bs$dollar/g s/\n//g" # Standard options: opt_dry_run=false opt_help=false opt_quiet=false opt_verbose=false opt_warning=: # func_echo arg... # Echo program name prefixed message, along with the current mode # name if it has been set yet. func_echo () { $ECHO "$progname${mode+: }$mode: $*" } # func_verbose arg... # Echo program name prefixed message in verbose mode only. func_verbose () { $opt_verbose && func_echo ${1+"$@"} # A bug in bash halts the script if the last line of a function # fails when set -e is in force, so we need another command to # work around that: : } # func_error arg... # Echo program name prefixed message to standard error. func_error () { $ECHO "$progname${mode+: }$mode: "${1+"$@"} 1>&2 } # func_warning arg... # Echo program name prefixed warning message to standard error. func_warning () { $opt_warning && $ECHO "$progname${mode+: }$mode: warning: "${1+"$@"} 1>&2 # bash bug again: : } # func_fatal_error arg... # Echo program name prefixed message to standard error, and exit. func_fatal_error () { func_error ${1+"$@"} exit $EXIT_FAILURE } # func_fatal_help arg... # Echo program name prefixed message to standard error, followed by # a help hint, and exit. func_fatal_help () { func_error ${1+"$@"} func_fatal_error "$help" } help="Try \`$progname --help' for more information." ## default # func_grep expression filename # Check whether EXPRESSION matches any line of FILENAME, without output. func_grep () { $GREP "$1" "$2" >/dev/null 2>&1 } # func_mkdir_p directory-path # Make sure the entire path to DIRECTORY-PATH is available. func_mkdir_p () { my_directory_path="$1" my_dir_list= if test -n "$my_directory_path" && test "$opt_dry_run" != ":"; then # Protect directory names starting with `-' case $my_directory_path in -*) my_directory_path="./$my_directory_path" ;; esac # While some portion of DIR does not yet exist... while test ! -d "$my_directory_path"; do # ...make a list in topmost first order. Use a colon delimited # list incase some portion of path contains whitespace. my_dir_list="$my_directory_path:$my_dir_list" # If the last portion added has no slash in it, the list is done case $my_directory_path in */*) ;; *) break ;; esac # ...otherwise throw away the child directory and loop my_directory_path=`$ECHO "X$my_directory_path" | $Xsed -e "$dirname"` done my_dir_list=`$ECHO "X$my_dir_list" | $Xsed -e 's,:*$,,'` save_mkdir_p_IFS="$IFS"; IFS=':' for my_dir in $my_dir_list; do IFS="$save_mkdir_p_IFS" # mkdir can fail with a `File exist' error if two processes # try to create one of the directories concurrently. Don't # stop in that case! $MKDIR "$my_dir" 2>/dev/null || : done IFS="$save_mkdir_p_IFS" # Bail out if we (or some other process) failed to create a directory. test -d "$my_directory_path" || \ func_fatal_error "Failed to create \`$1'" fi } # func_mktempdir [string] # Make a temporary directory that won't clash with other running # libtool processes, and avoids race conditions if possible. If # given, STRING is the basename for that directory. func_mktempdir () { my_template="${TMPDIR-/tmp}/${1-$progname}" if test "$opt_dry_run" = ":"; then # Return a directory name, but don't create it in dry-run mode my_tmpdir="${my_template}-$$" else # If mktemp works, use that first and foremost my_tmpdir=`mktemp -d "${my_template}-XXXXXXXX" 2>/dev/null` if test ! -d "$my_tmpdir"; then # Failing that, at least try and use $RANDOM to avoid a race my_tmpdir="${my_template}-${RANDOM-0}$$" save_mktempdir_umask=`umask` umask 0077 $MKDIR "$my_tmpdir" umask $save_mktempdir_umask fi # If we're not in dry-run mode, bomb out on failure test -d "$my_tmpdir" || \ func_fatal_error "cannot create temporary directory \`$my_tmpdir'" fi $ECHO "X$my_tmpdir" | $Xsed } # func_quote_for_eval arg # Aesthetically quote ARG to be evaled later. # This function returns two values: FUNC_QUOTE_FOR_EVAL_RESULT # is double-quoted, suitable for a subsequent eval, whereas # FUNC_QUOTE_FOR_EVAL_UNQUOTED_RESULT has merely all characters # which are still active within double quotes backslashified. func_quote_for_eval () { case $1 in *[\\\`\"\$]*) func_quote_for_eval_unquoted_result=`$ECHO "X$1" | $Xsed -e "$sed_quote_subst"` ;; *) func_quote_for_eval_unquoted_result="$1" ;; esac case $func_quote_for_eval_unquoted_result in # Double-quote args containing shell metacharacters to delay # word splitting, command substitution and and variable # expansion for a subsequent eval. # Many Bourne shells cannot handle close brackets correctly # in scan sets, so we specify it separately. *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") func_quote_for_eval_result="\"$func_quote_for_eval_unquoted_result\"" ;; *) func_quote_for_eval_result="$func_quote_for_eval_unquoted_result" esac } # func_quote_for_expand arg # Aesthetically quote ARG to be evaled later; same as above, # but do not quote variable references. func_quote_for_expand () { case $1 in *[\\\`\"]*) my_arg=`$ECHO "X$1" | $Xsed \ -e "$double_quote_subst" -e "$sed_double_backslash"` ;; *) my_arg="$1" ;; esac case $my_arg in # Double-quote args containing shell metacharacters to delay # word splitting and command substitution for a subsequent eval. # Many Bourne shells cannot handle close brackets correctly # in scan sets, so we specify it separately. *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") my_arg="\"$my_arg\"" ;; esac func_quote_for_expand_result="$my_arg" } # func_show_eval cmd [fail_exp] # Unless opt_silent is true, then output CMD. Then, if opt_dryrun is # not true, evaluate CMD. If the evaluation of CMD fails, and FAIL_EXP # is given, then evaluate it. func_show_eval () { my_cmd="$1" my_fail_exp="${2-:}" ${opt_silent-false} || { func_quote_for_expand "$my_cmd" eval "func_echo $func_quote_for_expand_result" } if ${opt_dry_run-false}; then :; else eval "$my_cmd" my_status=$? if test "$my_status" -eq 0; then :; else eval "(exit $my_status); $my_fail_exp" fi fi } # func_show_eval_locale cmd [fail_exp] # Unless opt_silent is true, then output CMD. Then, if opt_dryrun is # not true, evaluate CMD. If the evaluation of CMD fails, and FAIL_EXP # is given, then evaluate it. Use the saved locale for evaluation. func_show_eval_locale () { my_cmd="$1" my_fail_exp="${2-:}" ${opt_silent-false} || { func_quote_for_expand "$my_cmd" eval "func_echo $func_quote_for_expand_result" } if ${opt_dry_run-false}; then :; else eval "$lt_user_locale $my_cmd" my_status=$? eval "$lt_safe_locale" if test "$my_status" -eq 0; then :; else eval "(exit $my_status); $my_fail_exp" fi fi } # func_version # Echo version message to standard output and exit. func_version () { $SED -n '/^# '$PROGRAM' (GNU /,/# warranty; / { s/^# // s/^# *$// s/\((C)\)[ 0-9,-]*\( [1-9][0-9]*\)/\1\2/ p }' < "$progpath" exit $? } # func_usage # Echo short help message to standard output and exit. func_usage () { $SED -n '/^# Usage:/,/# -h/ { s/^# // s/^# *$// s/\$progname/'$progname'/ p }' < "$progpath" $ECHO $ECHO "run \`$progname --help | more' for full usage" exit $? } # func_help # Echo long help message to standard output and exit. func_help () { $SED -n '/^# Usage:/,/# Report bugs to/ { s/^# // s/^# *$// s*\$progname*'$progname'* s*\$host*'"$host"'* s*\$SHELL*'"$SHELL"'* s*\$LTCC*'"$LTCC"'* s*\$LTCFLAGS*'"$LTCFLAGS"'* s*\$LD*'"$LD"'* s/\$with_gnu_ld/'"$with_gnu_ld"'/ s/\$automake_version/'"`(automake --version) 2>/dev/null |$SED 1q`"'/ s/\$autoconf_version/'"`(autoconf --version) 2>/dev/null |$SED 1q`"'/ p }' < "$progpath" exit $? } # func_missing_arg argname # Echo program name prefixed message to standard error and set global # exit_cmd. func_missing_arg () { func_error "missing argument for $1" exit_cmd=exit } exit_cmd=: # Check that we have a working $ECHO. if test "X$1" = X--no-reexec; then # Discard the --no-reexec flag, and continue. shift elif test "X$1" = X--fallback-echo; then # Avoid inline document here, it may be left over : elif test "X`{ $ECHO '\t'; } 2>/dev/null`" = 'X\t'; then # Yippee, $ECHO works! : else # Restart under the correct shell, and then maybe $ECHO will work. exec $SHELL "$progpath" --no-reexec ${1+"$@"} fi if test "X$1" = X--fallback-echo; then # used as fallback echo shift cat </dev/null 2>&1; then taglist="$taglist $tagname" # Evaluate the configuration. Be careful to quote the path # and the sed script, to avoid splitting on whitespace, but # also don't use non-portable quotes within backquotes within # quotes we have to do it in 2 steps: extractedcf=`$SED -n -e "$sed_extractcf" < "$progpath"` eval "$extractedcf" else func_error "ignoring unknown tag $tagname" fi ;; esac } # Parse options once, thoroughly. This comes as soon as possible in # the script to make things like `libtool --version' happen quickly. { # Shorthand for --mode=foo, only valid as the first argument case $1 in clean|clea|cle|cl) shift; set dummy --mode clean ${1+"$@"}; shift ;; compile|compil|compi|comp|com|co|c) shift; set dummy --mode compile ${1+"$@"}; shift ;; execute|execut|execu|exec|exe|ex|e) shift; set dummy --mode execute ${1+"$@"}; shift ;; finish|finis|fini|fin|fi|f) shift; set dummy --mode finish ${1+"$@"}; shift ;; install|instal|insta|inst|ins|in|i) shift; set dummy --mode install ${1+"$@"}; shift ;; link|lin|li|l) shift; set dummy --mode link ${1+"$@"}; shift ;; uninstall|uninstal|uninsta|uninst|unins|unin|uni|un|u) shift; set dummy --mode uninstall ${1+"$@"}; shift ;; esac # Parse non-mode specific arguments: while test "$#" -gt 0; do opt="$1" shift case $opt in --config) func_config ;; --debug) preserve_args="$preserve_args $opt" func_echo "enabling shell trace mode" opt_debug='set -x' $opt_debug ;; -dlopen) test "$#" -eq 0 && func_missing_arg "$opt" && break execute_dlfiles="$execute_dlfiles $1" shift ;; --dry-run | -n) opt_dry_run=: ;; --features) func_features ;; --finish) mode="finish" ;; --mode) test "$#" -eq 0 && func_missing_arg "$opt" && break case $1 in # Valid mode arguments: clean) ;; compile) ;; execute) ;; finish) ;; install) ;; link) ;; relink) ;; uninstall) ;; # Catch anything else as an error *) func_error "invalid argument for $opt" exit_cmd=exit break ;; esac mode="$1" shift ;; --preserve-dup-deps) opt_duplicate_deps=: ;; --quiet|--silent) preserve_args="$preserve_args $opt" opt_silent=: ;; --verbose| -v) preserve_args="$preserve_args $opt" opt_silent=false ;; --tag) test "$#" -eq 0 && func_missing_arg "$opt" && break preserve_args="$preserve_args $opt $1" func_enable_tag "$1" # tagname is set here shift ;; # Separate optargs to long options: -dlopen=*|--mode=*|--tag=*) func_opt_split "$opt" set dummy "$func_opt_split_opt" "$func_opt_split_arg" ${1+"$@"} shift ;; -\?|-h) func_usage ;; --help) opt_help=: ;; --version) func_version ;; -*) func_fatal_help "unrecognized option \`$opt'" ;; *) nonopt="$opt" break ;; esac done case $host in *cygwin* | *mingw* | *pw32* | *cegcc*) # don't eliminate duplications in $postdeps and $predeps opt_duplicate_compiler_generated_deps=: ;; *) opt_duplicate_compiler_generated_deps=$opt_duplicate_deps ;; esac # Having warned about all mis-specified options, bail out if # anything was wrong. $exit_cmd $EXIT_FAILURE } # func_check_version_match # Ensure that we are using m4 macros, and libtool script from the same # release of libtool. func_check_version_match () { if test "$package_revision" != "$macro_revision"; then if test "$VERSION" != "$macro_version"; then if test -z "$macro_version"; then cat >&2 <<_LT_EOF $progname: Version mismatch error. This is $PACKAGE $VERSION, but the $progname: definition of this LT_INIT comes from an older release. $progname: You should recreate aclocal.m4 with macros from $PACKAGE $VERSION $progname: and run autoconf again. _LT_EOF else cat >&2 <<_LT_EOF $progname: Version mismatch error. This is $PACKAGE $VERSION, but the $progname: definition of this LT_INIT comes from $PACKAGE $macro_version. $progname: You should recreate aclocal.m4 with macros from $PACKAGE $VERSION $progname: and run autoconf again. _LT_EOF fi else cat >&2 <<_LT_EOF $progname: Version mismatch error. This is $PACKAGE $VERSION, revision $package_revision, $progname: but the definition of this LT_INIT comes from revision $macro_revision. $progname: You should recreate aclocal.m4 with macros from revision $package_revision $progname: of $PACKAGE $VERSION and run autoconf again. _LT_EOF fi exit $EXIT_MISMATCH fi } ## ----------- ## ## Main. ## ## ----------- ## $opt_help || { # Sanity checks first: func_check_version_match if test "$build_libtool_libs" != yes && test "$build_old_libs" != yes; then func_fatal_configuration "not configured to build any kind of library" fi test -z "$mode" && func_fatal_error "error: you must specify a MODE." # Darwin sucks eval std_shrext=\"$shrext_cmds\" # Only execute mode is allowed to have -dlopen flags. if test -n "$execute_dlfiles" && test "$mode" != execute; then func_error "unrecognized option \`-dlopen'" $ECHO "$help" 1>&2 exit $EXIT_FAILURE fi # Change the help message to a mode-specific one. generic_help="$help" help="Try \`$progname --help --mode=$mode' for more information." } # func_lalib_p file # True iff FILE is a libtool `.la' library or `.lo' object file. # This function is only a basic sanity check; it will hardly flush out # determined imposters. func_lalib_p () { test -f "$1" && $SED -e 4q "$1" 2>/dev/null \ | $GREP "^# Generated by .*$PACKAGE" > /dev/null 2>&1 } # func_lalib_unsafe_p file # True iff FILE is a libtool `.la' library or `.lo' object file. # This function implements the same check as func_lalib_p without # resorting to external programs. To this end, it redirects stdin and # closes it afterwards, without saving the original file descriptor. # As a safety measure, use it only where a negative result would be # fatal anyway. Works if `file' does not exist. func_lalib_unsafe_p () { lalib_p=no if test -f "$1" && test -r "$1" && exec 5<&0 <"$1"; then for lalib_p_l in 1 2 3 4 do read lalib_p_line case "$lalib_p_line" in \#\ Generated\ by\ *$PACKAGE* ) lalib_p=yes; break;; esac done exec 0<&5 5<&- fi test "$lalib_p" = yes } # func_ltwrapper_script_p file # True iff FILE is a libtool wrapper script # This function is only a basic sanity check; it will hardly flush out # determined imposters. func_ltwrapper_script_p () { func_lalib_p "$1" } # func_ltwrapper_executable_p file # True iff FILE is a libtool wrapper executable # This function is only a basic sanity check; it will hardly flush out # determined imposters. func_ltwrapper_executable_p () { func_ltwrapper_exec_suffix= case $1 in *.exe) ;; *) func_ltwrapper_exec_suffix=.exe ;; esac $GREP "$magic_exe" "$1$func_ltwrapper_exec_suffix" >/dev/null 2>&1 } # func_ltwrapper_scriptname file # Assumes file is an ltwrapper_executable # uses $file to determine the appropriate filename for a # temporary ltwrapper_script. func_ltwrapper_scriptname () { func_ltwrapper_scriptname_result="" if func_ltwrapper_executable_p "$1"; then func_dirname_and_basename "$1" "" "." func_stripname '' '.exe' "$func_basename_result" func_ltwrapper_scriptname_result="$func_dirname_result/$objdir/${func_stripname_result}_ltshwrapper" fi } # func_ltwrapper_p file # True iff FILE is a libtool wrapper script or wrapper executable # This function is only a basic sanity check; it will hardly flush out # determined imposters. func_ltwrapper_p () { func_ltwrapper_script_p "$1" || func_ltwrapper_executable_p "$1" } # func_execute_cmds commands fail_cmd # Execute tilde-delimited COMMANDS. # If FAIL_CMD is given, eval that upon failure. # FAIL_CMD may read-access the current command in variable CMD! func_execute_cmds () { $opt_debug save_ifs=$IFS; IFS='~' for cmd in $1; do IFS=$save_ifs eval cmd=\"$cmd\" func_show_eval "$cmd" "${2-:}" done IFS=$save_ifs } # func_source file # Source FILE, adding directory component if necessary. # Note that it is not necessary on cygwin/mingw to append a dot to # FILE even if both FILE and FILE.exe exist: automatic-append-.exe # behavior happens only for exec(3), not for open(2)! Also, sourcing # `FILE.' does not work on cygwin managed mounts. func_source () { $opt_debug case $1 in */* | *\\*) . "$1" ;; *) . "./$1" ;; esac } # func_infer_tag arg # Infer tagged configuration to use if any are available and # if one wasn't chosen via the "--tag" command line option. # Only attempt this if the compiler in the base compile # command doesn't match the default compiler. # arg is usually of the form 'gcc ...' func_infer_tag () { $opt_debug if test -n "$available_tags" && test -z "$tagname"; then CC_quoted= for arg in $CC; do func_quote_for_eval "$arg" CC_quoted="$CC_quoted $func_quote_for_eval_result" done case $@ in # Blanks in the command may have been stripped by the calling shell, # but not from the CC environment variable when configure was run. " $CC "* | "$CC "* | " `$ECHO $CC` "* | "`$ECHO $CC` "* | " $CC_quoted"* | "$CC_quoted "* | " `$ECHO $CC_quoted` "* | "`$ECHO $CC_quoted` "*) ;; # Blanks at the start of $base_compile will cause this to fail # if we don't check for them as well. *) for z in $available_tags; do if $GREP "^# ### BEGIN LIBTOOL TAG CONFIG: $z$" < "$progpath" > /dev/null; then # Evaluate the configuration. eval "`${SED} -n -e '/^# ### BEGIN LIBTOOL TAG CONFIG: '$z'$/,/^# ### END LIBTOOL TAG CONFIG: '$z'$/p' < $progpath`" CC_quoted= for arg in $CC; do # Double-quote args containing other shell metacharacters. func_quote_for_eval "$arg" CC_quoted="$CC_quoted $func_quote_for_eval_result" done case "$@ " in " $CC "* | "$CC "* | " `$ECHO $CC` "* | "`$ECHO $CC` "* | " $CC_quoted"* | "$CC_quoted "* | " `$ECHO $CC_quoted` "* | "`$ECHO $CC_quoted` "*) # The compiler in the base compile command matches # the one in the tagged configuration. # Assume this is the tagged configuration we want. tagname=$z break ;; esac fi done # If $tagname still isn't set, then no tagged configuration # was found and let the user know that the "--tag" command # line option must be used. if test -z "$tagname"; then func_echo "unable to infer tagged configuration" func_fatal_error "specify a tag with \`--tag'" # else # func_verbose "using $tagname tagged configuration" fi ;; esac fi } # func_write_libtool_object output_name pic_name nonpic_name # Create a libtool object file (analogous to a ".la" file), # but don't create it if we're doing a dry run. func_write_libtool_object () { write_libobj=${1} if test "$build_libtool_libs" = yes; then write_lobj=\'${2}\' else write_lobj=none fi if test "$build_old_libs" = yes; then write_oldobj=\'${3}\' else write_oldobj=none fi $opt_dry_run || { cat >${write_libobj}T <?"'"'"' &()|`$[]' \ && func_warning "libobj name \`$libobj' may not contain shell special characters." func_dirname_and_basename "$obj" "/" "" objname="$func_basename_result" xdir="$func_dirname_result" lobj=${xdir}$objdir/$objname test -z "$base_compile" && \ func_fatal_help "you must specify a compilation command" # Delete any leftover library objects. if test "$build_old_libs" = yes; then removelist="$obj $lobj $libobj ${libobj}T" else removelist="$lobj $libobj ${libobj}T" fi # On Cygwin there's no "real" PIC flag so we must build both object types case $host_os in cygwin* | mingw* | pw32* | os2* | cegcc*) pic_mode=default ;; esac if test "$pic_mode" = no && test "$deplibs_check_method" != pass_all; then # non-PIC code in shared libraries is not supported pic_mode=default fi # Calculate the filename of the output object if compiler does # not support -o with -c if test "$compiler_c_o" = no; then output_obj=`$ECHO "X$srcfile" | $Xsed -e 's%^.*/%%' -e 's%\.[^.]*$%%'`.${objext} lockfile="$output_obj.lock" else output_obj= need_locks=no lockfile= fi # Lock this critical section if it is needed # We use this script file to make the link, it avoids creating a new file if test "$need_locks" = yes; then until $opt_dry_run || ln "$progpath" "$lockfile" 2>/dev/null; do func_echo "Waiting for $lockfile to be removed" sleep 2 done elif test "$need_locks" = warn; then if test -f "$lockfile"; then $ECHO "\ *** ERROR, $lockfile exists and contains: `cat $lockfile 2>/dev/null` This indicates that another process is trying to use the same temporary object file, and libtool could not work around it because your compiler does not support \`-c' and \`-o' together. If you repeat this compilation, it may succeed, by chance, but you had better avoid parallel builds (make -j) in this platform, or get a better compiler." $opt_dry_run || $RM $removelist exit $EXIT_FAILURE fi removelist="$removelist $output_obj" $ECHO "$srcfile" > "$lockfile" fi $opt_dry_run || $RM $removelist removelist="$removelist $lockfile" trap '$opt_dry_run || $RM $removelist; exit $EXIT_FAILURE' 1 2 15 if test -n "$fix_srcfile_path"; then eval srcfile=\"$fix_srcfile_path\" fi func_quote_for_eval "$srcfile" qsrcfile=$func_quote_for_eval_result # Only build a PIC object if we are building libtool libraries. if test "$build_libtool_libs" = yes; then # Without this assignment, base_compile gets emptied. fbsd_hideous_sh_bug=$base_compile if test "$pic_mode" != no; then command="$base_compile $qsrcfile $pic_flag" else # Don't build PIC code command="$base_compile $qsrcfile" fi func_mkdir_p "$xdir$objdir" if test -z "$output_obj"; then # Place PIC objects in $objdir command="$command -o $lobj" fi func_show_eval_locale "$command" \ 'test -n "$output_obj" && $RM $removelist; exit $EXIT_FAILURE' if test "$need_locks" = warn && test "X`cat $lockfile 2>/dev/null`" != "X$srcfile"; then $ECHO "\ *** ERROR, $lockfile contains: `cat $lockfile 2>/dev/null` but it should contain: $srcfile This indicates that another process is trying to use the same temporary object file, and libtool could not work around it because your compiler does not support \`-c' and \`-o' together. If you repeat this compilation, it may succeed, by chance, but you had better avoid parallel builds (make -j) in this platform, or get a better compiler." $opt_dry_run || $RM $removelist exit $EXIT_FAILURE fi # Just move the object if needed, then go on to compile the next one if test -n "$output_obj" && test "X$output_obj" != "X$lobj"; then func_show_eval '$MV "$output_obj" "$lobj"' \ 'error=$?; $opt_dry_run || $RM $removelist; exit $error' fi # Allow error messages only from the first compilation. if test "$suppress_opt" = yes; then suppress_output=' >/dev/null 2>&1' fi fi # Only build a position-dependent object if we build old libraries. if test "$build_old_libs" = yes; then if test "$pic_mode" != yes; then # Don't build PIC code command="$base_compile $qsrcfile$pie_flag" else command="$base_compile $qsrcfile $pic_flag" fi if test "$compiler_c_o" = yes; then command="$command -o $obj" fi # Suppress compiler output if we already did a PIC compilation. command="$command$suppress_output" func_show_eval_locale "$command" \ '$opt_dry_run || $RM $removelist; exit $EXIT_FAILURE' if test "$need_locks" = warn && test "X`cat $lockfile 2>/dev/null`" != "X$srcfile"; then $ECHO "\ *** ERROR, $lockfile contains: `cat $lockfile 2>/dev/null` but it should contain: $srcfile This indicates that another process is trying to use the same temporary object file, and libtool could not work around it because your compiler does not support \`-c' and \`-o' together. If you repeat this compilation, it may succeed, by chance, but you had better avoid parallel builds (make -j) in this platform, or get a better compiler." $opt_dry_run || $RM $removelist exit $EXIT_FAILURE fi # Just move the object if needed if test -n "$output_obj" && test "X$output_obj" != "X$obj"; then func_show_eval '$MV "$output_obj" "$obj"' \ 'error=$?; $opt_dry_run || $RM $removelist; exit $error' fi fi $opt_dry_run || { func_write_libtool_object "$libobj" "$objdir/$objname" "$objname" # Unlock the critical section if it was locked if test "$need_locks" != no; then removelist=$lockfile $RM "$lockfile" fi } exit $EXIT_SUCCESS } $opt_help || { test "$mode" = compile && func_mode_compile ${1+"$@"} } func_mode_help () { # We need to display help for each of the modes. case $mode in "") # Generic help is extracted from the usage comments # at the start of this file. func_help ;; clean) $ECHO \ "Usage: $progname [OPTION]... --mode=clean RM [RM-OPTION]... FILE... Remove files from the build directory. RM is the name of the program to use to delete files associated with each FILE (typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed to RM. If FILE is a libtool library, object or program, all the files associated with it are deleted. Otherwise, only FILE itself is deleted using RM." ;; compile) $ECHO \ "Usage: $progname [OPTION]... --mode=compile COMPILE-COMMAND... SOURCEFILE Compile a source file into a libtool library object. This mode accepts the following additional options: -o OUTPUT-FILE set the output file name to OUTPUT-FILE -no-suppress do not suppress compiler output for multiple passes -prefer-pic try to building PIC objects only -prefer-non-pic try to building non-PIC objects only -shared do not build a \`.o' file suitable for static linking -static only build a \`.o' file suitable for static linking COMPILE-COMMAND is a command to be used in creating a \`standard' object file from the given SOURCEFILE. The output file name is determined by removing the directory component from SOURCEFILE, then substituting the C source code suffix \`.c' with the library object suffix, \`.lo'." ;; execute) $ECHO \ "Usage: $progname [OPTION]... --mode=execute COMMAND [ARGS]... Automatically set library path, then run a program. This mode accepts the following additional options: -dlopen FILE add the directory containing FILE to the library path This mode sets the library path environment variable according to \`-dlopen' flags. If any of the ARGS are libtool executable wrappers, then they are translated into their corresponding uninstalled binary, and any of their required library directories are added to the library path. Then, COMMAND is executed, with ARGS as arguments." ;; finish) $ECHO \ "Usage: $progname [OPTION]... --mode=finish [LIBDIR]... Complete the installation of libtool libraries. Each LIBDIR is a directory that contains libtool libraries. The commands that this mode executes may require superuser privileges. Use the \`--dry-run' option if you just want to see what would be executed." ;; install) $ECHO \ "Usage: $progname [OPTION]... --mode=install INSTALL-COMMAND... Install executables or libraries. INSTALL-COMMAND is the installation command. The first component should be either the \`install' or \`cp' program. The following components of INSTALL-COMMAND are treated specially: -inst-prefix PREFIX-DIR Use PREFIX-DIR as a staging area for installation The rest of the components are interpreted as arguments to that command (only BSD-compatible install options are recognized)." ;; link) $ECHO \ "Usage: $progname [OPTION]... --mode=link LINK-COMMAND... Link object files or libraries together to form another library, or to create an executable program. LINK-COMMAND is a command using the C compiler that you would use to create a program from several object files. The following components of LINK-COMMAND are treated specially: -all-static do not do any dynamic linking at all -avoid-version do not add a version suffix if possible -dlopen FILE \`-dlpreopen' FILE if it cannot be dlopened at runtime -dlpreopen FILE link in FILE and add its symbols to lt_preloaded_symbols -export-dynamic allow symbols from OUTPUT-FILE to be resolved with dlsym(3) -export-symbols SYMFILE try to export only the symbols listed in SYMFILE -export-symbols-regex REGEX try to export only the symbols matching REGEX -LLIBDIR search LIBDIR for required installed libraries -lNAME OUTPUT-FILE requires the installed library libNAME -module build a library that can dlopened -no-fast-install disable the fast-install mode -no-install link a not-installable executable -no-undefined declare that a library does not refer to external symbols -o OUTPUT-FILE create OUTPUT-FILE from the specified objects -objectlist FILE Use a list of object files found in FILE to specify objects -precious-files-regex REGEX don't remove output files matching REGEX -release RELEASE specify package release information -rpath LIBDIR the created library will eventually be installed in LIBDIR -R[ ]LIBDIR add LIBDIR to the runtime path of programs and libraries -shared only do dynamic linking of libtool libraries -shrext SUFFIX override the standard shared library file extension -static do not do any dynamic linking of uninstalled libtool libraries -static-libtool-libs do not do any dynamic linking of libtool libraries -version-info CURRENT[:REVISION[:AGE]] specify library version info [each variable defaults to 0] -weak LIBNAME declare that the target provides the LIBNAME interface All other options (arguments beginning with \`-') are ignored. Every other argument is treated as a filename. Files ending in \`.la' are treated as uninstalled libtool libraries, other files are standard or library object files. If the OUTPUT-FILE ends in \`.la', then a libtool library is created, only library objects (\`.lo' files) may be specified, and \`-rpath' is required, except when creating a convenience library. If OUTPUT-FILE ends in \`.a' or \`.lib', then a standard library is created using \`ar' and \`ranlib', or on Windows using \`lib'. If OUTPUT-FILE ends in \`.lo' or \`.${objext}', then a reloadable object file is created, otherwise an executable program is created." ;; uninstall) $ECHO \ "Usage: $progname [OPTION]... --mode=uninstall RM [RM-OPTION]... FILE... Remove libraries from an installation directory. RM is the name of the program to use to delete files associated with each FILE (typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed to RM. If FILE is a libtool library, all the files associated with it are deleted. Otherwise, only FILE itself is deleted using RM." ;; *) func_fatal_help "invalid operation mode \`$mode'" ;; esac $ECHO $ECHO "Try \`$progname --help' for more information about other modes." exit $? } # Now that we've collected a possible --mode arg, show help if necessary $opt_help && func_mode_help # func_mode_execute arg... func_mode_execute () { $opt_debug # The first argument is the command name. cmd="$nonopt" test -z "$cmd" && \ func_fatal_help "you must specify a COMMAND" # Handle -dlopen flags immediately. for file in $execute_dlfiles; do test -f "$file" \ || func_fatal_help "\`$file' is not a file" dir= case $file in *.la) # Check to see that this really is a libtool archive. func_lalib_unsafe_p "$file" \ || func_fatal_help "\`$lib' is not a valid libtool archive" # Read the libtool library. dlname= library_names= func_source "$file" # Skip this library if it cannot be dlopened. if test -z "$dlname"; then # Warn if it was a shared library. test -n "$library_names" && \ func_warning "\`$file' was not linked with \`-export-dynamic'" continue fi func_dirname "$file" "" "." dir="$func_dirname_result" if test -f "$dir/$objdir/$dlname"; then dir="$dir/$objdir" else if test ! -f "$dir/$dlname"; then func_fatal_error "cannot find \`$dlname' in \`$dir' or \`$dir/$objdir'" fi fi ;; *.lo) # Just add the directory containing the .lo file. func_dirname "$file" "" "." dir="$func_dirname_result" ;; *) func_warning "\`-dlopen' is ignored for non-libtool libraries and objects" continue ;; esac # Get the absolute pathname. absdir=`cd "$dir" && pwd` test -n "$absdir" && dir="$absdir" # Now add the directory to shlibpath_var. if eval "test -z \"\$$shlibpath_var\""; then eval "$shlibpath_var=\"\$dir\"" else eval "$shlibpath_var=\"\$dir:\$$shlibpath_var\"" fi done # This variable tells wrapper scripts just to set shlibpath_var # rather than running their programs. libtool_execute_magic="$magic" # Check if any of the arguments is a wrapper script. args= for file do case $file in -*) ;; *) # Do a test to see if this is really a libtool program. if func_ltwrapper_script_p "$file"; then func_source "$file" # Transform arg to wrapped name. file="$progdir/$program" elif func_ltwrapper_executable_p "$file"; then func_ltwrapper_scriptname "$file" func_source "$func_ltwrapper_scriptname_result" # Transform arg to wrapped name. file="$progdir/$program" fi ;; esac # Quote arguments (to preserve shell metacharacters). func_quote_for_eval "$file" args="$args $func_quote_for_eval_result" done if test "X$opt_dry_run" = Xfalse; then if test -n "$shlibpath_var"; then # Export the shlibpath_var. eval "export $shlibpath_var" fi # Restore saved environment variables for lt_var in LANG LANGUAGE LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES do eval "if test \"\${save_$lt_var+set}\" = set; then $lt_var=\$save_$lt_var; export $lt_var else $lt_unset $lt_var fi" done # Now prepare to actually exec the command. exec_cmd="\$cmd$args" else # Display what would be done. if test -n "$shlibpath_var"; then eval "\$ECHO \"\$shlibpath_var=\$$shlibpath_var\"" $ECHO "export $shlibpath_var" fi $ECHO "$cmd$args" exit $EXIT_SUCCESS fi } test "$mode" = execute && func_mode_execute ${1+"$@"} # func_mode_finish arg... func_mode_finish () { $opt_debug libdirs="$nonopt" admincmds= if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then for dir do libdirs="$libdirs $dir" done for libdir in $libdirs; do if test -n "$finish_cmds"; then # Do each command in the finish commands. func_execute_cmds "$finish_cmds" 'admincmds="$admincmds '"$cmd"'"' fi if test -n "$finish_eval"; then # Do the single finish_eval. eval cmds=\"$finish_eval\" $opt_dry_run || eval "$cmds" || admincmds="$admincmds $cmds" fi done fi # Exit here if they wanted silent mode. $opt_silent && exit $EXIT_SUCCESS $ECHO "X----------------------------------------------------------------------" | $Xsed $ECHO "Libraries have been installed in:" for libdir in $libdirs; do $ECHO " $libdir" done $ECHO $ECHO "If you ever happen to want to link against installed libraries" $ECHO "in a given directory, LIBDIR, you must either use libtool, and" $ECHO "specify the full pathname of the library, or use the \`-LLIBDIR'" $ECHO "flag during linking and do at least one of the following:" if test -n "$shlibpath_var"; then $ECHO " - add LIBDIR to the \`$shlibpath_var' environment variable" $ECHO " during execution" fi if test -n "$runpath_var"; then $ECHO " - add LIBDIR to the \`$runpath_var' environment variable" $ECHO " during linking" fi if test -n "$hardcode_libdir_flag_spec"; then libdir=LIBDIR eval flag=\"$hardcode_libdir_flag_spec\" $ECHO " - use the \`$flag' linker flag" fi if test -n "$admincmds"; then $ECHO " - have your system administrator run these commands:$admincmds" fi if test -f /etc/ld.so.conf; then $ECHO " - have your system administrator add LIBDIR to \`/etc/ld.so.conf'" fi $ECHO $ECHO "See any operating system documentation about shared libraries for" case $host in solaris2.[6789]|solaris2.1[0-9]) $ECHO "more information, such as the ld(1), crle(1) and ld.so(8) manual" $ECHO "pages." ;; *) $ECHO "more information, such as the ld(1) and ld.so(8) manual pages." ;; esac $ECHO "X----------------------------------------------------------------------" | $Xsed exit $EXIT_SUCCESS } test "$mode" = finish && func_mode_finish ${1+"$@"} # func_mode_install arg... func_mode_install () { $opt_debug # There may be an optional sh(1) argument at the beginning of # install_prog (especially on Windows NT). if test "$nonopt" = "$SHELL" || test "$nonopt" = /bin/sh || # Allow the use of GNU shtool's install command. $ECHO "X$nonopt" | $GREP shtool >/dev/null; then # Aesthetically quote it. func_quote_for_eval "$nonopt" install_prog="$func_quote_for_eval_result " arg=$1 shift else install_prog= arg=$nonopt fi # The real first argument should be the name of the installation program. # Aesthetically quote it. func_quote_for_eval "$arg" install_prog="$install_prog$func_quote_for_eval_result" # We need to accept at least all the BSD install flags. dest= files= opts= prev= install_type= isdir=no stripme= for arg do if test -n "$dest"; then files="$files $dest" dest=$arg continue fi case $arg in -d) isdir=yes ;; -f) case " $install_prog " in *[\\\ /]cp\ *) ;; *) prev=$arg ;; esac ;; -g | -m | -o) prev=$arg ;; -s) stripme=" -s" continue ;; -*) ;; *) # If the previous option needed an argument, then skip it. if test -n "$prev"; then prev= else dest=$arg continue fi ;; esac # Aesthetically quote the argument. func_quote_for_eval "$arg" install_prog="$install_prog $func_quote_for_eval_result" done test -z "$install_prog" && \ func_fatal_help "you must specify an install program" test -n "$prev" && \ func_fatal_help "the \`$prev' option requires an argument" if test -z "$files"; then if test -z "$dest"; then func_fatal_help "no file or destination specified" else func_fatal_help "you must specify a destination" fi fi # Strip any trailing slash from the destination. func_stripname '' '/' "$dest" dest=$func_stripname_result # Check to see that the destination is a directory. test -d "$dest" && isdir=yes if test "$isdir" = yes; then destdir="$dest" destname= else func_dirname_and_basename "$dest" "" "." destdir="$func_dirname_result" destname="$func_basename_result" # Not a directory, so check to see that there is only one file specified. set dummy $files; shift test "$#" -gt 1 && \ func_fatal_help "\`$dest' is not a directory" fi case $destdir in [\\/]* | [A-Za-z]:[\\/]*) ;; *) for file in $files; do case $file in *.lo) ;; *) func_fatal_help "\`$destdir' must be an absolute directory name" ;; esac done ;; esac # This variable tells wrapper scripts just to set variables rather # than running their programs. libtool_install_magic="$magic" staticlibs= future_libdirs= current_libdirs= for file in $files; do # Do each installation. case $file in *.$libext) # Do the static libraries later. staticlibs="$staticlibs $file" ;; *.la) # Check to see that this really is a libtool archive. func_lalib_unsafe_p "$file" \ || func_fatal_help "\`$file' is not a valid libtool archive" library_names= old_library= relink_command= func_source "$file" # Add the libdir to current_libdirs if it is the destination. if test "X$destdir" = "X$libdir"; then case "$current_libdirs " in *" $libdir "*) ;; *) current_libdirs="$current_libdirs $libdir" ;; esac else # Note the libdir as a future libdir. case "$future_libdirs " in *" $libdir "*) ;; *) future_libdirs="$future_libdirs $libdir" ;; esac fi func_dirname "$file" "/" "" dir="$func_dirname_result" dir="$dir$objdir" if test -n "$relink_command"; then # Determine the prefix the user has applied to our future dir. inst_prefix_dir=`$ECHO "X$destdir" | $Xsed -e "s%$libdir\$%%"` # Don't allow the user to place us outside of our expected # location b/c this prevents finding dependent libraries that # are installed to the same prefix. # At present, this check doesn't affect windows .dll's that # are installed into $libdir/../bin (currently, that works fine) # but it's something to keep an eye on. test "$inst_prefix_dir" = "$destdir" && \ func_fatal_error "error: cannot install \`$file' to a directory not ending in $libdir" if test -n "$inst_prefix_dir"; then # Stick the inst_prefix_dir data into the link command. relink_command=`$ECHO "X$relink_command" | $Xsed -e "s%@inst_prefix_dir@%-inst-prefix-dir $inst_prefix_dir%"` else relink_command=`$ECHO "X$relink_command" | $Xsed -e "s%@inst_prefix_dir@%%"` fi func_warning "relinking \`$file'" func_show_eval "$relink_command" \ 'func_fatal_error "error: relink \`$file'\'' with the above command before installing it"' fi # See the names of the shared library. set dummy $library_names; shift if test -n "$1"; then realname="$1" shift srcname="$realname" test -n "$relink_command" && srcname="$realname"T # Install the shared library and build the symlinks. func_show_eval "$install_prog $dir/$srcname $destdir/$realname" \ 'exit $?' tstripme="$stripme" case $host_os in cygwin* | mingw* | pw32* | cegcc*) case $realname in *.dll.a) tstripme="" ;; esac ;; esac if test -n "$tstripme" && test -n "$striplib"; then func_show_eval "$striplib $destdir/$realname" 'exit $?' fi if test "$#" -gt 0; then # Delete the old symlinks, and create new ones. # Try `ln -sf' first, because the `ln' binary might depend on # the symlink we replace! Solaris /bin/ln does not understand -f, # so we also need to try rm && ln -s. for linkname do test "$linkname" != "$realname" \ && func_show_eval "(cd $destdir && { $LN_S -f $realname $linkname || { $RM $linkname && $LN_S $realname $linkname; }; })" done fi # Do each command in the postinstall commands. lib="$destdir/$realname" func_execute_cmds "$postinstall_cmds" 'exit $?' fi # Install the pseudo-library for information purposes. func_basename "$file" name="$func_basename_result" instname="$dir/$name"i func_show_eval "$install_prog $instname $destdir/$name" 'exit $?' # Maybe install the static library, too. test -n "$old_library" && staticlibs="$staticlibs $dir/$old_library" ;; *.lo) # Install (i.e. copy) a libtool object. # Figure out destination file name, if it wasn't already specified. if test -n "$destname"; then destfile="$destdir/$destname" else func_basename "$file" destfile="$func_basename_result" destfile="$destdir/$destfile" fi # Deduce the name of the destination old-style object file. case $destfile in *.lo) func_lo2o "$destfile" staticdest=$func_lo2o_result ;; *.$objext) staticdest="$destfile" destfile= ;; *) func_fatal_help "cannot copy a libtool object to \`$destfile'" ;; esac # Install the libtool object if requested. test -n "$destfile" && \ func_show_eval "$install_prog $file $destfile" 'exit $?' # Install the old object if enabled. if test "$build_old_libs" = yes; then # Deduce the name of the old-style object file. func_lo2o "$file" staticobj=$func_lo2o_result func_show_eval "$install_prog \$staticobj \$staticdest" 'exit $?' fi exit $EXIT_SUCCESS ;; *) # Figure out destination file name, if it wasn't already specified. if test -n "$destname"; then destfile="$destdir/$destname" else func_basename "$file" destfile="$func_basename_result" destfile="$destdir/$destfile" fi # If the file is missing, and there is a .exe on the end, strip it # because it is most likely a libtool script we actually want to # install stripped_ext="" case $file in *.exe) if test ! -f "$file"; then func_stripname '' '.exe' "$file" file=$func_stripname_result stripped_ext=".exe" fi ;; esac # Do a test to see if this is really a libtool program. case $host in *cygwin* | *mingw*) if func_ltwrapper_executable_p "$file"; then func_ltwrapper_scriptname "$file" wrapper=$func_ltwrapper_scriptname_result else func_stripname '' '.exe' "$file" wrapper=$func_stripname_result fi ;; *) wrapper=$file ;; esac if func_ltwrapper_script_p "$wrapper"; then notinst_deplibs= relink_command= func_source "$wrapper" # Check the variables that should have been set. test -z "$generated_by_libtool_version" && \ func_fatal_error "invalid libtool wrapper script \`$wrapper'" finalize=yes for lib in $notinst_deplibs; do # Check to see that each library is installed. libdir= if test -f "$lib"; then func_source "$lib" fi libfile="$libdir/"`$ECHO "X$lib" | $Xsed -e 's%^.*/%%g'` ### testsuite: skip nested quoting test if test -n "$libdir" && test ! -f "$libfile"; then func_warning "\`$lib' has not been installed in \`$libdir'" finalize=no fi done relink_command= func_source "$wrapper" outputname= if test "$fast_install" = no && test -n "$relink_command"; then $opt_dry_run || { if test "$finalize" = yes; then tmpdir=`func_mktempdir` func_basename "$file$stripped_ext" file="$func_basename_result" outputname="$tmpdir/$file" # Replace the output file specification. relink_command=`$ECHO "X$relink_command" | $Xsed -e 's%@OUTPUT@%'"$outputname"'%g'` $opt_silent || { func_quote_for_expand "$relink_command" eval "func_echo $func_quote_for_expand_result" } if eval "$relink_command"; then : else func_error "error: relink \`$file' with the above command before installing it" $opt_dry_run || ${RM}r "$tmpdir" continue fi file="$outputname" else func_warning "cannot relink \`$file'" fi } else # Install the binary that we compiled earlier. file=`$ECHO "X$file$stripped_ext" | $Xsed -e "s%\([^/]*\)$%$objdir/\1%"` fi fi # remove .exe since cygwin /usr/bin/install will append another # one anyway case $install_prog,$host in */usr/bin/install*,*cygwin*) case $file:$destfile in *.exe:*.exe) # this is ok ;; *.exe:*) destfile=$destfile.exe ;; *:*.exe) func_stripname '' '.exe' "$destfile" destfile=$func_stripname_result ;; esac ;; esac func_show_eval "$install_prog\$stripme \$file \$destfile" 'exit $?' $opt_dry_run || if test -n "$outputname"; then ${RM}r "$tmpdir" fi ;; esac done for file in $staticlibs; do func_basename "$file" name="$func_basename_result" # Set up the ranlib parameters. oldlib="$destdir/$name" func_show_eval "$install_prog \$file \$oldlib" 'exit $?' if test -n "$stripme" && test -n "$old_striplib"; then func_show_eval "$old_striplib $oldlib" 'exit $?' fi # Do each command in the postinstall commands. func_execute_cmds "$old_postinstall_cmds" 'exit $?' done test -n "$future_libdirs" && \ func_warning "remember to run \`$progname --finish$future_libdirs'" if test -n "$current_libdirs"; then # Maybe just do a dry run. $opt_dry_run && current_libdirs=" -n$current_libdirs" exec_cmd='$SHELL $progpath $preserve_args --finish$current_libdirs' else exit $EXIT_SUCCESS fi } test "$mode" = install && func_mode_install ${1+"$@"} # func_generate_dlsyms outputname originator pic_p # Extract symbols from dlprefiles and create ${outputname}S.o with # a dlpreopen symbol table. func_generate_dlsyms () { $opt_debug my_outputname="$1" my_originator="$2" my_pic_p="${3-no}" my_prefix=`$ECHO "$my_originator" | sed 's%[^a-zA-Z0-9]%_%g'` my_dlsyms= if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then if test -n "$NM" && test -n "$global_symbol_pipe"; then my_dlsyms="${my_outputname}S.c" else func_error "not configured to extract global symbols from dlpreopened files" fi fi if test -n "$my_dlsyms"; then case $my_dlsyms in "") ;; *.c) # Discover the nlist of each of the dlfiles. nlist="$output_objdir/${my_outputname}.nm" func_show_eval "$RM $nlist ${nlist}S ${nlist}T" # Parse the name list into a source file. func_verbose "creating $output_objdir/$my_dlsyms" $opt_dry_run || $ECHO > "$output_objdir/$my_dlsyms" "\ /* $my_dlsyms - symbol resolution table for \`$my_outputname' dlsym emulation. */ /* Generated by $PROGRAM (GNU $PACKAGE$TIMESTAMP) $VERSION */ #ifdef __cplusplus extern \"C\" { #endif /* External symbol declarations for the compiler. */\ " if test "$dlself" = yes; then func_verbose "generating symbol list for \`$output'" $opt_dry_run || echo ': @PROGRAM@ ' > "$nlist" # Add our own program objects to the symbol list. progfiles=`$ECHO "X$objs$old_deplibs" | $SP2NL | $Xsed -e "$lo2o" | $NL2SP` for progfile in $progfiles; do func_verbose "extracting global C symbols from \`$progfile'" $opt_dry_run || eval "$NM $progfile | $global_symbol_pipe >> '$nlist'" done if test -n "$exclude_expsyms"; then $opt_dry_run || { eval '$EGREP -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T' eval '$MV "$nlist"T "$nlist"' } fi if test -n "$export_symbols_regex"; then $opt_dry_run || { eval '$EGREP -e "$export_symbols_regex" "$nlist" > "$nlist"T' eval '$MV "$nlist"T "$nlist"' } fi # Prepare the list of exported symbols if test -z "$export_symbols"; then export_symbols="$output_objdir/$outputname.exp" $opt_dry_run || { $RM $export_symbols eval "${SED} -n -e '/^: @PROGRAM@ $/d' -e 's/^.* \(.*\)$/\1/p' "'< "$nlist" > "$export_symbols"' case $host in *cygwin* | *mingw* | *cegcc* ) eval "echo EXPORTS "'> "$output_objdir/$outputname.def"' eval 'cat "$export_symbols" >> "$output_objdir/$outputname.def"' ;; esac } else $opt_dry_run || { eval "${SED} -e 's/\([].[*^$]\)/\\\\\1/g' -e 's/^/ /' -e 's/$/$/'"' < "$export_symbols" > "$output_objdir/$outputname.exp"' eval '$GREP -f "$output_objdir/$outputname.exp" < "$nlist" > "$nlist"T' eval '$MV "$nlist"T "$nlist"' case $host in *cygwin | *mingw* | *cegcc* ) eval "echo EXPORTS "'> "$output_objdir/$outputname.def"' eval 'cat "$nlist" >> "$output_objdir/$outputname.def"' ;; esac } fi fi for dlprefile in $dlprefiles; do func_verbose "extracting global C symbols from \`$dlprefile'" func_basename "$dlprefile" name="$func_basename_result" $opt_dry_run || { eval '$ECHO ": $name " >> "$nlist"' eval "$NM $dlprefile 2>/dev/null | $global_symbol_pipe >> '$nlist'" } done $opt_dry_run || { # Make sure we have at least an empty file. test -f "$nlist" || : > "$nlist" if test -n "$exclude_expsyms"; then $EGREP -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T $MV "$nlist"T "$nlist" fi # Try sorting and uniquifying the output. if $GREP -v "^: " < "$nlist" | if sort -k 3 /dev/null 2>&1; then sort -k 3 else sort +2 fi | uniq > "$nlist"S; then : else $GREP -v "^: " < "$nlist" > "$nlist"S fi if test -f "$nlist"S; then eval "$global_symbol_to_cdecl"' < "$nlist"S >> "$output_objdir/$my_dlsyms"' else $ECHO '/* NONE */' >> "$output_objdir/$my_dlsyms" fi $ECHO >> "$output_objdir/$my_dlsyms" "\ /* The mapping between symbol names and symbols. */ typedef struct { const char *name; void *address; } lt_dlsymlist; " case $host in *cygwin* | *mingw* | *cegcc* ) $ECHO >> "$output_objdir/$my_dlsyms" "\ /* DATA imports from DLLs on WIN32 con't be const, because runtime relocations are performed -- see ld's documentation on pseudo-relocs. */" lt_dlsym_const= ;; *osf5*) echo >> "$output_objdir/$my_dlsyms" "\ /* This system does not cope well with relocations in const data */" lt_dlsym_const= ;; *) lt_dlsym_const=const ;; esac $ECHO >> "$output_objdir/$my_dlsyms" "\ extern $lt_dlsym_const lt_dlsymlist lt_${my_prefix}_LTX_preloaded_symbols[]; $lt_dlsym_const lt_dlsymlist lt_${my_prefix}_LTX_preloaded_symbols[] = {\ { \"$my_originator\", (void *) 0 }," case $need_lib_prefix in no) eval "$global_symbol_to_c_name_address" < "$nlist" >> "$output_objdir/$my_dlsyms" ;; *) eval "$global_symbol_to_c_name_address_lib_prefix" < "$nlist" >> "$output_objdir/$my_dlsyms" ;; esac $ECHO >> "$output_objdir/$my_dlsyms" "\ {0, (void *) 0} }; /* This works around a problem in FreeBSD linker */ #ifdef FREEBSD_WORKAROUND static const void *lt_preloaded_setup() { return lt_${my_prefix}_LTX_preloaded_symbols; } #endif #ifdef __cplusplus } #endif\ " } # !$opt_dry_run pic_flag_for_symtable= case "$compile_command " in *" -static "*) ;; *) case $host in # compiling the symbol table file with pic_flag works around # a FreeBSD bug that causes programs to crash when -lm is # linked before any other PIC object. But we must not use # pic_flag when linking with -static. The problem exists in # FreeBSD 2.2.6 and is fixed in FreeBSD 3.1. *-*-freebsd2*|*-*-freebsd3.0*|*-*-freebsdelf3.0*) pic_flag_for_symtable=" $pic_flag -DFREEBSD_WORKAROUND" ;; *-*-hpux*) pic_flag_for_symtable=" $pic_flag" ;; *) if test "X$my_pic_p" != Xno; then pic_flag_for_symtable=" $pic_flag" fi ;; esac ;; esac symtab_cflags= for arg in $LTCFLAGS; do case $arg in -pie | -fpie | -fPIE) ;; *) symtab_cflags="$symtab_cflags $arg" ;; esac done # Now compile the dynamic symbol file. func_show_eval '(cd $output_objdir && $LTCC$symtab_cflags -c$no_builtin_flag$pic_flag_for_symtable "$my_dlsyms")' 'exit $?' # Clean up the generated files. func_show_eval '$RM "$output_objdir/$my_dlsyms" "$nlist" "${nlist}S" "${nlist}T"' # Transform the symbol file into the correct name. symfileobj="$output_objdir/${my_outputname}S.$objext" case $host in *cygwin* | *mingw* | *cegcc* ) if test -f "$output_objdir/$my_outputname.def"; then compile_command=`$ECHO "X$compile_command" | $Xsed -e "s%@SYMFILE@%$output_objdir/$my_outputname.def $symfileobj%"` finalize_command=`$ECHO "X$finalize_command" | $Xsed -e "s%@SYMFILE@%$output_objdir/$my_outputname.def $symfileobj%"` else compile_command=`$ECHO "X$compile_command" | $Xsed -e "s%@SYMFILE@%$symfileobj%"` finalize_command=`$ECHO "X$finalize_command" | $Xsed -e "s%@SYMFILE@%$symfileobj%"` fi ;; *) compile_command=`$ECHO "X$compile_command" | $Xsed -e "s%@SYMFILE@%$symfileobj%"` finalize_command=`$ECHO "X$finalize_command" | $Xsed -e "s%@SYMFILE@%$symfileobj%"` ;; esac ;; *) func_fatal_error "unknown suffix for \`$my_dlsyms'" ;; esac else # We keep going just in case the user didn't refer to # lt_preloaded_symbols. The linker will fail if global_symbol_pipe # really was required. # Nullify the symbol file. compile_command=`$ECHO "X$compile_command" | $Xsed -e "s% @SYMFILE@%%"` finalize_command=`$ECHO "X$finalize_command" | $Xsed -e "s% @SYMFILE@%%"` fi } # func_win32_libid arg # return the library type of file 'arg' # # Need a lot of goo to handle *both* DLLs and import libs # Has to be a shell function in order to 'eat' the argument # that is supplied when $file_magic_command is called. func_win32_libid () { $opt_debug win32_libid_type="unknown" win32_fileres=`file -L $1 2>/dev/null` case $win32_fileres in *ar\ archive\ import\ library*) # definitely import win32_libid_type="x86 archive import" ;; *ar\ archive*) # could be an import, or static if eval $OBJDUMP -f $1 | $SED -e '10q' 2>/dev/null | $EGREP 'file format pe-i386(.*architecture: i386)?' >/dev/null ; then win32_nmres=`eval $NM -f posix -A $1 | $SED -n -e ' 1,100{ / I /{ s,.*,import, p q } }'` case $win32_nmres in import*) win32_libid_type="x86 archive import";; *) win32_libid_type="x86 archive static";; esac fi ;; *DLL*) win32_libid_type="x86 DLL" ;; *executable*) # but shell scripts are "executable" too... case $win32_fileres in *MS\ Windows\ PE\ Intel*) win32_libid_type="x86 DLL" ;; esac ;; esac $ECHO "$win32_libid_type" } # func_extract_an_archive dir oldlib func_extract_an_archive () { $opt_debug f_ex_an_ar_dir="$1"; shift f_ex_an_ar_oldlib="$1" func_show_eval "(cd \$f_ex_an_ar_dir && $AR x \"\$f_ex_an_ar_oldlib\")" 'exit $?' if ($AR t "$f_ex_an_ar_oldlib" | sort | sort -uc >/dev/null 2>&1); then : else func_fatal_error "object name conflicts in archive: $f_ex_an_ar_dir/$f_ex_an_ar_oldlib" fi } # func_extract_archives gentop oldlib ... func_extract_archives () { $opt_debug my_gentop="$1"; shift my_oldlibs=${1+"$@"} my_oldobjs="" my_xlib="" my_xabs="" my_xdir="" for my_xlib in $my_oldlibs; do # Extract the objects. case $my_xlib in [\\/]* | [A-Za-z]:[\\/]*) my_xabs="$my_xlib" ;; *) my_xabs=`pwd`"/$my_xlib" ;; esac func_basename "$my_xlib" my_xlib="$func_basename_result" my_xlib_u=$my_xlib while :; do case " $extracted_archives " in *" $my_xlib_u "*) func_arith $extracted_serial + 1 extracted_serial=$func_arith_result my_xlib_u=lt$extracted_serial-$my_xlib ;; *) break ;; esac done extracted_archives="$extracted_archives $my_xlib_u" my_xdir="$my_gentop/$my_xlib_u" func_mkdir_p "$my_xdir" case $host in *-darwin*) func_verbose "Extracting $my_xabs" # Do not bother doing anything if just a dry run $opt_dry_run || { darwin_orig_dir=`pwd` cd $my_xdir || exit $? darwin_archive=$my_xabs darwin_curdir=`pwd` darwin_base_archive=`basename "$darwin_archive"` darwin_arches=`$LIPO -info "$darwin_archive" 2>/dev/null | $GREP Architectures 2>/dev/null || true` if test -n "$darwin_arches"; then darwin_arches=`$ECHO "$darwin_arches" | $SED -e 's/.*are://'` darwin_arch= func_verbose "$darwin_base_archive has multiple architectures $darwin_arches" for darwin_arch in $darwin_arches ; do func_mkdir_p "unfat-$$/${darwin_base_archive}-${darwin_arch}" $LIPO -thin $darwin_arch -output "unfat-$$/${darwin_base_archive}-${darwin_arch}/${darwin_base_archive}" "${darwin_archive}" cd "unfat-$$/${darwin_base_archive}-${darwin_arch}" func_extract_an_archive "`pwd`" "${darwin_base_archive}" cd "$darwin_curdir" $RM "unfat-$$/${darwin_base_archive}-${darwin_arch}/${darwin_base_archive}" done # $darwin_arches ## Okay now we've a bunch of thin objects, gotta fatten them up :) darwin_filelist=`find unfat-$$ -type f -name \*.o -print -o -name \*.lo -print | $SED -e "$basename" | sort -u` darwin_file= darwin_files= for darwin_file in $darwin_filelist; do darwin_files=`find unfat-$$ -name $darwin_file -print | $NL2SP` $LIPO -create -output "$darwin_file" $darwin_files done # $darwin_filelist $RM -rf unfat-$$ cd "$darwin_orig_dir" else cd $darwin_orig_dir func_extract_an_archive "$my_xdir" "$my_xabs" fi # $darwin_arches } # !$opt_dry_run ;; *) func_extract_an_archive "$my_xdir" "$my_xabs" ;; esac my_oldobjs="$my_oldobjs "`find $my_xdir -name \*.$objext -print -o -name \*.lo -print | $NL2SP` done func_extract_archives_result="$my_oldobjs" } # func_emit_wrapper_part1 [arg=no] # # Emit the first part of a libtool wrapper script on stdout. # For more information, see the description associated with # func_emit_wrapper(), below. func_emit_wrapper_part1 () { func_emit_wrapper_part1_arg1=no if test -n "$1" ; then func_emit_wrapper_part1_arg1=$1 fi $ECHO "\ #! $SHELL # $output - temporary wrapper script for $objdir/$outputname # Generated by $PROGRAM (GNU $PACKAGE$TIMESTAMP) $VERSION # # The $output program cannot be directly executed until all the libtool # libraries that it depends on are installed. # # This wrapper script should never be moved out of the build directory. # If it is, it will not operate correctly. # Sed substitution that helps us do robust quoting. It backslashifies # metacharacters that are still active within double-quoted strings. Xsed='${SED} -e 1s/^X//' sed_quote_subst='$sed_quote_subst' # Be Bourne compatible if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in *posix*) set -o posix;; esac fi BIN_SH=xpg4; export BIN_SH # for Tru64 DUALCASE=1; export DUALCASE # for MKS sh # The HP-UX ksh and POSIX shell print the target directory to stdout # if CDPATH is set. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH relink_command=\"$relink_command\" # This environment variable determines our operation mode. if test \"\$libtool_install_magic\" = \"$magic\"; then # install mode needs the following variables: generated_by_libtool_version='$macro_version' notinst_deplibs='$notinst_deplibs' else # When we are sourced in execute mode, \$file and \$ECHO are already set. if test \"\$libtool_execute_magic\" != \"$magic\"; then ECHO=\"$qecho\" file=\"\$0\" # Make sure echo works. if test \"X\$1\" = X--no-reexec; then # Discard the --no-reexec flag, and continue. shift elif test \"X\`{ \$ECHO '\t'; } 2>/dev/null\`\" = 'X\t'; then # Yippee, \$ECHO works! : else # Restart under the correct shell, and then maybe \$ECHO will work. exec $SHELL \"\$0\" --no-reexec \${1+\"\$@\"} fi fi\ " $ECHO "\ # Find the directory that this script lives in. thisdir=\`\$ECHO \"X\$file\" | \$Xsed -e 's%/[^/]*$%%'\` test \"x\$thisdir\" = \"x\$file\" && thisdir=. # Follow symbolic links until we get to the real thisdir. file=\`ls -ld \"\$file\" | ${SED} -n 's/.*-> //p'\` while test -n \"\$file\"; do destdir=\`\$ECHO \"X\$file\" | \$Xsed -e 's%/[^/]*\$%%'\` # If there was a directory component, then change thisdir. if test \"x\$destdir\" != \"x\$file\"; then case \"\$destdir\" in [\\\\/]* | [A-Za-z]:[\\\\/]*) thisdir=\"\$destdir\" ;; *) thisdir=\"\$thisdir/\$destdir\" ;; esac fi file=\`\$ECHO \"X\$file\" | \$Xsed -e 's%^.*/%%'\` file=\`ls -ld \"\$thisdir/\$file\" | ${SED} -n 's/.*-> //p'\` done " } # end: func_emit_wrapper_part1 # func_emit_wrapper_part2 [arg=no] # # Emit the second part of a libtool wrapper script on stdout. # For more information, see the description associated with # func_emit_wrapper(), below. func_emit_wrapper_part2 () { func_emit_wrapper_part2_arg1=no if test -n "$1" ; then func_emit_wrapper_part2_arg1=$1 fi $ECHO "\ # Usually 'no', except on cygwin/mingw when embedded into # the cwrapper. WRAPPER_SCRIPT_BELONGS_IN_OBJDIR=$func_emit_wrapper_part2_arg1 if test \"\$WRAPPER_SCRIPT_BELONGS_IN_OBJDIR\" = \"yes\"; then # special case for '.' if test \"\$thisdir\" = \".\"; then thisdir=\`pwd\` fi # remove .libs from thisdir case \"\$thisdir\" in *[\\\\/]$objdir ) thisdir=\`\$ECHO \"X\$thisdir\" | \$Xsed -e 's%[\\\\/][^\\\\/]*$%%'\` ;; $objdir ) thisdir=. ;; esac fi # Try to get the absolute directory name. absdir=\`cd \"\$thisdir\" && pwd\` test -n \"\$absdir\" && thisdir=\"\$absdir\" " if test "$fast_install" = yes; then $ECHO "\ program=lt-'$outputname'$exeext progdir=\"\$thisdir/$objdir\" if test ! -f \"\$progdir/\$program\" || { file=\`ls -1dt \"\$progdir/\$program\" \"\$progdir/../\$program\" 2>/dev/null | ${SED} 1q\`; \\ test \"X\$file\" != \"X\$progdir/\$program\"; }; then file=\"\$\$-\$program\" if test ! -d \"\$progdir\"; then $MKDIR \"\$progdir\" else $RM \"\$progdir/\$file\" fi" $ECHO "\ # relink executable if necessary if test -n \"\$relink_command\"; then if relink_command_output=\`eval \$relink_command 2>&1\`; then : else $ECHO \"\$relink_command_output\" >&2 $RM \"\$progdir/\$file\" exit 1 fi fi $MV \"\$progdir/\$file\" \"\$progdir/\$program\" 2>/dev/null || { $RM \"\$progdir/\$program\"; $MV \"\$progdir/\$file\" \"\$progdir/\$program\"; } $RM \"\$progdir/\$file\" fi" else $ECHO "\ program='$outputname' progdir=\"\$thisdir/$objdir\" " fi $ECHO "\ if test -f \"\$progdir/\$program\"; then" # Export our shlibpath_var if we have one. if test "$shlibpath_overrides_runpath" = yes && test -n "$shlibpath_var" && test -n "$temp_rpath"; then $ECHO "\ # Add our own library path to $shlibpath_var $shlibpath_var=\"$temp_rpath\$$shlibpath_var\" # Some systems cannot cope with colon-terminated $shlibpath_var # The second colon is a workaround for a bug in BeOS R4 sed $shlibpath_var=\`\$ECHO \"X\$$shlibpath_var\" | \$Xsed -e 's/::*\$//'\` export $shlibpath_var " fi # fixup the dll searchpath if we need to. if test -n "$dllsearchpath"; then $ECHO "\ # Add the dll search path components to the executable PATH PATH=$dllsearchpath:\$PATH " fi $ECHO "\ if test \"\$libtool_execute_magic\" != \"$magic\"; then # Run the actual program with our arguments. " case $host in # Backslashes separate directories on plain windows *-*-mingw | *-*-os2* | *-cegcc*) $ECHO "\ exec \"\$progdir\\\\\$program\" \${1+\"\$@\"} " ;; *) $ECHO "\ exec \"\$progdir/\$program\" \${1+\"\$@\"} " ;; esac $ECHO "\ \$ECHO \"\$0: cannot exec \$program \$*\" 1>&2 exit 1 fi else # The program doesn't exist. \$ECHO \"\$0: error: \\\`\$progdir/\$program' does not exist\" 1>&2 \$ECHO \"This script is just a wrapper for \$program.\" 1>&2 $ECHO \"See the $PACKAGE documentation for more information.\" 1>&2 exit 1 fi fi\ " } # end: func_emit_wrapper_part2 # func_emit_wrapper [arg=no] # # Emit a libtool wrapper script on stdout. # Don't directly open a file because we may want to # incorporate the script contents within a cygwin/mingw # wrapper executable. Must ONLY be called from within # func_mode_link because it depends on a number of variables # set therein. # # ARG is the value that the WRAPPER_SCRIPT_BELONGS_IN_OBJDIR # variable will take. If 'yes', then the emitted script # will assume that the directory in which it is stored is # the $objdir directory. This is a cygwin/mingw-specific # behavior. func_emit_wrapper () { func_emit_wrapper_arg1=no if test -n "$1" ; then func_emit_wrapper_arg1=$1 fi # split this up so that func_emit_cwrapperexe_src # can call each part independently. func_emit_wrapper_part1 "${func_emit_wrapper_arg1}" func_emit_wrapper_part2 "${func_emit_wrapper_arg1}" } # func_to_host_path arg # # Convert paths to host format when used with build tools. # Intended for use with "native" mingw (where libtool itself # is running under the msys shell), or in the following cross- # build environments: # $build $host # mingw (msys) mingw [e.g. native] # cygwin mingw # *nix + wine mingw # where wine is equipped with the `winepath' executable. # In the native mingw case, the (msys) shell automatically # converts paths for any non-msys applications it launches, # but that facility isn't available from inside the cwrapper. # Similar accommodations are necessary for $host mingw and # $build cygwin. Calling this function does no harm for other # $host/$build combinations not listed above. # # ARG is the path (on $build) that should be converted to # the proper representation for $host. The result is stored # in $func_to_host_path_result. func_to_host_path () { func_to_host_path_result="$1" if test -n "$1" ; then case $host in *mingw* ) lt_sed_naive_backslashify='s|\\\\*|\\|g;s|/|\\|g;s|\\|\\\\|g' case $build in *mingw* ) # actually, msys # awkward: cmd appends spaces to result lt_sed_strip_trailing_spaces="s/[ ]*\$//" func_to_host_path_tmp1=`( cmd //c echo "$1" |\ $SED -e "$lt_sed_strip_trailing_spaces" ) 2>/dev/null || echo ""` func_to_host_path_result=`echo "$func_to_host_path_tmp1" |\ $SED -e "$lt_sed_naive_backslashify"` ;; *cygwin* ) func_to_host_path_tmp1=`cygpath -w "$1"` func_to_host_path_result=`echo "$func_to_host_path_tmp1" |\ $SED -e "$lt_sed_naive_backslashify"` ;; * ) # Unfortunately, winepath does not exit with a non-zero # error code, so we are forced to check the contents of # stdout. On the other hand, if the command is not # found, the shell will set an exit code of 127 and print # *an error message* to stdout. So we must check for both # error code of zero AND non-empty stdout, which explains # the odd construction: func_to_host_path_tmp1=`winepath -w "$1" 2>/dev/null` if test "$?" -eq 0 && test -n "${func_to_host_path_tmp1}"; then func_to_host_path_result=`echo "$func_to_host_path_tmp1" |\ $SED -e "$lt_sed_naive_backslashify"` else # Allow warning below. func_to_host_path_result="" fi ;; esac if test -z "$func_to_host_path_result" ; then func_error "Could not determine host path corresponding to" func_error " '$1'" func_error "Continuing, but uninstalled executables may not work." # Fallback: func_to_host_path_result="$1" fi ;; esac fi } # end: func_to_host_path # func_to_host_pathlist arg # # Convert pathlists to host format when used with build tools. # See func_to_host_path(), above. This function supports the # following $build/$host combinations (but does no harm for # combinations not listed here): # $build $host # mingw (msys) mingw [e.g. native] # cygwin mingw # *nix + wine mingw # # Path separators are also converted from $build format to # $host format. If ARG begins or ends with a path separator # character, it is preserved (but converted to $host format) # on output. # # ARG is a pathlist (on $build) that should be converted to # the proper representation on $host. The result is stored # in $func_to_host_pathlist_result. func_to_host_pathlist () { func_to_host_pathlist_result="$1" if test -n "$1" ; then case $host in *mingw* ) lt_sed_naive_backslashify='s|\\\\*|\\|g;s|/|\\|g;s|\\|\\\\|g' # Remove leading and trailing path separator characters from # ARG. msys behavior is inconsistent here, cygpath turns them # into '.;' and ';.', and winepath ignores them completely. func_to_host_pathlist_tmp2="$1" # Once set for this call, this variable should not be # reassigned. It is used in tha fallback case. func_to_host_pathlist_tmp1=`echo "$func_to_host_pathlist_tmp2" |\ $SED -e 's|^:*||' -e 's|:*$||'` case $build in *mingw* ) # Actually, msys. # Awkward: cmd appends spaces to result. lt_sed_strip_trailing_spaces="s/[ ]*\$//" func_to_host_pathlist_tmp2=`( cmd //c echo "$func_to_host_pathlist_tmp1" |\ $SED -e "$lt_sed_strip_trailing_spaces" ) 2>/dev/null || echo ""` func_to_host_pathlist_result=`echo "$func_to_host_pathlist_tmp2" |\ $SED -e "$lt_sed_naive_backslashify"` ;; *cygwin* ) func_to_host_pathlist_tmp2=`cygpath -w -p "$func_to_host_pathlist_tmp1"` func_to_host_pathlist_result=`echo "$func_to_host_pathlist_tmp2" |\ $SED -e "$lt_sed_naive_backslashify"` ;; * ) # unfortunately, winepath doesn't convert pathlists func_to_host_pathlist_result="" func_to_host_pathlist_oldIFS=$IFS IFS=: for func_to_host_pathlist_f in $func_to_host_pathlist_tmp1 ; do IFS=$func_to_host_pathlist_oldIFS if test -n "$func_to_host_pathlist_f" ; then func_to_host_path "$func_to_host_pathlist_f" if test -n "$func_to_host_path_result" ; then if test -z "$func_to_host_pathlist_result" ; then func_to_host_pathlist_result="$func_to_host_path_result" else func_to_host_pathlist_result="$func_to_host_pathlist_result;$func_to_host_path_result" fi fi fi IFS=: done IFS=$func_to_host_pathlist_oldIFS ;; esac if test -z "$func_to_host_pathlist_result" ; then func_error "Could not determine the host path(s) corresponding to" func_error " '$1'" func_error "Continuing, but uninstalled executables may not work." # Fallback. This may break if $1 contains DOS-style drive # specifications. The fix is not to complicate the expression # below, but for the user to provide a working wine installation # with winepath so that path translation in the cross-to-mingw # case works properly. lt_replace_pathsep_nix_to_dos="s|:|;|g" func_to_host_pathlist_result=`echo "$func_to_host_pathlist_tmp1" |\ $SED -e "$lt_replace_pathsep_nix_to_dos"` fi # Now, add the leading and trailing path separators back case "$1" in :* ) func_to_host_pathlist_result=";$func_to_host_pathlist_result" ;; esac case "$1" in *: ) func_to_host_pathlist_result="$func_to_host_pathlist_result;" ;; esac ;; esac fi } # end: func_to_host_pathlist # func_emit_cwrapperexe_src # emit the source code for a wrapper executable on stdout # Must ONLY be called from within func_mode_link because # it depends on a number of variable set therein. func_emit_cwrapperexe_src () { cat < #include #ifdef _MSC_VER # include # include # include # define setmode _setmode #else # include # include # ifdef __CYGWIN__ # include # define HAVE_SETENV # ifdef __STRICT_ANSI__ char *realpath (const char *, char *); int putenv (char *); int setenv (const char *, const char *, int); # endif # endif #endif #include #include #include #include #include #include #include #include #if defined(PATH_MAX) # define LT_PATHMAX PATH_MAX #elif defined(MAXPATHLEN) # define LT_PATHMAX MAXPATHLEN #else # define LT_PATHMAX 1024 #endif #ifndef S_IXOTH # define S_IXOTH 0 #endif #ifndef S_IXGRP # define S_IXGRP 0 #endif #ifdef _MSC_VER # define S_IXUSR _S_IEXEC # define stat _stat # ifndef _INTPTR_T_DEFINED # define intptr_t int # endif #endif #ifndef DIR_SEPARATOR # define DIR_SEPARATOR '/' # define PATH_SEPARATOR ':' #endif #if defined (_WIN32) || defined (__MSDOS__) || defined (__DJGPP__) || \ defined (__OS2__) # define HAVE_DOS_BASED_FILE_SYSTEM # define FOPEN_WB "wb" # ifndef DIR_SEPARATOR_2 # define DIR_SEPARATOR_2 '\\' # endif # ifndef PATH_SEPARATOR_2 # define PATH_SEPARATOR_2 ';' # endif #endif #ifndef DIR_SEPARATOR_2 # define IS_DIR_SEPARATOR(ch) ((ch) == DIR_SEPARATOR) #else /* DIR_SEPARATOR_2 */ # define IS_DIR_SEPARATOR(ch) \ (((ch) == DIR_SEPARATOR) || ((ch) == DIR_SEPARATOR_2)) #endif /* DIR_SEPARATOR_2 */ #ifndef PATH_SEPARATOR_2 # define IS_PATH_SEPARATOR(ch) ((ch) == PATH_SEPARATOR) #else /* PATH_SEPARATOR_2 */ # define IS_PATH_SEPARATOR(ch) ((ch) == PATH_SEPARATOR_2) #endif /* PATH_SEPARATOR_2 */ #ifdef __CYGWIN__ # define FOPEN_WB "wb" #endif #ifndef FOPEN_WB # define FOPEN_WB "w" #endif #ifndef _O_BINARY # define _O_BINARY 0 #endif #define XMALLOC(type, num) ((type *) xmalloc ((num) * sizeof(type))) #define XFREE(stale) do { \ if (stale) { free ((void *) stale); stale = 0; } \ } while (0) #undef LTWRAPPER_DEBUGPRINTF #if defined DEBUGWRAPPER # define LTWRAPPER_DEBUGPRINTF(args) ltwrapper_debugprintf args static void ltwrapper_debugprintf (const char *fmt, ...) { va_list args; va_start (args, fmt); (void) vfprintf (stderr, fmt, args); va_end (args); } #else # define LTWRAPPER_DEBUGPRINTF(args) #endif const char *program_name = NULL; void *xmalloc (size_t num); char *xstrdup (const char *string); const char *base_name (const char *name); char *find_executable (const char *wrapper); char *chase_symlinks (const char *pathspec); int make_executable (const char *path); int check_executable (const char *path); char *strendzap (char *str, const char *pat); void lt_fatal (const char *message, ...); void lt_setenv (const char *name, const char *value); char *lt_extend_str (const char *orig_value, const char *add, int to_end); void lt_opt_process_env_set (const char *arg); void lt_opt_process_env_prepend (const char *arg); void lt_opt_process_env_append (const char *arg); int lt_split_name_value (const char *arg, char** name, char** value); void lt_update_exe_path (const char *name, const char *value); void lt_update_lib_path (const char *name, const char *value); static const char *script_text_part1 = EOF func_emit_wrapper_part1 yes | $SED -e 's/\([\\"]\)/\\\1/g' \ -e 's/^/ "/' -e 's/$/\\n"/' echo ";" cat <"))); for (i = 0; i < newargc; i++) { LTWRAPPER_DEBUGPRINTF (("(main) newargz[%d] : %s\n", i, (newargz[i] ? newargz[i] : ""))); } EOF case $host_os in mingw*) cat <<"EOF" /* execv doesn't actually work on mingw as expected on unix */ rval = _spawnv (_P_WAIT, lt_argv_zero, (const char * const *) newargz); if (rval == -1) { /* failed to start process */ LTWRAPPER_DEBUGPRINTF (("(main) failed to launch target \"%s\": errno = %d\n", lt_argv_zero, errno)); return 127; } return rval; EOF ;; *) cat <<"EOF" execv (lt_argv_zero, newargz); return rval; /* =127, but avoids unused variable warning */ EOF ;; esac cat <<"EOF" } void * xmalloc (size_t num) { void *p = (void *) malloc (num); if (!p) lt_fatal ("Memory exhausted"); return p; } char * xstrdup (const char *string) { return string ? strcpy ((char *) xmalloc (strlen (string) + 1), string) : NULL; } const char * base_name (const char *name) { const char *base; #if defined (HAVE_DOS_BASED_FILE_SYSTEM) /* Skip over the disk name in MSDOS pathnames. */ if (isalpha ((unsigned char) name[0]) && name[1] == ':') name += 2; #endif for (base = name; *name; name++) if (IS_DIR_SEPARATOR (*name)) base = name + 1; return base; } int check_executable (const char *path) { struct stat st; LTWRAPPER_DEBUGPRINTF (("(check_executable) : %s\n", path ? (*path ? path : "EMPTY!") : "NULL!")); if ((!path) || (!*path)) return 0; if ((stat (path, &st) >= 0) && (st.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH))) return 1; else return 0; } int make_executable (const char *path) { int rval = 0; struct stat st; LTWRAPPER_DEBUGPRINTF (("(make_executable) : %s\n", path ? (*path ? path : "EMPTY!") : "NULL!")); if ((!path) || (!*path)) return 0; if (stat (path, &st) >= 0) { rval = chmod (path, st.st_mode | S_IXOTH | S_IXGRP | S_IXUSR); } return rval; } /* Searches for the full path of the wrapper. Returns newly allocated full path name if found, NULL otherwise Does not chase symlinks, even on platforms that support them. */ char * find_executable (const char *wrapper) { int has_slash = 0; const char *p; const char *p_next; /* static buffer for getcwd */ char tmp[LT_PATHMAX + 1]; int tmp_len; char *concat_name; LTWRAPPER_DEBUGPRINTF (("(find_executable) : %s\n", wrapper ? (*wrapper ? wrapper : "EMPTY!") : "NULL!")); if ((wrapper == NULL) || (*wrapper == '\0')) return NULL; /* Absolute path? */ #if defined (HAVE_DOS_BASED_FILE_SYSTEM) if (isalpha ((unsigned char) wrapper[0]) && wrapper[1] == ':') { concat_name = xstrdup (wrapper); if (check_executable (concat_name)) return concat_name; XFREE (concat_name); } else { #endif if (IS_DIR_SEPARATOR (wrapper[0])) { concat_name = xstrdup (wrapper); if (check_executable (concat_name)) return concat_name; XFREE (concat_name); } #if defined (HAVE_DOS_BASED_FILE_SYSTEM) } #endif for (p = wrapper; *p; p++) if (*p == '/') { has_slash = 1; break; } if (!has_slash) { /* no slashes; search PATH */ const char *path = getenv ("PATH"); if (path != NULL) { for (p = path; *p; p = p_next) { const char *q; size_t p_len; for (q = p; *q; q++) if (IS_PATH_SEPARATOR (*q)) break; p_len = q - p; p_next = (*q == '\0' ? q : q + 1); if (p_len == 0) { /* empty path: current directory */ if (getcwd (tmp, LT_PATHMAX) == NULL) lt_fatal ("getcwd failed"); tmp_len = strlen (tmp); concat_name = XMALLOC (char, tmp_len + 1 + strlen (wrapper) + 1); memcpy (concat_name, tmp, tmp_len); concat_name[tmp_len] = '/'; strcpy (concat_name + tmp_len + 1, wrapper); } else { concat_name = XMALLOC (char, p_len + 1 + strlen (wrapper) + 1); memcpy (concat_name, p, p_len); concat_name[p_len] = '/'; strcpy (concat_name + p_len + 1, wrapper); } if (check_executable (concat_name)) return concat_name; XFREE (concat_name); } } /* not found in PATH; assume curdir */ } /* Relative path | not found in path: prepend cwd */ if (getcwd (tmp, LT_PATHMAX) == NULL) lt_fatal ("getcwd failed"); tmp_len = strlen (tmp); concat_name = XMALLOC (char, tmp_len + 1 + strlen (wrapper) + 1); memcpy (concat_name, tmp, tmp_len); concat_name[tmp_len] = '/'; strcpy (concat_name + tmp_len + 1, wrapper); if (check_executable (concat_name)) return concat_name; XFREE (concat_name); return NULL; } char * chase_symlinks (const char *pathspec) { #ifndef S_ISLNK return xstrdup (pathspec); #else char buf[LT_PATHMAX]; struct stat s; char *tmp_pathspec = xstrdup (pathspec); char *p; int has_symlinks = 0; while (strlen (tmp_pathspec) && !has_symlinks) { LTWRAPPER_DEBUGPRINTF (("checking path component for symlinks: %s\n", tmp_pathspec)); if (lstat (tmp_pathspec, &s) == 0) { if (S_ISLNK (s.st_mode) != 0) { has_symlinks = 1; break; } /* search backwards for last DIR_SEPARATOR */ p = tmp_pathspec + strlen (tmp_pathspec) - 1; while ((p > tmp_pathspec) && (!IS_DIR_SEPARATOR (*p))) p--; if ((p == tmp_pathspec) && (!IS_DIR_SEPARATOR (*p))) { /* no more DIR_SEPARATORS left */ break; } *p = '\0'; } else { char *errstr = strerror (errno); lt_fatal ("Error accessing file %s (%s)", tmp_pathspec, errstr); } } XFREE (tmp_pathspec); if (!has_symlinks) { return xstrdup (pathspec); } tmp_pathspec = realpath (pathspec, buf); if (tmp_pathspec == 0) { lt_fatal ("Could not follow symlinks for %s", pathspec); } return xstrdup (tmp_pathspec); #endif } char * strendzap (char *str, const char *pat) { size_t len, patlen; assert (str != NULL); assert (pat != NULL); len = strlen (str); patlen = strlen (pat); if (patlen <= len) { str += len - patlen; if (strcmp (str, pat) == 0) *str = '\0'; } return str; } static void lt_error_core (int exit_status, const char *mode, const char *message, va_list ap) { fprintf (stderr, "%s: %s: ", program_name, mode); vfprintf (stderr, message, ap); fprintf (stderr, ".\n"); if (exit_status >= 0) exit (exit_status); } void lt_fatal (const char *message, ...) { va_list ap; va_start (ap, message); lt_error_core (EXIT_FAILURE, "FATAL", message, ap); va_end (ap); } void lt_setenv (const char *name, const char *value) { LTWRAPPER_DEBUGPRINTF (("(lt_setenv) setting '%s' to '%s'\n", (name ? name : ""), (value ? value : ""))); { #ifdef HAVE_SETENV /* always make a copy, for consistency with !HAVE_SETENV */ char *str = xstrdup (value); setenv (name, str, 1); #else int len = strlen (name) + 1 + strlen (value) + 1; char *str = XMALLOC (char, len); sprintf (str, "%s=%s", name, value); if (putenv (str) != EXIT_SUCCESS) { XFREE (str); } #endif } } char * lt_extend_str (const char *orig_value, const char *add, int to_end) { char *new_value; if (orig_value && *orig_value) { int orig_value_len = strlen (orig_value); int add_len = strlen (add); new_value = XMALLOC (char, add_len + orig_value_len + 1); if (to_end) { strcpy (new_value, orig_value); strcpy (new_value + orig_value_len, add); } else { strcpy (new_value, add); strcpy (new_value + add_len, orig_value); } } else { new_value = xstrdup (add); } return new_value; } int lt_split_name_value (const char *arg, char** name, char** value) { const char *p; int len; if (!arg || !*arg) return 1; p = strchr (arg, (int)'='); if (!p) return 1; *value = xstrdup (++p); len = strlen (arg) - strlen (*value); *name = XMALLOC (char, len); strncpy (*name, arg, len-1); (*name)[len - 1] = '\0'; return 0; } void lt_opt_process_env_set (const char *arg) { char *name = NULL; char *value = NULL; if (lt_split_name_value (arg, &name, &value) != 0) { XFREE (name); XFREE (value); lt_fatal ("bad argument for %s: '%s'", env_set_opt, arg); } lt_setenv (name, value); XFREE (name); XFREE (value); } void lt_opt_process_env_prepend (const char *arg) { char *name = NULL; char *value = NULL; char *new_value = NULL; if (lt_split_name_value (arg, &name, &value) != 0) { XFREE (name); XFREE (value); lt_fatal ("bad argument for %s: '%s'", env_prepend_opt, arg); } new_value = lt_extend_str (getenv (name), value, 0); lt_setenv (name, new_value); XFREE (new_value); XFREE (name); XFREE (value); } void lt_opt_process_env_append (const char *arg) { char *name = NULL; char *value = NULL; char *new_value = NULL; if (lt_split_name_value (arg, &name, &value) != 0) { XFREE (name); XFREE (value); lt_fatal ("bad argument for %s: '%s'", env_append_opt, arg); } new_value = lt_extend_str (getenv (name), value, 1); lt_setenv (name, new_value); XFREE (new_value); XFREE (name); XFREE (value); } void lt_update_exe_path (const char *name, const char *value) { LTWRAPPER_DEBUGPRINTF (("(lt_update_exe_path) modifying '%s' by prepending '%s'\n", (name ? name : ""), (value ? value : ""))); if (name && *name && value && *value) { char *new_value = lt_extend_str (getenv (name), value, 0); /* some systems can't cope with a ':'-terminated path #' */ int len = strlen (new_value); while (((len = strlen (new_value)) > 0) && IS_PATH_SEPARATOR (new_value[len-1])) { new_value[len-1] = '\0'; } lt_setenv (name, new_value); XFREE (new_value); } } void lt_update_lib_path (const char *name, const char *value) { LTWRAPPER_DEBUGPRINTF (("(lt_update_lib_path) modifying '%s' by prepending '%s'\n", (name ? name : ""), (value ? value : ""))); if (name && *name && value && *value) { char *new_value = lt_extend_str (getenv (name), value, 0); lt_setenv (name, new_value); XFREE (new_value); } } EOF } # end: func_emit_cwrapperexe_src # func_mode_link arg... func_mode_link () { $opt_debug case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*) # It is impossible to link a dll without this setting, and # we shouldn't force the makefile maintainer to figure out # which system we are compiling for in order to pass an extra # flag for every libtool invocation. # allow_undefined=no # FIXME: Unfortunately, there are problems with the above when trying # to make a dll which has undefined symbols, in which case not # even a static library is built. For now, we need to specify # -no-undefined on the libtool link line when we can be certain # that all symbols are satisfied, otherwise we get a static library. allow_undefined=yes ;; *) allow_undefined=yes ;; esac libtool_args=$nonopt base_compile="$nonopt $@" compile_command=$nonopt finalize_command=$nonopt compile_rpath= finalize_rpath= compile_shlibpath= finalize_shlibpath= convenience= old_convenience= deplibs= old_deplibs= compiler_flags= linker_flags= dllsearchpath= lib_search_path=`pwd` inst_prefix_dir= new_inherited_linker_flags= avoid_version=no dlfiles= dlprefiles= dlself=no export_dynamic=no export_symbols= export_symbols_regex= generated= libobjs= ltlibs= module=no no_install=no objs= non_pic_objects= precious_files_regex= prefer_static_libs=no preload=no prev= prevarg= release= rpath= xrpath= perm_rpath= temp_rpath= thread_safe=no vinfo= vinfo_number=no weak_libs= single_module="${wl}-single_module" func_infer_tag $base_compile # We need to know -static, to get the right output filenames. for arg do case $arg in -shared) test "$build_libtool_libs" != yes && \ func_fatal_configuration "can not build a shared library" build_old_libs=no break ;; -all-static | -static | -static-libtool-libs) case $arg in -all-static) if test "$build_libtool_libs" = yes && test -z "$link_static_flag"; then func_warning "complete static linking is impossible in this configuration" fi if test -n "$link_static_flag"; then dlopen_self=$dlopen_self_static fi prefer_static_libs=yes ;; -static) if test -z "$pic_flag" && test -n "$link_static_flag"; then dlopen_self=$dlopen_self_static fi prefer_static_libs=built ;; -static-libtool-libs) if test -z "$pic_flag" && test -n "$link_static_flag"; then dlopen_self=$dlopen_self_static fi prefer_static_libs=yes ;; esac build_libtool_libs=no build_old_libs=yes break ;; esac done # See if our shared archives depend on static archives. test -n "$old_archive_from_new_cmds" && build_old_libs=yes # Go through the arguments, transforming them on the way. while test "$#" -gt 0; do arg="$1" shift func_quote_for_eval "$arg" qarg=$func_quote_for_eval_unquoted_result func_append libtool_args " $func_quote_for_eval_result" # If the previous option needs an argument, assign it. if test -n "$prev"; then case $prev in output) func_append compile_command " @OUTPUT@" func_append finalize_command " @OUTPUT@" ;; esac case $prev in dlfiles|dlprefiles) if test "$preload" = no; then # Add the symbol object into the linking commands. func_append compile_command " @SYMFILE@" func_append finalize_command " @SYMFILE@" preload=yes fi case $arg in *.la | *.lo) ;; # We handle these cases below. force) if test "$dlself" = no; then dlself=needless export_dynamic=yes fi prev= continue ;; self) if test "$prev" = dlprefiles; then dlself=yes elif test "$prev" = dlfiles && test "$dlopen_self" != yes; then dlself=yes else dlself=needless export_dynamic=yes fi prev= continue ;; *) if test "$prev" = dlfiles; then dlfiles="$dlfiles $arg" else dlprefiles="$dlprefiles $arg" fi prev= continue ;; esac ;; expsyms) export_symbols="$arg" test -f "$arg" \ || func_fatal_error "symbol file \`$arg' does not exist" prev= continue ;; expsyms_regex) export_symbols_regex="$arg" prev= continue ;; framework) case $host in *-*-darwin*) case "$deplibs " in *" $qarg.ltframework "*) ;; *) deplibs="$deplibs $qarg.ltframework" # this is fixed later ;; esac ;; esac prev= continue ;; inst_prefix) inst_prefix_dir="$arg" prev= continue ;; objectlist) if test -f "$arg"; then save_arg=$arg moreargs= for fil in `cat "$save_arg"` do # moreargs="$moreargs $fil" arg=$fil # A libtool-controlled object. # Check to see that this really is a libtool object. if func_lalib_unsafe_p "$arg"; then pic_object= non_pic_object= # Read the .lo file func_source "$arg" if test -z "$pic_object" || test -z "$non_pic_object" || test "$pic_object" = none && test "$non_pic_object" = none; then func_fatal_error "cannot find name of object for \`$arg'" fi # Extract subdirectory from the argument. func_dirname "$arg" "/" "" xdir="$func_dirname_result" if test "$pic_object" != none; then # Prepend the subdirectory the object is found in. pic_object="$xdir$pic_object" if test "$prev" = dlfiles; then if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then dlfiles="$dlfiles $pic_object" prev= continue else # If libtool objects are unsupported, then we need to preload. prev=dlprefiles fi fi # CHECK ME: I think I busted this. -Ossama if test "$prev" = dlprefiles; then # Preload the old-style object. dlprefiles="$dlprefiles $pic_object" prev= fi # A PIC object. func_append libobjs " $pic_object" arg="$pic_object" fi # Non-PIC object. if test "$non_pic_object" != none; then # Prepend the subdirectory the object is found in. non_pic_object="$xdir$non_pic_object" # A standard non-PIC object func_append non_pic_objects " $non_pic_object" if test -z "$pic_object" || test "$pic_object" = none ; then arg="$non_pic_object" fi else # If the PIC object exists, use it instead. # $xdir was prepended to $pic_object above. non_pic_object="$pic_object" func_append non_pic_objects " $non_pic_object" fi else # Only an error if not doing a dry-run. if $opt_dry_run; then # Extract subdirectory from the argument. func_dirname "$arg" "/" "" xdir="$func_dirname_result" func_lo2o "$arg" pic_object=$xdir$objdir/$func_lo2o_result non_pic_object=$xdir$func_lo2o_result func_append libobjs " $pic_object" func_append non_pic_objects " $non_pic_object" else func_fatal_error "\`$arg' is not a valid libtool object" fi fi done else func_fatal_error "link input file \`$arg' does not exist" fi arg=$save_arg prev= continue ;; precious_regex) precious_files_regex="$arg" prev= continue ;; release) release="-$arg" prev= continue ;; rpath | xrpath) # We need an absolute path. case $arg in [\\/]* | [A-Za-z]:[\\/]*) ;; *) func_fatal_error "only absolute run-paths are allowed" ;; esac if test "$prev" = rpath; then case "$rpath " in *" $arg "*) ;; *) rpath="$rpath $arg" ;; esac else case "$xrpath " in *" $arg "*) ;; *) xrpath="$xrpath $arg" ;; esac fi prev= continue ;; shrext) shrext_cmds="$arg" prev= continue ;; weak) weak_libs="$weak_libs $arg" prev= continue ;; xcclinker) linker_flags="$linker_flags $qarg" compiler_flags="$compiler_flags $qarg" prev= func_append compile_command " $qarg" func_append finalize_command " $qarg" continue ;; xcompiler) compiler_flags="$compiler_flags $qarg" prev= func_append compile_command " $qarg" func_append finalize_command " $qarg" continue ;; xlinker) linker_flags="$linker_flags $qarg" compiler_flags="$compiler_flags $wl$qarg" prev= func_append compile_command " $wl$qarg" func_append finalize_command " $wl$qarg" continue ;; *) eval "$prev=\"\$arg\"" prev= continue ;; esac fi # test -n "$prev" prevarg="$arg" case $arg in -all-static) if test -n "$link_static_flag"; then # See comment for -static flag below, for more details. func_append compile_command " $link_static_flag" func_append finalize_command " $link_static_flag" fi continue ;; -allow-undefined) # FIXME: remove this flag sometime in the future. func_fatal_error "\`-allow-undefined' must not be used because it is the default" ;; -avoid-version) avoid_version=yes continue ;; -dlopen) prev=dlfiles continue ;; -dlpreopen) prev=dlprefiles continue ;; -export-dynamic) export_dynamic=yes continue ;; -export-symbols | -export-symbols-regex) if test -n "$export_symbols" || test -n "$export_symbols_regex"; then func_fatal_error "more than one -exported-symbols argument is not allowed" fi if test "X$arg" = "X-export-symbols"; then prev=expsyms else prev=expsyms_regex fi continue ;; -framework) prev=framework continue ;; -inst-prefix-dir) prev=inst_prefix continue ;; # The native IRIX linker understands -LANG:*, -LIST:* and -LNO:* # so, if we see these flags be careful not to treat them like -L -L[A-Z][A-Z]*:*) case $with_gcc/$host in no/*-*-irix* | /*-*-irix*) func_append compile_command " $arg" func_append finalize_command " $arg" ;; esac continue ;; -L*) func_stripname '-L' '' "$arg" dir=$func_stripname_result if test -z "$dir"; then if test "$#" -gt 0; then func_fatal_error "require no space between \`-L' and \`$1'" else func_fatal_error "need path for \`-L' option" fi fi # We need an absolute path. case $dir in [\\/]* | [A-Za-z]:[\\/]*) ;; *) absdir=`cd "$dir" && pwd` test -z "$absdir" && \ func_fatal_error "cannot determine absolute directory name of \`$dir'" dir="$absdir" ;; esac case "$deplibs " in *" -L$dir "*) ;; *) deplibs="$deplibs -L$dir" lib_search_path="$lib_search_path $dir" ;; esac case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*) testbindir=`$ECHO "X$dir" | $Xsed -e 's*/lib$*/bin*'` case :$dllsearchpath: in *":$dir:"*) ;; ::) dllsearchpath=$dir;; *) dllsearchpath="$dllsearchpath:$dir";; esac case :$dllsearchpath: in *":$testbindir:"*) ;; ::) dllsearchpath=$testbindir;; *) dllsearchpath="$dllsearchpath:$testbindir";; esac ;; esac continue ;; -l*) if test "X$arg" = "X-lc" || test "X$arg" = "X-lm"; then case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-beos* | *-cegcc*) # These systems don't actually have a C or math library (as such) continue ;; *-*-os2*) # These systems don't actually have a C library (as such) test "X$arg" = "X-lc" && continue ;; *-*-openbsd* | *-*-freebsd* | *-*-dragonfly*) # Do not include libc due to us having libc/libc_r. test "X$arg" = "X-lc" && continue ;; *-*-rhapsody* | *-*-darwin1.[012]) # Rhapsody C and math libraries are in the System framework deplibs="$deplibs System.ltframework" continue ;; *-*-sco3.2v5* | *-*-sco5v6*) # Causes problems with __ctype test "X$arg" = "X-lc" && continue ;; *-*-sysv4.2uw2* | *-*-sysv5* | *-*-unixware* | *-*-OpenUNIX*) # Compiler inserts libc in the correct place for threads to work test "X$arg" = "X-lc" && continue ;; esac elif test "X$arg" = "X-lc_r"; then case $host in *-*-openbsd* | *-*-freebsd* | *-*-dragonfly*) # Do not include libc_r directly, use -pthread flag. continue ;; esac fi deplibs="$deplibs $arg" continue ;; -module) module=yes continue ;; # Tru64 UNIX uses -model [arg] to determine the layout of C++ # classes, name mangling, and exception handling. # Darwin uses the -arch flag to determine output architecture. -model|-arch|-isysroot) compiler_flags="$compiler_flags $arg" func_append compile_command " $arg" func_append finalize_command " $arg" prev=xcompiler continue ;; -mt|-mthreads|-kthread|-Kthread|-pthread|-pthreads|--thread-safe|-threads) compiler_flags="$compiler_flags $arg" func_append compile_command " $arg" func_append finalize_command " $arg" case "$new_inherited_linker_flags " in *" $arg "*) ;; * ) new_inherited_linker_flags="$new_inherited_linker_flags $arg" ;; esac continue ;; -multi_module) single_module="${wl}-multi_module" continue ;; -no-fast-install) fast_install=no continue ;; -no-install) case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-darwin* | *-cegcc*) # The PATH hackery in wrapper scripts is required on Windows # and Darwin in order for the loader to find any dlls it needs. func_warning "\`-no-install' is ignored for $host" func_warning "assuming \`-no-fast-install' instead" fast_install=no ;; *) no_install=yes ;; esac continue ;; -no-undefined) allow_undefined=no continue ;; -objectlist) prev=objectlist continue ;; -o) prev=output ;; -precious-files-regex) prev=precious_regex continue ;; -release) prev=release continue ;; -rpath) prev=rpath continue ;; -R) prev=xrpath continue ;; -R*) func_stripname '-R' '' "$arg" dir=$func_stripname_result # We need an absolute path. case $dir in [\\/]* | [A-Za-z]:[\\/]*) ;; *) func_fatal_error "only absolute run-paths are allowed" ;; esac case "$xrpath " in *" $dir "*) ;; *) xrpath="$xrpath $dir" ;; esac continue ;; -shared) # The effects of -shared are defined in a previous loop. continue ;; -shrext) prev=shrext continue ;; -static | -static-libtool-libs) # The effects of -static are defined in a previous loop. # We used to do the same as -all-static on platforms that # didn't have a PIC flag, but the assumption that the effects # would be equivalent was wrong. It would break on at least # Digital Unix and AIX. continue ;; -thread-safe) thread_safe=yes continue ;; -version-info) prev=vinfo continue ;; -version-number) prev=vinfo vinfo_number=yes continue ;; -weak) prev=weak continue ;; -Wc,*) func_stripname '-Wc,' '' "$arg" args=$func_stripname_result arg= save_ifs="$IFS"; IFS=',' for flag in $args; do IFS="$save_ifs" func_quote_for_eval "$flag" arg="$arg $wl$func_quote_for_eval_result" compiler_flags="$compiler_flags $func_quote_for_eval_result" done IFS="$save_ifs" func_stripname ' ' '' "$arg" arg=$func_stripname_result ;; -Wl,*) func_stripname '-Wl,' '' "$arg" args=$func_stripname_result arg= save_ifs="$IFS"; IFS=',' for flag in $args; do IFS="$save_ifs" func_quote_for_eval "$flag" arg="$arg $wl$func_quote_for_eval_result" compiler_flags="$compiler_flags $wl$func_quote_for_eval_result" linker_flags="$linker_flags $func_quote_for_eval_result" done IFS="$save_ifs" func_stripname ' ' '' "$arg" arg=$func_stripname_result ;; -Xcompiler) prev=xcompiler continue ;; -Xlinker) prev=xlinker continue ;; -XCClinker) prev=xcclinker continue ;; # -msg_* for osf cc -msg_*) func_quote_for_eval "$arg" arg="$func_quote_for_eval_result" ;; # -64, -mips[0-9] enable 64-bit mode on the SGI compiler # -r[0-9][0-9]* specifies the processor on the SGI compiler # -xarch=*, -xtarget=* enable 64-bit mode on the Sun compiler # +DA*, +DD* enable 64-bit mode on the HP compiler # -q* pass through compiler args for the IBM compiler # -m*, -t[45]*, -txscale* pass through architecture-specific # compiler args for GCC # -F/path gives path to uninstalled frameworks, gcc on darwin # -p, -pg, --coverage, -fprofile-* pass through profiling flag for GCC # @file GCC response files -64|-mips[0-9]|-r[0-9][0-9]*|-xarch=*|-xtarget=*|+DA*|+DD*|-q*|-m*| \ -t[45]*|-txscale*|-p|-pg|--coverage|-fprofile-*|-F*|@*) func_quote_for_eval "$arg" arg="$func_quote_for_eval_result" func_append compile_command " $arg" func_append finalize_command " $arg" compiler_flags="$compiler_flags $arg" continue ;; # Some other compiler flag. -* | +*) func_quote_for_eval "$arg" arg="$func_quote_for_eval_result" ;; *.$objext) # A standard object. objs="$objs $arg" ;; *.lo) # A libtool-controlled object. # Check to see that this really is a libtool object. if func_lalib_unsafe_p "$arg"; then pic_object= non_pic_object= # Read the .lo file func_source "$arg" if test -z "$pic_object" || test -z "$non_pic_object" || test "$pic_object" = none && test "$non_pic_object" = none; then func_fatal_error "cannot find name of object for \`$arg'" fi # Extract subdirectory from the argument. func_dirname "$arg" "/" "" xdir="$func_dirname_result" if test "$pic_object" != none; then # Prepend the subdirectory the object is found in. pic_object="$xdir$pic_object" if test "$prev" = dlfiles; then if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then dlfiles="$dlfiles $pic_object" prev= continue else # If libtool objects are unsupported, then we need to preload. prev=dlprefiles fi fi # CHECK ME: I think I busted this. -Ossama if test "$prev" = dlprefiles; then # Preload the old-style object. dlprefiles="$dlprefiles $pic_object" prev= fi # A PIC object. func_append libobjs " $pic_object" arg="$pic_object" fi # Non-PIC object. if test "$non_pic_object" != none; then # Prepend the subdirectory the object is found in. non_pic_object="$xdir$non_pic_object" # A standard non-PIC object func_append non_pic_objects " $non_pic_object" if test -z "$pic_object" || test "$pic_object" = none ; then arg="$non_pic_object" fi else # If the PIC object exists, use it instead. # $xdir was prepended to $pic_object above. non_pic_object="$pic_object" func_append non_pic_objects " $non_pic_object" fi else # Only an error if not doing a dry-run. if $opt_dry_run; then # Extract subdirectory from the argument. func_dirname "$arg" "/" "" xdir="$func_dirname_result" func_lo2o "$arg" pic_object=$xdir$objdir/$func_lo2o_result non_pic_object=$xdir$func_lo2o_result func_append libobjs " $pic_object" func_append non_pic_objects " $non_pic_object" else func_fatal_error "\`$arg' is not a valid libtool object" fi fi ;; *.$libext) # An archive. deplibs="$deplibs $arg" old_deplibs="$old_deplibs $arg" continue ;; *.la) # A libtool-controlled library. if test "$prev" = dlfiles; then # This library was specified with -dlopen. dlfiles="$dlfiles $arg" prev= elif test "$prev" = dlprefiles; then # The library was specified with -dlpreopen. dlprefiles="$dlprefiles $arg" prev= else deplibs="$deplibs $arg" fi continue ;; # Some other compiler argument. *) # Unknown arguments in both finalize_command and compile_command need # to be aesthetically quoted because they are evaled later. func_quote_for_eval "$arg" arg="$func_quote_for_eval_result" ;; esac # arg # Now actually substitute the argument into the commands. if test -n "$arg"; then func_append compile_command " $arg" func_append finalize_command " $arg" fi done # argument parsing loop test -n "$prev" && \ func_fatal_help "the \`$prevarg' option requires an argument" if test "$export_dynamic" = yes && test -n "$export_dynamic_flag_spec"; then eval arg=\"$export_dynamic_flag_spec\" func_append compile_command " $arg" func_append finalize_command " $arg" fi oldlibs= # calculate the name of the file, without its directory func_basename "$output" outputname="$func_basename_result" libobjs_save="$libobjs" if test -n "$shlibpath_var"; then # get the directories listed in $shlibpath_var eval shlib_search_path=\`\$ECHO \"X\${$shlibpath_var}\" \| \$Xsed -e \'s/:/ /g\'\` else shlib_search_path= fi eval sys_lib_search_path=\"$sys_lib_search_path_spec\" eval sys_lib_dlsearch_path=\"$sys_lib_dlsearch_path_spec\" func_dirname "$output" "/" "" output_objdir="$func_dirname_result$objdir" # Create the object directory. func_mkdir_p "$output_objdir" # Determine the type of output case $output in "") func_fatal_help "you must specify an output file" ;; *.$libext) linkmode=oldlib ;; *.lo | *.$objext) linkmode=obj ;; *.la) linkmode=lib ;; *) linkmode=prog ;; # Anything else should be a program. esac specialdeplibs= libs= # Find all interdependent deplibs by searching for libraries # that are linked more than once (e.g. -la -lb -la) for deplib in $deplibs; do if $opt_duplicate_deps ; then case "$libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac fi libs="$libs $deplib" done if test "$linkmode" = lib; then libs="$predeps $libs $compiler_lib_search_path $postdeps" # Compute libraries that are listed more than once in $predeps # $postdeps and mark them as special (i.e., whose duplicates are # not to be eliminated). pre_post_deps= if $opt_duplicate_compiler_generated_deps; then for pre_post_dep in $predeps $postdeps; do case "$pre_post_deps " in *" $pre_post_dep "*) specialdeplibs="$specialdeplibs $pre_post_deps" ;; esac pre_post_deps="$pre_post_deps $pre_post_dep" done fi pre_post_deps= fi deplibs= newdependency_libs= newlib_search_path= need_relink=no # whether we're linking any uninstalled libtool libraries notinst_deplibs= # not-installed libtool libraries notinst_path= # paths that contain not-installed libtool libraries case $linkmode in lib) passes="conv dlpreopen link" for file in $dlfiles $dlprefiles; do case $file in *.la) ;; *) func_fatal_help "libraries can \`-dlopen' only libtool libraries: $file" ;; esac done ;; prog) compile_deplibs= finalize_deplibs= alldeplibs=no newdlfiles= newdlprefiles= passes="conv scan dlopen dlpreopen link" ;; *) passes="conv" ;; esac for pass in $passes; do # The preopen pass in lib mode reverses $deplibs; put it back here # so that -L comes before libs that need it for instance... if test "$linkmode,$pass" = "lib,link"; then ## FIXME: Find the place where the list is rebuilt in the wrong ## order, and fix it there properly tmp_deplibs= for deplib in $deplibs; do tmp_deplibs="$deplib $tmp_deplibs" done deplibs="$tmp_deplibs" fi if test "$linkmode,$pass" = "lib,link" || test "$linkmode,$pass" = "prog,scan"; then libs="$deplibs" deplibs= fi if test "$linkmode" = prog; then case $pass in dlopen) libs="$dlfiles" ;; dlpreopen) libs="$dlprefiles" ;; link) libs="$deplibs %DEPLIBS%" test "X$link_all_deplibs" != Xno && libs="$libs $dependency_libs" ;; esac fi if test "$linkmode,$pass" = "lib,dlpreopen"; then # Collect and forward deplibs of preopened libtool libs for lib in $dlprefiles; do # Ignore non-libtool-libs dependency_libs= case $lib in *.la) func_source "$lib" ;; esac # Collect preopened libtool deplibs, except any this library # has declared as weak libs for deplib in $dependency_libs; do deplib_base=`$ECHO "X$deplib" | $Xsed -e "$basename"` case " $weak_libs " in *" $deplib_base "*) ;; *) deplibs="$deplibs $deplib" ;; esac done done libs="$dlprefiles" fi if test "$pass" = dlopen; then # Collect dlpreopened libraries save_deplibs="$deplibs" deplibs= fi for deplib in $libs; do lib= found=no case $deplib in -mt|-mthreads|-kthread|-Kthread|-pthread|-pthreads|--thread-safe|-threads) if test "$linkmode,$pass" = "prog,link"; then compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" else compiler_flags="$compiler_flags $deplib" if test "$linkmode" = lib ; then case "$new_inherited_linker_flags " in *" $deplib "*) ;; * ) new_inherited_linker_flags="$new_inherited_linker_flags $deplib" ;; esac fi fi continue ;; -l*) if test "$linkmode" != lib && test "$linkmode" != prog; then func_warning "\`-l' is ignored for archives/objects" continue fi func_stripname '-l' '' "$deplib" name=$func_stripname_result if test "$linkmode" = lib; then searchdirs="$newlib_search_path $lib_search_path $compiler_lib_search_dirs $sys_lib_search_path $shlib_search_path" else searchdirs="$newlib_search_path $lib_search_path $sys_lib_search_path $shlib_search_path" fi for searchdir in $searchdirs; do for search_ext in .la $std_shrext .so .a; do # Search the libtool library lib="$searchdir/lib${name}${search_ext}" if test -f "$lib"; then if test "$search_ext" = ".la"; then found=yes else found=no fi break 2 fi done done if test "$found" != yes; then # deplib doesn't seem to be a libtool library if test "$linkmode,$pass" = "prog,link"; then compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" else deplibs="$deplib $deplibs" test "$linkmode" = lib && newdependency_libs="$deplib $newdependency_libs" fi continue else # deplib is a libtool library # If $allow_libtool_libs_with_static_runtimes && $deplib is a stdlib, # We need to do some special things here, and not later. if test "X$allow_libtool_libs_with_static_runtimes" = "Xyes" ; then case " $predeps $postdeps " in *" $deplib "*) if func_lalib_p "$lib"; then library_names= old_library= func_source "$lib" for l in $old_library $library_names; do ll="$l" done if test "X$ll" = "X$old_library" ; then # only static version available found=no func_dirname "$lib" "" "." ladir="$func_dirname_result" lib=$ladir/$old_library if test "$linkmode,$pass" = "prog,link"; then compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" else deplibs="$deplib $deplibs" test "$linkmode" = lib && newdependency_libs="$deplib $newdependency_libs" fi continue fi fi ;; *) ;; esac fi fi ;; # -l *.ltframework) if test "$linkmode,$pass" = "prog,link"; then compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" else deplibs="$deplib $deplibs" if test "$linkmode" = lib ; then case "$new_inherited_linker_flags " in *" $deplib "*) ;; * ) new_inherited_linker_flags="$new_inherited_linker_flags $deplib" ;; esac fi fi continue ;; -L*) case $linkmode in lib) deplibs="$deplib $deplibs" test "$pass" = conv && continue newdependency_libs="$deplib $newdependency_libs" func_stripname '-L' '' "$deplib" newlib_search_path="$newlib_search_path $func_stripname_result" ;; prog) if test "$pass" = conv; then deplibs="$deplib $deplibs" continue fi if test "$pass" = scan; then deplibs="$deplib $deplibs" else compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" fi func_stripname '-L' '' "$deplib" newlib_search_path="$newlib_search_path $func_stripname_result" ;; *) func_warning "\`-L' is ignored for archives/objects" ;; esac # linkmode continue ;; # -L -R*) if test "$pass" = link; then func_stripname '-R' '' "$deplib" dir=$func_stripname_result # Make sure the xrpath contains only unique directories. case "$xrpath " in *" $dir "*) ;; *) xrpath="$xrpath $dir" ;; esac fi deplibs="$deplib $deplibs" continue ;; *.la) lib="$deplib" ;; *.$libext) if test "$pass" = conv; then deplibs="$deplib $deplibs" continue fi case $linkmode in lib) # Linking convenience modules into shared libraries is allowed, # but linking other static libraries is non-portable. case " $dlpreconveniencelibs " in *" $deplib "*) ;; *) valid_a_lib=no case $deplibs_check_method in match_pattern*) set dummy $deplibs_check_method; shift match_pattern_regex=`expr "$deplibs_check_method" : "$1 \(.*\)"` if eval "\$ECHO \"X$deplib\"" 2>/dev/null | $Xsed -e 10q \ | $EGREP "$match_pattern_regex" > /dev/null; then valid_a_lib=yes fi ;; pass_all) valid_a_lib=yes ;; esac if test "$valid_a_lib" != yes; then $ECHO $ECHO "*** Warning: Trying to link with static lib archive $deplib." $ECHO "*** I have the capability to make that library automatically link in when" $ECHO "*** you link to this library. But I can only do this if you have a" $ECHO "*** shared version of the library, which you do not appear to have" $ECHO "*** because the file extensions .$libext of this argument makes me believe" $ECHO "*** that it is just a static archive that I should not use here." else $ECHO $ECHO "*** Warning: Linking the shared library $output against the" $ECHO "*** static library $deplib is not portable!" deplibs="$deplib $deplibs" fi ;; esac continue ;; prog) if test "$pass" != link; then deplibs="$deplib $deplibs" else compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" fi continue ;; esac # linkmode ;; # *.$libext *.lo | *.$objext) if test "$pass" = conv; then deplibs="$deplib $deplibs" elif test "$linkmode" = prog; then if test "$pass" = dlpreopen || test "$dlopen_support" != yes || test "$build_libtool_libs" = no; then # If there is no dlopen support or we're linking statically, # we need to preload. newdlprefiles="$newdlprefiles $deplib" compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" else newdlfiles="$newdlfiles $deplib" fi fi continue ;; %DEPLIBS%) alldeplibs=yes continue ;; esac # case $deplib if test "$found" = yes || test -f "$lib"; then : else func_fatal_error "cannot find the library \`$lib' or unhandled argument \`$deplib'" fi # Check to see that this really is a libtool archive. func_lalib_unsafe_p "$lib" \ || func_fatal_error "\`$lib' is not a valid libtool archive" func_dirname "$lib" "" "." ladir="$func_dirname_result" dlname= dlopen= dlpreopen= libdir= library_names= old_library= inherited_linker_flags= # If the library was installed with an old release of libtool, # it will not redefine variables installed, or shouldnotlink installed=yes shouldnotlink=no avoidtemprpath= # Read the .la file func_source "$lib" # Convert "-framework foo" to "foo.ltframework" if test -n "$inherited_linker_flags"; then tmp_inherited_linker_flags=`$ECHO "X$inherited_linker_flags" | $Xsed -e 's/-framework \([^ $]*\)/\1.ltframework/g'` for tmp_inherited_linker_flag in $tmp_inherited_linker_flags; do case " $new_inherited_linker_flags " in *" $tmp_inherited_linker_flag "*) ;; *) new_inherited_linker_flags="$new_inherited_linker_flags $tmp_inherited_linker_flag";; esac done fi dependency_libs=`$ECHO "X $dependency_libs" | $Xsed -e 's% \([^ $]*\).ltframework% -framework \1%g'` if test "$linkmode,$pass" = "lib,link" || test "$linkmode,$pass" = "prog,scan" || { test "$linkmode" != prog && test "$linkmode" != lib; }; then test -n "$dlopen" && dlfiles="$dlfiles $dlopen" test -n "$dlpreopen" && dlprefiles="$dlprefiles $dlpreopen" fi if test "$pass" = conv; then # Only check for convenience libraries deplibs="$lib $deplibs" if test -z "$libdir"; then if test -z "$old_library"; then func_fatal_error "cannot find name of link library for \`$lib'" fi # It is a libtool convenience library, so add in its objects. convenience="$convenience $ladir/$objdir/$old_library" old_convenience="$old_convenience $ladir/$objdir/$old_library" tmp_libs= for deplib in $dependency_libs; do deplibs="$deplib $deplibs" if $opt_duplicate_deps ; then case "$tmp_libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac fi tmp_libs="$tmp_libs $deplib" done elif test "$linkmode" != prog && test "$linkmode" != lib; then func_fatal_error "\`$lib' is not a convenience library" fi continue fi # $pass = conv # Get the name of the library we link against. linklib= for l in $old_library $library_names; do linklib="$l" done if test -z "$linklib"; then func_fatal_error "cannot find name of link library for \`$lib'" fi # This library was specified with -dlopen. if test "$pass" = dlopen; then if test -z "$libdir"; then func_fatal_error "cannot -dlopen a convenience library: \`$lib'" fi if test -z "$dlname" || test "$dlopen_support" != yes || test "$build_libtool_libs" = no; then # If there is no dlname, no dlopen support or we're linking # statically, we need to preload. We also need to preload any # dependent libraries so libltdl's deplib preloader doesn't # bomb out in the load deplibs phase. dlprefiles="$dlprefiles $lib $dependency_libs" else newdlfiles="$newdlfiles $lib" fi continue fi # $pass = dlopen # We need an absolute path. case $ladir in [\\/]* | [A-Za-z]:[\\/]*) abs_ladir="$ladir" ;; *) abs_ladir=`cd "$ladir" && pwd` if test -z "$abs_ladir"; then func_warning "cannot determine absolute directory name of \`$ladir'" func_warning "passing it literally to the linker, although it might fail" abs_ladir="$ladir" fi ;; esac func_basename "$lib" laname="$func_basename_result" # Find the relevant object directory and library name. if test "X$installed" = Xyes; then if test ! -f "$libdir/$linklib" && test -f "$abs_ladir/$linklib"; then func_warning "library \`$lib' was moved." dir="$ladir" absdir="$abs_ladir" libdir="$abs_ladir" else dir="$libdir" absdir="$libdir" fi test "X$hardcode_automatic" = Xyes && avoidtemprpath=yes else if test ! -f "$ladir/$objdir/$linklib" && test -f "$abs_ladir/$linklib"; then dir="$ladir" absdir="$abs_ladir" # Remove this search path later notinst_path="$notinst_path $abs_ladir" else dir="$ladir/$objdir" absdir="$abs_ladir/$objdir" # Remove this search path later notinst_path="$notinst_path $abs_ladir" fi fi # $installed = yes func_stripname 'lib' '.la' "$laname" name=$func_stripname_result # This library was specified with -dlpreopen. if test "$pass" = dlpreopen; then if test -z "$libdir" && test "$linkmode" = prog; then func_fatal_error "only libraries may -dlpreopen a convenience library: \`$lib'" fi # Prefer using a static library (so that no silly _DYNAMIC symbols # are required to link). if test -n "$old_library"; then newdlprefiles="$newdlprefiles $dir/$old_library" # Keep a list of preopened convenience libraries to check # that they are being used correctly in the link pass. test -z "$libdir" && \ dlpreconveniencelibs="$dlpreconveniencelibs $dir/$old_library" # Otherwise, use the dlname, so that lt_dlopen finds it. elif test -n "$dlname"; then newdlprefiles="$newdlprefiles $dir/$dlname" else newdlprefiles="$newdlprefiles $dir/$linklib" fi fi # $pass = dlpreopen if test -z "$libdir"; then # Link the convenience library if test "$linkmode" = lib; then deplibs="$dir/$old_library $deplibs" elif test "$linkmode,$pass" = "prog,link"; then compile_deplibs="$dir/$old_library $compile_deplibs" finalize_deplibs="$dir/$old_library $finalize_deplibs" else deplibs="$lib $deplibs" # used for prog,scan pass fi continue fi if test "$linkmode" = prog && test "$pass" != link; then newlib_search_path="$newlib_search_path $ladir" deplibs="$lib $deplibs" linkalldeplibs=no if test "$link_all_deplibs" != no || test -z "$library_names" || test "$build_libtool_libs" = no; then linkalldeplibs=yes fi tmp_libs= for deplib in $dependency_libs; do case $deplib in -L*) func_stripname '-L' '' "$deplib" newlib_search_path="$newlib_search_path $func_stripname_result" ;; esac # Need to link against all dependency_libs? if test "$linkalldeplibs" = yes; then deplibs="$deplib $deplibs" else # Need to hardcode shared library paths # or/and link against static libraries newdependency_libs="$deplib $newdependency_libs" fi if $opt_duplicate_deps ; then case "$tmp_libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac fi tmp_libs="$tmp_libs $deplib" done # for deplib continue fi # $linkmode = prog... if test "$linkmode,$pass" = "prog,link"; then if test -n "$library_names" && { { test "$prefer_static_libs" = no || test "$prefer_static_libs,$installed" = "built,yes"; } || test -z "$old_library"; }; then # We need to hardcode the library path if test -n "$shlibpath_var" && test -z "$avoidtemprpath" ; then # Make sure the rpath contains only unique directories. case "$temp_rpath:" in *"$absdir:"*) ;; *) temp_rpath="$temp_rpath$absdir:" ;; esac fi # Hardcode the library path. # Skip directories that are in the system default run-time # search path. case " $sys_lib_dlsearch_path " in *" $absdir "*) ;; *) case "$compile_rpath " in *" $absdir "*) ;; *) compile_rpath="$compile_rpath $absdir" esac ;; esac case " $sys_lib_dlsearch_path " in *" $libdir "*) ;; *) case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" esac ;; esac fi # $linkmode,$pass = prog,link... if test "$alldeplibs" = yes && { test "$deplibs_check_method" = pass_all || { test "$build_libtool_libs" = yes && test -n "$library_names"; }; }; then # We only need to search for static libraries continue fi fi link_static=no # Whether the deplib will be linked statically use_static_libs=$prefer_static_libs if test "$use_static_libs" = built && test "$installed" = yes; then use_static_libs=no fi if test -n "$library_names" && { test "$use_static_libs" = no || test -z "$old_library"; }; then case $host in *cygwin* | *mingw* | *cegcc*) # No point in relinking DLLs because paths are not encoded notinst_deplibs="$notinst_deplibs $lib" need_relink=no ;; *) if test "$installed" = no; then notinst_deplibs="$notinst_deplibs $lib" need_relink=yes fi ;; esac # This is a shared library # Warn about portability, can't link against -module's on some # systems (darwin). Don't bleat about dlopened modules though! dlopenmodule="" for dlpremoduletest in $dlprefiles; do if test "X$dlpremoduletest" = "X$lib"; then dlopenmodule="$dlpremoduletest" break fi done if test -z "$dlopenmodule" && test "$shouldnotlink" = yes && test "$pass" = link; then $ECHO if test "$linkmode" = prog; then $ECHO "*** Warning: Linking the executable $output against the loadable module" else $ECHO "*** Warning: Linking the shared library $output against the loadable module" fi $ECHO "*** $linklib is not portable!" fi if test "$linkmode" = lib && test "$hardcode_into_libs" = yes; then # Hardcode the library path. # Skip directories that are in the system default run-time # search path. case " $sys_lib_dlsearch_path " in *" $absdir "*) ;; *) case "$compile_rpath " in *" $absdir "*) ;; *) compile_rpath="$compile_rpath $absdir" esac ;; esac case " $sys_lib_dlsearch_path " in *" $libdir "*) ;; *) case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" esac ;; esac fi if test -n "$old_archive_from_expsyms_cmds"; then # figure out the soname set dummy $library_names shift realname="$1" shift libname=`eval "\\$ECHO \"$libname_spec\""` # use dlname if we got it. it's perfectly good, no? if test -n "$dlname"; then soname="$dlname" elif test -n "$soname_spec"; then # bleh windows case $host in *cygwin* | mingw* | *cegcc*) func_arith $current - $age major=$func_arith_result versuffix="-$major" ;; esac eval soname=\"$soname_spec\" else soname="$realname" fi # Make a new name for the extract_expsyms_cmds to use soroot="$soname" func_basename "$soroot" soname="$func_basename_result" func_stripname 'lib' '.dll' "$soname" newlib=libimp-$func_stripname_result.a # If the library has no export list, then create one now if test -f "$output_objdir/$soname-def"; then : else func_verbose "extracting exported symbol list from \`$soname'" func_execute_cmds "$extract_expsyms_cmds" 'exit $?' fi # Create $newlib if test -f "$output_objdir/$newlib"; then :; else func_verbose "generating import library for \`$soname'" func_execute_cmds "$old_archive_from_expsyms_cmds" 'exit $?' fi # make sure the library variables are pointing to the new library dir=$output_objdir linklib=$newlib fi # test -n "$old_archive_from_expsyms_cmds" if test "$linkmode" = prog || test "$mode" != relink; then add_shlibpath= add_dir= add= lib_linked=yes case $hardcode_action in immediate | unsupported) if test "$hardcode_direct" = no; then add="$dir/$linklib" case $host in *-*-sco3.2v5.0.[024]*) add_dir="-L$dir" ;; *-*-sysv4*uw2*) add_dir="-L$dir" ;; *-*-sysv5OpenUNIX* | *-*-sysv5UnixWare7.[01].[10]* | \ *-*-unixware7*) add_dir="-L$dir" ;; *-*-darwin* ) # if the lib is a (non-dlopened) module then we can not # link against it, someone is ignoring the earlier warnings if /usr/bin/file -L $add 2> /dev/null | $GREP ": [^:]* bundle" >/dev/null ; then if test "X$dlopenmodule" != "X$lib"; then $ECHO "*** Warning: lib $linklib is a module, not a shared library" if test -z "$old_library" ; then $ECHO $ECHO "*** And there doesn't seem to be a static archive available" $ECHO "*** The link will probably fail, sorry" else add="$dir/$old_library" fi elif test -n "$old_library"; then add="$dir/$old_library" fi fi esac elif test "$hardcode_minus_L" = no; then case $host in *-*-sunos*) add_shlibpath="$dir" ;; esac add_dir="-L$dir" add="-l$name" elif test "$hardcode_shlibpath_var" = no; then add_shlibpath="$dir" add="-l$name" else lib_linked=no fi ;; relink) if test "$hardcode_direct" = yes && test "$hardcode_direct_absolute" = no; then add="$dir/$linklib" elif test "$hardcode_minus_L" = yes; then add_dir="-L$dir" # Try looking first in the location we're being installed to. if test -n "$inst_prefix_dir"; then case $libdir in [\\/]*) add_dir="$add_dir -L$inst_prefix_dir$libdir" ;; esac fi add="-l$name" elif test "$hardcode_shlibpath_var" = yes; then add_shlibpath="$dir" add="-l$name" else lib_linked=no fi ;; *) lib_linked=no ;; esac if test "$lib_linked" != yes; then func_fatal_configuration "unsupported hardcode properties" fi if test -n "$add_shlibpath"; then case :$compile_shlibpath: in *":$add_shlibpath:"*) ;; *) compile_shlibpath="$compile_shlibpath$add_shlibpath:" ;; esac fi if test "$linkmode" = prog; then test -n "$add_dir" && compile_deplibs="$add_dir $compile_deplibs" test -n "$add" && compile_deplibs="$add $compile_deplibs" else test -n "$add_dir" && deplibs="$add_dir $deplibs" test -n "$add" && deplibs="$add $deplibs" if test "$hardcode_direct" != yes && test "$hardcode_minus_L" != yes && test "$hardcode_shlibpath_var" = yes; then case :$finalize_shlibpath: in *":$libdir:"*) ;; *) finalize_shlibpath="$finalize_shlibpath$libdir:" ;; esac fi fi fi if test "$linkmode" = prog || test "$mode" = relink; then add_shlibpath= add_dir= add= # Finalize command for both is simple: just hardcode it. if test "$hardcode_direct" = yes && test "$hardcode_direct_absolute" = no; then add="$libdir/$linklib" elif test "$hardcode_minus_L" = yes; then add_dir="-L$libdir" add="-l$name" elif test "$hardcode_shlibpath_var" = yes; then case :$finalize_shlibpath: in *":$libdir:"*) ;; *) finalize_shlibpath="$finalize_shlibpath$libdir:" ;; esac add="-l$name" elif test "$hardcode_automatic" = yes; then if test -n "$inst_prefix_dir" && test -f "$inst_prefix_dir$libdir/$linklib" ; then add="$inst_prefix_dir$libdir/$linklib" else add="$libdir/$linklib" fi else # We cannot seem to hardcode it, guess we'll fake it. add_dir="-L$libdir" # Try looking first in the location we're being installed to. if test -n "$inst_prefix_dir"; then case $libdir in [\\/]*) add_dir="$add_dir -L$inst_prefix_dir$libdir" ;; esac fi add="-l$name" fi if test "$linkmode" = prog; then test -n "$add_dir" && finalize_deplibs="$add_dir $finalize_deplibs" test -n "$add" && finalize_deplibs="$add $finalize_deplibs" else test -n "$add_dir" && deplibs="$add_dir $deplibs" test -n "$add" && deplibs="$add $deplibs" fi fi elif test "$linkmode" = prog; then # Here we assume that one of hardcode_direct or hardcode_minus_L # is not unsupported. This is valid on all known static and # shared platforms. if test "$hardcode_direct" != unsupported; then test -n "$old_library" && linklib="$old_library" compile_deplibs="$dir/$linklib $compile_deplibs" finalize_deplibs="$dir/$linklib $finalize_deplibs" else compile_deplibs="-l$name -L$dir $compile_deplibs" finalize_deplibs="-l$name -L$dir $finalize_deplibs" fi elif test "$build_libtool_libs" = yes; then # Not a shared library if test "$deplibs_check_method" != pass_all; then # We're trying link a shared library against a static one # but the system doesn't support it. # Just print a warning and add the library to dependency_libs so # that the program can be linked against the static library. $ECHO $ECHO "*** Warning: This system can not link to static lib archive $lib." $ECHO "*** I have the capability to make that library automatically link in when" $ECHO "*** you link to this library. But I can only do this if you have a" $ECHO "*** shared version of the library, which you do not appear to have." if test "$module" = yes; then $ECHO "*** But as you try to build a module library, libtool will still create " $ECHO "*** a static module, that should work as long as the dlopening application" $ECHO "*** is linked with the -dlopen flag to resolve symbols at runtime." if test -z "$global_symbol_pipe"; then $ECHO $ECHO "*** However, this would only work if libtool was able to extract symbol" $ECHO "*** lists from a program, using \`nm' or equivalent, but libtool could" $ECHO "*** not find such a program. So, this module is probably useless." $ECHO "*** \`nm' from GNU binutils and a full rebuild may help." fi if test "$build_old_libs" = no; then build_libtool_libs=module build_old_libs=yes else build_libtool_libs=no fi fi else deplibs="$dir/$old_library $deplibs" link_static=yes fi fi # link shared/static library? if test "$linkmode" = lib; then if test -n "$dependency_libs" && { test "$hardcode_into_libs" != yes || test "$build_old_libs" = yes || test "$link_static" = yes; }; then # Extract -R from dependency_libs temp_deplibs= for libdir in $dependency_libs; do case $libdir in -R*) func_stripname '-R' '' "$libdir" temp_xrpath=$func_stripname_result case " $xrpath " in *" $temp_xrpath "*) ;; *) xrpath="$xrpath $temp_xrpath";; esac;; *) temp_deplibs="$temp_deplibs $libdir";; esac done dependency_libs="$temp_deplibs" fi newlib_search_path="$newlib_search_path $absdir" # Link against this library test "$link_static" = no && newdependency_libs="$abs_ladir/$laname $newdependency_libs" # ... and its dependency_libs tmp_libs= for deplib in $dependency_libs; do newdependency_libs="$deplib $newdependency_libs" if $opt_duplicate_deps ; then case "$tmp_libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac fi tmp_libs="$tmp_libs $deplib" done if test "$link_all_deplibs" != no; then # Add the search paths of all dependency libraries for deplib in $dependency_libs; do path= case $deplib in -L*) path="$deplib" ;; *.la) func_dirname "$deplib" "" "." dir="$func_dirname_result" # We need an absolute path. case $dir in [\\/]* | [A-Za-z]:[\\/]*) absdir="$dir" ;; *) absdir=`cd "$dir" && pwd` if test -z "$absdir"; then func_warning "cannot determine absolute directory name of \`$dir'" absdir="$dir" fi ;; esac if $GREP "^installed=no" $deplib > /dev/null; then case $host in *-*-darwin*) depdepl= eval deplibrary_names=`${SED} -n -e 's/^library_names=\(.*\)$/\1/p' $deplib` if test -n "$deplibrary_names" ; then for tmp in $deplibrary_names ; do depdepl=$tmp done if test -f "$absdir/$objdir/$depdepl" ; then depdepl="$absdir/$objdir/$depdepl" darwin_install_name=`${OTOOL} -L $depdepl | awk '{if (NR == 2) {print $1;exit}}'` if test -z "$darwin_install_name"; then darwin_install_name=`${OTOOL64} -L $depdepl | awk '{if (NR == 2) {print $1;exit}}'` fi compiler_flags="$compiler_flags ${wl}-dylib_file ${wl}${darwin_install_name}:${depdepl}" linker_flags="$linker_flags -dylib_file ${darwin_install_name}:${depdepl}" path= fi fi ;; *) path="-L$absdir/$objdir" ;; esac else eval libdir=`${SED} -n -e 's/^libdir=\(.*\)$/\1/p' $deplib` test -z "$libdir" && \ func_fatal_error "\`$deplib' is not a valid libtool archive" test "$absdir" != "$libdir" && \ func_warning "\`$deplib' seems to be moved" path="-L$absdir" fi ;; esac case " $deplibs " in *" $path "*) ;; *) deplibs="$path $deplibs" ;; esac done fi # link_all_deplibs != no fi # linkmode = lib done # for deplib in $libs if test "$pass" = link; then if test "$linkmode" = "prog"; then compile_deplibs="$new_inherited_linker_flags $compile_deplibs" finalize_deplibs="$new_inherited_linker_flags $finalize_deplibs" else compiler_flags="$compiler_flags "`$ECHO "X $new_inherited_linker_flags" | $Xsed -e 's% \([^ $]*\).ltframework% -framework \1%g'` fi fi dependency_libs="$newdependency_libs" if test "$pass" = dlpreopen; then # Link the dlpreopened libraries before other libraries for deplib in $save_deplibs; do deplibs="$deplib $deplibs" done fi if test "$pass" != dlopen; then if test "$pass" != conv; then # Make sure lib_search_path contains only unique directories. lib_search_path= for dir in $newlib_search_path; do case "$lib_search_path " in *" $dir "*) ;; *) lib_search_path="$lib_search_path $dir" ;; esac done newlib_search_path= fi if test "$linkmode,$pass" != "prog,link"; then vars="deplibs" else vars="compile_deplibs finalize_deplibs" fi for var in $vars dependency_libs; do # Add libraries to $var in reverse order eval tmp_libs=\"\$$var\" new_libs= for deplib in $tmp_libs; do # FIXME: Pedantically, this is the right thing to do, so # that some nasty dependency loop isn't accidentally # broken: #new_libs="$deplib $new_libs" # Pragmatically, this seems to cause very few problems in # practice: case $deplib in -L*) new_libs="$deplib $new_libs" ;; -R*) ;; *) # And here is the reason: when a library appears more # than once as an explicit dependence of a library, or # is implicitly linked in more than once by the # compiler, it is considered special, and multiple # occurrences thereof are not removed. Compare this # with having the same library being listed as a # dependency of multiple other libraries: in this case, # we know (pedantically, we assume) the library does not # need to be listed more than once, so we keep only the # last copy. This is not always right, but it is rare # enough that we require users that really mean to play # such unportable linking tricks to link the library # using -Wl,-lname, so that libtool does not consider it # for duplicate removal. case " $specialdeplibs " in *" $deplib "*) new_libs="$deplib $new_libs" ;; *) case " $new_libs " in *" $deplib "*) ;; *) new_libs="$deplib $new_libs" ;; esac ;; esac ;; esac done tmp_libs= for deplib in $new_libs; do case $deplib in -L*) case " $tmp_libs " in *" $deplib "*) ;; *) tmp_libs="$tmp_libs $deplib" ;; esac ;; *) tmp_libs="$tmp_libs $deplib" ;; esac done eval $var=\"$tmp_libs\" done # for var fi # Last step: remove runtime libs from dependency_libs # (they stay in deplibs) tmp_libs= for i in $dependency_libs ; do case " $predeps $postdeps $compiler_lib_search_path " in *" $i "*) i="" ;; esac if test -n "$i" ; then tmp_libs="$tmp_libs $i" fi done dependency_libs=$tmp_libs done # for pass if test "$linkmode" = prog; then dlfiles="$newdlfiles" fi if test "$linkmode" = prog || test "$linkmode" = lib; then dlprefiles="$newdlprefiles" fi case $linkmode in oldlib) if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then func_warning "\`-dlopen' is ignored for archives" fi case " $deplibs" in *\ -l* | *\ -L*) func_warning "\`-l' and \`-L' are ignored for archives" ;; esac test -n "$rpath" && \ func_warning "\`-rpath' is ignored for archives" test -n "$xrpath" && \ func_warning "\`-R' is ignored for archives" test -n "$vinfo" && \ func_warning "\`-version-info/-version-number' is ignored for archives" test -n "$release" && \ func_warning "\`-release' is ignored for archives" test -n "$export_symbols$export_symbols_regex" && \ func_warning "\`-export-symbols' is ignored for archives" # Now set the variables for building old libraries. build_libtool_libs=no oldlibs="$output" objs="$objs$old_deplibs" ;; lib) # Make sure we only generate libraries of the form `libNAME.la'. case $outputname in lib*) func_stripname 'lib' '.la' "$outputname" name=$func_stripname_result eval shared_ext=\"$shrext_cmds\" eval libname=\"$libname_spec\" ;; *) test "$module" = no && \ func_fatal_help "libtool library \`$output' must begin with \`lib'" if test "$need_lib_prefix" != no; then # Add the "lib" prefix for modules if required func_stripname '' '.la' "$outputname" name=$func_stripname_result eval shared_ext=\"$shrext_cmds\" eval libname=\"$libname_spec\" else func_stripname '' '.la' "$outputname" libname=$func_stripname_result fi ;; esac if test -n "$objs"; then if test "$deplibs_check_method" != pass_all; then func_fatal_error "cannot build libtool library \`$output' from non-libtool objects on this host:$objs" else $ECHO $ECHO "*** Warning: Linking the shared library $output against the non-libtool" $ECHO "*** objects $objs is not portable!" libobjs="$libobjs $objs" fi fi test "$dlself" != no && \ func_warning "\`-dlopen self' is ignored for libtool libraries" set dummy $rpath shift test "$#" -gt 1 && \ func_warning "ignoring multiple \`-rpath's for a libtool library" install_libdir="$1" oldlibs= if test -z "$rpath"; then if test "$build_libtool_libs" = yes; then # Building a libtool convenience library. # Some compilers have problems with a `.al' extension so # convenience libraries should have the same extension an # archive normally would. oldlibs="$output_objdir/$libname.$libext $oldlibs" build_libtool_libs=convenience build_old_libs=yes fi test -n "$vinfo" && \ func_warning "\`-version-info/-version-number' is ignored for convenience libraries" test -n "$release" && \ func_warning "\`-release' is ignored for convenience libraries" else # Parse the version information argument. save_ifs="$IFS"; IFS=':' set dummy $vinfo 0 0 0 shift IFS="$save_ifs" test -n "$7" && \ func_fatal_help "too many parameters to \`-version-info'" # convert absolute version numbers to libtool ages # this retains compatibility with .la files and attempts # to make the code below a bit more comprehensible case $vinfo_number in yes) number_major="$1" number_minor="$2" number_revision="$3" # # There are really only two kinds -- those that # use the current revision as the major version # and those that subtract age and use age as # a minor version. But, then there is irix # which has an extra 1 added just for fun # case $version_type in darwin|linux|osf|windows|none) func_arith $number_major + $number_minor current=$func_arith_result age="$number_minor" revision="$number_revision" ;; freebsd-aout|freebsd-elf|sunos) current="$number_major" revision="$number_minor" age="0" ;; irix|nonstopux) func_arith $number_major + $number_minor current=$func_arith_result age="$number_minor" revision="$number_minor" lt_irix_increment=no ;; *) func_fatal_configuration "$modename: unknown library version type \`$version_type'" ;; esac ;; no) current="$1" revision="$2" age="$3" ;; esac # Check that each of the things are valid numbers. case $current in 0|[1-9]|[1-9][0-9]|[1-9][0-9][0-9]|[1-9][0-9][0-9][0-9]|[1-9][0-9][0-9][0-9][0-9]) ;; *) func_error "CURRENT \`$current' must be a nonnegative integer" func_fatal_error "\`$vinfo' is not valid version information" ;; esac case $revision in 0|[1-9]|[1-9][0-9]|[1-9][0-9][0-9]|[1-9][0-9][0-9][0-9]|[1-9][0-9][0-9][0-9][0-9]) ;; *) func_error "REVISION \`$revision' must be a nonnegative integer" func_fatal_error "\`$vinfo' is not valid version information" ;; esac case $age in 0|[1-9]|[1-9][0-9]|[1-9][0-9][0-9]|[1-9][0-9][0-9][0-9]|[1-9][0-9][0-9][0-9][0-9]) ;; *) func_error "AGE \`$age' must be a nonnegative integer" func_fatal_error "\`$vinfo' is not valid version information" ;; esac if test "$age" -gt "$current"; then func_error "AGE \`$age' is greater than the current interface number \`$current'" func_fatal_error "\`$vinfo' is not valid version information" fi # Calculate the version variables. major= versuffix= verstring= case $version_type in none) ;; darwin) # Like Linux, but with the current version available in # verstring for coding it into the library header func_arith $current - $age major=.$func_arith_result versuffix="$major.$age.$revision" # Darwin ld doesn't like 0 for these options... func_arith $current + 1 minor_current=$func_arith_result xlcverstring="${wl}-compatibility_version ${wl}$minor_current ${wl}-current_version ${wl}$minor_current.$revision" verstring="-compatibility_version $minor_current -current_version $minor_current.$revision" ;; freebsd-aout) major=".$current" versuffix=".$current.$revision"; ;; freebsd-elf) major=".$current" versuffix=".$current" ;; irix | nonstopux) if test "X$lt_irix_increment" = "Xno"; then func_arith $current - $age else func_arith $current - $age + 1 fi major=$func_arith_result case $version_type in nonstopux) verstring_prefix=nonstopux ;; *) verstring_prefix=sgi ;; esac verstring="$verstring_prefix$major.$revision" # Add in all the interfaces that we are compatible with. loop=$revision while test "$loop" -ne 0; do func_arith $revision - $loop iface=$func_arith_result func_arith $loop - 1 loop=$func_arith_result verstring="$verstring_prefix$major.$iface:$verstring" done # Before this point, $major must not contain `.'. major=.$major versuffix="$major.$revision" ;; linux) func_arith $current - $age major=.$func_arith_result versuffix="$major.$age.$revision" ;; osf) func_arith $current - $age major=.$func_arith_result versuffix=".$current.$age.$revision" verstring="$current.$age.$revision" # Add in all the interfaces that we are compatible with. loop=$age while test "$loop" -ne 0; do func_arith $current - $loop iface=$func_arith_result func_arith $loop - 1 loop=$func_arith_result verstring="$verstring:${iface}.0" done # Make executables depend on our current version. verstring="$verstring:${current}.0" ;; qnx) major=".$current" versuffix=".$current" ;; sunos) major=".$current" versuffix=".$current.$revision" ;; windows) # Use '-' rather than '.', since we only want one # extension on DOS 8.3 filesystems. func_arith $current - $age major=$func_arith_result versuffix="-$major" ;; *) func_fatal_configuration "unknown library version type \`$version_type'" ;; esac # Clear the version info if we defaulted, and they specified a release. if test -z "$vinfo" && test -n "$release"; then major= case $version_type in darwin) # we can't check for "0.0" in archive_cmds due to quoting # problems, so we reset it completely verstring= ;; *) verstring="0.0" ;; esac if test "$need_version" = no; then versuffix= else versuffix=".0.0" fi fi # Remove version info from name if versioning should be avoided if test "$avoid_version" = yes && test "$need_version" = no; then major= versuffix= verstring="" fi # Check to see if the archive will have undefined symbols. if test "$allow_undefined" = yes; then if test "$allow_undefined_flag" = unsupported; then func_warning "undefined symbols not allowed in $host shared libraries" build_libtool_libs=no build_old_libs=yes fi else # Don't allow undefined symbols. allow_undefined_flag="$no_undefined_flag" fi fi func_generate_dlsyms "$libname" "$libname" "yes" libobjs="$libobjs $symfileobj" test "X$libobjs" = "X " && libobjs= if test "$mode" != relink; then # Remove our outputs, but don't remove object files since they # may have been created when compiling PIC objects. removelist= tempremovelist=`$ECHO "$output_objdir/*"` for p in $tempremovelist; do case $p in *.$objext | *.gcno) ;; $output_objdir/$outputname | $output_objdir/$libname.* | $output_objdir/${libname}${release}.*) if test "X$precious_files_regex" != "X"; then if $ECHO "$p" | $EGREP -e "$precious_files_regex" >/dev/null 2>&1 then continue fi fi removelist="$removelist $p" ;; *) ;; esac done test -n "$removelist" && \ func_show_eval "${RM}r \$removelist" fi # Now set the variables for building old libraries. if test "$build_old_libs" = yes && test "$build_libtool_libs" != convenience ; then oldlibs="$oldlibs $output_objdir/$libname.$libext" # Transform .lo files to .o files. oldobjs="$objs "`$ECHO "X$libobjs" | $SP2NL | $Xsed -e '/\.'${libext}'$/d' -e "$lo2o" | $NL2SP` fi # Eliminate all temporary directories. #for path in $notinst_path; do # lib_search_path=`$ECHO "X$lib_search_path " | $Xsed -e "s% $path % %g"` # deplibs=`$ECHO "X$deplibs " | $Xsed -e "s% -L$path % %g"` # dependency_libs=`$ECHO "X$dependency_libs " | $Xsed -e "s% -L$path % %g"` #done if test -n "$xrpath"; then # If the user specified any rpath flags, then add them. temp_xrpath= for libdir in $xrpath; do temp_xrpath="$temp_xrpath -R$libdir" case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" ;; esac done if test "$hardcode_into_libs" != yes || test "$build_old_libs" = yes; then dependency_libs="$temp_xrpath $dependency_libs" fi fi # Make sure dlfiles contains only unique files that won't be dlpreopened old_dlfiles="$dlfiles" dlfiles= for lib in $old_dlfiles; do case " $dlprefiles $dlfiles " in *" $lib "*) ;; *) dlfiles="$dlfiles $lib" ;; esac done # Make sure dlprefiles contains only unique files old_dlprefiles="$dlprefiles" dlprefiles= for lib in $old_dlprefiles; do case "$dlprefiles " in *" $lib "*) ;; *) dlprefiles="$dlprefiles $lib" ;; esac done if test "$build_libtool_libs" = yes; then if test -n "$rpath"; then case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-beos* | *-cegcc*) # these systems don't actually have a c library (as such)! ;; *-*-rhapsody* | *-*-darwin1.[012]) # Rhapsody C library is in the System framework deplibs="$deplibs System.ltframework" ;; *-*-netbsd*) # Don't link with libc until the a.out ld.so is fixed. ;; *-*-openbsd* | *-*-freebsd* | *-*-dragonfly*) # Do not include libc due to us having libc/libc_r. ;; *-*-sco3.2v5* | *-*-sco5v6*) # Causes problems with __ctype ;; *-*-sysv4.2uw2* | *-*-sysv5* | *-*-unixware* | *-*-OpenUNIX*) # Compiler inserts libc in the correct place for threads to work ;; *) # Add libc to deplibs on all other systems if necessary. if test "$build_libtool_need_lc" = "yes"; then deplibs="$deplibs -lc" fi ;; esac fi # Transform deplibs into only deplibs that can be linked in shared. name_save=$name libname_save=$libname release_save=$release versuffix_save=$versuffix major_save=$major # I'm not sure if I'm treating the release correctly. I think # release should show up in the -l (ie -lgmp5) so we don't want to # add it in twice. Is that correct? release="" versuffix="" major="" newdeplibs= droppeddeps=no case $deplibs_check_method in pass_all) # Don't check for shared/static. Everything works. # This might be a little naive. We might want to check # whether the library exists or not. But this is on # osf3 & osf4 and I'm not really sure... Just # implementing what was already the behavior. newdeplibs=$deplibs ;; test_compile) # This code stresses the "libraries are programs" paradigm to its # limits. Maybe even breaks it. We compile a program, linking it # against the deplibs as a proxy for the library. Then we can check # whether they linked in statically or dynamically with ldd. $opt_dry_run || $RM conftest.c cat > conftest.c </dev/null` for potent_lib in $potential_libs; do # Follow soft links. if ls -lLd "$potent_lib" 2>/dev/null | $GREP " -> " >/dev/null; then continue fi # The statement above tries to avoid entering an # endless loop below, in case of cyclic links. # We might still enter an endless loop, since a link # loop can be closed while we follow links, # but so what? potlib="$potent_lib" while test -h "$potlib" 2>/dev/null; do potliblink=`ls -ld $potlib | ${SED} 's/.* -> //'` case $potliblink in [\\/]* | [A-Za-z]:[\\/]*) potlib="$potliblink";; *) potlib=`$ECHO "X$potlib" | $Xsed -e 's,[^/]*$,,'`"$potliblink";; esac done if eval $file_magic_cmd \"\$potlib\" 2>/dev/null | $SED -e 10q | $EGREP "$file_magic_regex" > /dev/null; then newdeplibs="$newdeplibs $a_deplib" a_deplib="" break 2 fi done done fi if test -n "$a_deplib" ; then droppeddeps=yes $ECHO $ECHO "*** Warning: linker path does not have real file for library $a_deplib." $ECHO "*** I have the capability to make that library automatically link in when" $ECHO "*** you link to this library. But I can only do this if you have a" $ECHO "*** shared version of the library, which you do not appear to have" $ECHO "*** because I did check the linker path looking for a file starting" if test -z "$potlib" ; then $ECHO "*** with $libname but no candidates were found. (...for file magic test)" else $ECHO "*** with $libname and none of the candidates passed a file format test" $ECHO "*** using a file magic. Last file checked: $potlib" fi fi ;; *) # Add a -L argument. newdeplibs="$newdeplibs $a_deplib" ;; esac done # Gone through all deplibs. ;; match_pattern*) set dummy $deplibs_check_method; shift match_pattern_regex=`expr "$deplibs_check_method" : "$1 \(.*\)"` for a_deplib in $deplibs; do case $a_deplib in -l*) func_stripname -l '' "$a_deplib" name=$func_stripname_result if test "X$allow_libtool_libs_with_static_runtimes" = "Xyes" ; then case " $predeps $postdeps " in *" $a_deplib "*) newdeplibs="$newdeplibs $a_deplib" a_deplib="" ;; esac fi if test -n "$a_deplib" ; then libname=`eval "\\$ECHO \"$libname_spec\""` for i in $lib_search_path $sys_lib_search_path $shlib_search_path; do potential_libs=`ls $i/$libname[.-]* 2>/dev/null` for potent_lib in $potential_libs; do potlib="$potent_lib" # see symlink-check above in file_magic test if eval "\$ECHO \"X$potent_lib\"" 2>/dev/null | $Xsed -e 10q | \ $EGREP "$match_pattern_regex" > /dev/null; then newdeplibs="$newdeplibs $a_deplib" a_deplib="" break 2 fi done done fi if test -n "$a_deplib" ; then droppeddeps=yes $ECHO $ECHO "*** Warning: linker path does not have real file for library $a_deplib." $ECHO "*** I have the capability to make that library automatically link in when" $ECHO "*** you link to this library. But I can only do this if you have a" $ECHO "*** shared version of the library, which you do not appear to have" $ECHO "*** because I did check the linker path looking for a file starting" if test -z "$potlib" ; then $ECHO "*** with $libname but no candidates were found. (...for regex pattern test)" else $ECHO "*** with $libname and none of the candidates passed a file format test" $ECHO "*** using a regex pattern. Last file checked: $potlib" fi fi ;; *) # Add a -L argument. newdeplibs="$newdeplibs $a_deplib" ;; esac done # Gone through all deplibs. ;; none | unknown | *) newdeplibs="" tmp_deplibs=`$ECHO "X $deplibs" | $Xsed \ -e 's/ -lc$//' -e 's/ -[LR][^ ]*//g'` if test "X$allow_libtool_libs_with_static_runtimes" = "Xyes" ; then for i in $predeps $postdeps ; do # can't use Xsed below, because $i might contain '/' tmp_deplibs=`$ECHO "X $tmp_deplibs" | $Xsed -e "s,$i,,"` done fi if $ECHO "X $tmp_deplibs" | $Xsed -e 's/[ ]//g' | $GREP . >/dev/null; then $ECHO if test "X$deplibs_check_method" = "Xnone"; then $ECHO "*** Warning: inter-library dependencies are not supported in this platform." else $ECHO "*** Warning: inter-library dependencies are not known to be supported." fi $ECHO "*** All declared inter-library dependencies are being dropped." droppeddeps=yes fi ;; esac versuffix=$versuffix_save major=$major_save release=$release_save libname=$libname_save name=$name_save case $host in *-*-rhapsody* | *-*-darwin1.[012]) # On Rhapsody replace the C library with the System framework newdeplibs=`$ECHO "X $newdeplibs" | $Xsed -e 's/ -lc / System.ltframework /'` ;; esac if test "$droppeddeps" = yes; then if test "$module" = yes; then $ECHO $ECHO "*** Warning: libtool could not satisfy all declared inter-library" $ECHO "*** dependencies of module $libname. Therefore, libtool will create" $ECHO "*** a static module, that should work as long as the dlopening" $ECHO "*** application is linked with the -dlopen flag." if test -z "$global_symbol_pipe"; then $ECHO $ECHO "*** However, this would only work if libtool was able to extract symbol" $ECHO "*** lists from a program, using \`nm' or equivalent, but libtool could" $ECHO "*** not find such a program. So, this module is probably useless." $ECHO "*** \`nm' from GNU binutils and a full rebuild may help." fi if test "$build_old_libs" = no; then oldlibs="$output_objdir/$libname.$libext" build_libtool_libs=module build_old_libs=yes else build_libtool_libs=no fi else $ECHO "*** The inter-library dependencies that have been dropped here will be" $ECHO "*** automatically added whenever a program is linked with this library" $ECHO "*** or is declared to -dlopen it." if test "$allow_undefined" = no; then $ECHO $ECHO "*** Since this library must not contain undefined symbols," $ECHO "*** because either the platform does not support them or" $ECHO "*** it was explicitly requested with -no-undefined," $ECHO "*** libtool will only create a static version of it." if test "$build_old_libs" = no; then oldlibs="$output_objdir/$libname.$libext" build_libtool_libs=module build_old_libs=yes else build_libtool_libs=no fi fi fi fi # Done checking deplibs! deplibs=$newdeplibs fi # Time to change all our "foo.ltframework" stuff back to "-framework foo" case $host in *-*-darwin*) newdeplibs=`$ECHO "X $newdeplibs" | $Xsed -e 's% \([^ $]*\).ltframework% -framework \1%g'` new_inherited_linker_flags=`$ECHO "X $new_inherited_linker_flags" | $Xsed -e 's% \([^ $]*\).ltframework% -framework \1%g'` deplibs=`$ECHO "X $deplibs" | $Xsed -e 's% \([^ $]*\).ltframework% -framework \1%g'` ;; esac # move library search paths that coincide with paths to not yet # installed libraries to the beginning of the library search list new_libs= for path in $notinst_path; do case " $new_libs " in *" -L$path/$objdir "*) ;; *) case " $deplibs " in *" -L$path/$objdir "*) new_libs="$new_libs -L$path/$objdir" ;; esac ;; esac done for deplib in $deplibs; do case $deplib in -L*) case " $new_libs " in *" $deplib "*) ;; *) new_libs="$new_libs $deplib" ;; esac ;; *) new_libs="$new_libs $deplib" ;; esac done deplibs="$new_libs" # All the library-specific variables (install_libdir is set above). library_names= old_library= dlname= # Test again, we may have decided not to build it any more if test "$build_libtool_libs" = yes; then if test "$hardcode_into_libs" = yes; then # Hardcode the library paths hardcode_libdirs= dep_rpath= rpath="$finalize_rpath" test "$mode" != relink && rpath="$compile_rpath$rpath" for libdir in $rpath; do if test -n "$hardcode_libdir_flag_spec"; then if test -n "$hardcode_libdir_separator"; then if test -z "$hardcode_libdirs"; then hardcode_libdirs="$libdir" else # Just accumulate the unique libdirs. case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) ;; *) hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" ;; esac fi else eval flag=\"$hardcode_libdir_flag_spec\" dep_rpath="$dep_rpath $flag" fi elif test -n "$runpath_var"; then case "$perm_rpath " in *" $libdir "*) ;; *) perm_rpath="$perm_rpath $libdir" ;; esac fi done # Substitute the hardcoded libdirs into the rpath. if test -n "$hardcode_libdir_separator" && test -n "$hardcode_libdirs"; then libdir="$hardcode_libdirs" if test -n "$hardcode_libdir_flag_spec_ld"; then eval dep_rpath=\"$hardcode_libdir_flag_spec_ld\" else eval dep_rpath=\"$hardcode_libdir_flag_spec\" fi fi if test -n "$runpath_var" && test -n "$perm_rpath"; then # We should set the runpath_var. rpath= for dir in $perm_rpath; do rpath="$rpath$dir:" done eval "$runpath_var='$rpath\$$runpath_var'; export $runpath_var" fi test -n "$dep_rpath" && deplibs="$dep_rpath $deplibs" fi shlibpath="$finalize_shlibpath" test "$mode" != relink && shlibpath="$compile_shlibpath$shlibpath" if test -n "$shlibpath"; then eval "$shlibpath_var='$shlibpath\$$shlibpath_var'; export $shlibpath_var" fi # Get the real and link names of the library. eval shared_ext=\"$shrext_cmds\" eval library_names=\"$library_names_spec\" set dummy $library_names shift realname="$1" shift if test -n "$soname_spec"; then eval soname=\"$soname_spec\" else soname="$realname" fi if test -z "$dlname"; then dlname=$soname fi lib="$output_objdir/$realname" linknames= for link do linknames="$linknames $link" done # Use standard objects if they are pic test -z "$pic_flag" && libobjs=`$ECHO "X$libobjs" | $SP2NL | $Xsed -e "$lo2o" | $NL2SP` test "X$libobjs" = "X " && libobjs= delfiles= if test -n "$export_symbols" && test -n "$include_expsyms"; then $opt_dry_run || cp "$export_symbols" "$output_objdir/$libname.uexp" export_symbols="$output_objdir/$libname.uexp" delfiles="$delfiles $export_symbols" fi orig_export_symbols= case $host_os in cygwin* | mingw* | cegcc*) if test -n "$export_symbols" && test -z "$export_symbols_regex"; then # exporting using user supplied symfile if test "x`$SED 1q $export_symbols`" != xEXPORTS; then # and it's NOT already a .def file. Must figure out # which of the given symbols are data symbols and tag # them as such. So, trigger use of export_symbols_cmds. # export_symbols gets reassigned inside the "prepare # the list of exported symbols" if statement, so the # include_expsyms logic still works. orig_export_symbols="$export_symbols" export_symbols= always_export_symbols=yes fi fi ;; esac # Prepare the list of exported symbols if test -z "$export_symbols"; then if test "$always_export_symbols" = yes || test -n "$export_symbols_regex"; then func_verbose "generating symbol list for \`$libname.la'" export_symbols="$output_objdir/$libname.exp" $opt_dry_run || $RM $export_symbols cmds=$export_symbols_cmds save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" eval cmd=\"$cmd\" func_len " $cmd" len=$func_len_result if test "$len" -lt "$max_cmd_len" || test "$max_cmd_len" -le -1; then func_show_eval "$cmd" 'exit $?' skipped_export=false else # The command line is too long to execute in one step. func_verbose "using reloadable object file for export list..." skipped_export=: # Break out early, otherwise skipped_export may be # set to false by a later but shorter cmd. break fi done IFS="$save_ifs" if test -n "$export_symbols_regex" && test "X$skipped_export" != "X:"; then func_show_eval '$EGREP -e "$export_symbols_regex" "$export_symbols" > "${export_symbols}T"' func_show_eval '$MV "${export_symbols}T" "$export_symbols"' fi fi fi if test -n "$export_symbols" && test -n "$include_expsyms"; then tmp_export_symbols="$export_symbols" test -n "$orig_export_symbols" && tmp_export_symbols="$orig_export_symbols" $opt_dry_run || eval '$ECHO "X$include_expsyms" | $Xsed | $SP2NL >> "$tmp_export_symbols"' fi if test "X$skipped_export" != "X:" && test -n "$orig_export_symbols"; then # The given exports_symbols file has to be filtered, so filter it. func_verbose "filter symbol list for \`$libname.la' to tag DATA exports" # FIXME: $output_objdir/$libname.filter potentially contains lots of # 's' commands which not all seds can handle. GNU sed should be fine # though. Also, the filter scales superlinearly with the number of # global variables. join(1) would be nice here, but unfortunately # isn't a blessed tool. $opt_dry_run || $SED -e '/[ ,]DATA/!d;s,\(.*\)\([ \,].*\),s|^\1$|\1\2|,' < $export_symbols > $output_objdir/$libname.filter delfiles="$delfiles $export_symbols $output_objdir/$libname.filter" export_symbols=$output_objdir/$libname.def $opt_dry_run || $SED -f $output_objdir/$libname.filter < $orig_export_symbols > $export_symbols fi tmp_deplibs= for test_deplib in $deplibs; do case " $convenience " in *" $test_deplib "*) ;; *) tmp_deplibs="$tmp_deplibs $test_deplib" ;; esac done deplibs="$tmp_deplibs" if test -n "$convenience"; then if test -n "$whole_archive_flag_spec" && test "$compiler_needs_object" = yes && test -z "$libobjs"; then # extract the archives, so we have objects to list. # TODO: could optimize this to just extract one archive. whole_archive_flag_spec= fi if test -n "$whole_archive_flag_spec"; then save_libobjs=$libobjs eval libobjs=\"\$libobjs $whole_archive_flag_spec\" test "X$libobjs" = "X " && libobjs= else gentop="$output_objdir/${outputname}x" generated="$generated $gentop" func_extract_archives $gentop $convenience libobjs="$libobjs $func_extract_archives_result" test "X$libobjs" = "X " && libobjs= fi fi if test "$thread_safe" = yes && test -n "$thread_safe_flag_spec"; then eval flag=\"$thread_safe_flag_spec\" linker_flags="$linker_flags $flag" fi # Make a backup of the uninstalled library when relinking if test "$mode" = relink; then $opt_dry_run || eval '(cd $output_objdir && $RM ${realname}U && $MV $realname ${realname}U)' || exit $? fi # Do each of the archive commands. if test "$module" = yes && test -n "$module_cmds" ; then if test -n "$export_symbols" && test -n "$module_expsym_cmds"; then eval test_cmds=\"$module_expsym_cmds\" cmds=$module_expsym_cmds else eval test_cmds=\"$module_cmds\" cmds=$module_cmds fi else if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then eval test_cmds=\"$archive_expsym_cmds\" cmds=$archive_expsym_cmds else eval test_cmds=\"$archive_cmds\" cmds=$archive_cmds fi fi if test "X$skipped_export" != "X:" && func_len " $test_cmds" && len=$func_len_result && test "$len" -lt "$max_cmd_len" || test "$max_cmd_len" -le -1; then : else # The command line is too long to link in one step, link piecewise # or, if using GNU ld and skipped_export is not :, use a linker # script. # Save the value of $output and $libobjs because we want to # use them later. If we have whole_archive_flag_spec, we # want to use save_libobjs as it was before # whole_archive_flag_spec was expanded, because we can't # assume the linker understands whole_archive_flag_spec. # This may have to be revisited, in case too many # convenience libraries get linked in and end up exceeding # the spec. if test -z "$convenience" || test -z "$whole_archive_flag_spec"; then save_libobjs=$libobjs fi save_output=$output output_la=`$ECHO "X$output" | $Xsed -e "$basename"` # Clear the reloadable object creation command queue and # initialize k to one. test_cmds= concat_cmds= objlist= last_robj= k=1 if test -n "$save_libobjs" && test "X$skipped_export" != "X:" && test "$with_gnu_ld" = yes; then output=${output_objdir}/${output_la}.lnkscript func_verbose "creating GNU ld script: $output" $ECHO 'INPUT (' > $output for obj in $save_libobjs do $ECHO "$obj" >> $output done $ECHO ')' >> $output delfiles="$delfiles $output" elif test -n "$save_libobjs" && test "X$skipped_export" != "X:" && test "X$file_list_spec" != X; then output=${output_objdir}/${output_la}.lnk func_verbose "creating linker input file list: $output" : > $output set x $save_libobjs shift firstobj= if test "$compiler_needs_object" = yes; then firstobj="$1 " shift fi for obj do $ECHO "$obj" >> $output done delfiles="$delfiles $output" output=$firstobj\"$file_list_spec$output\" else if test -n "$save_libobjs"; then func_verbose "creating reloadable object files..." output=$output_objdir/$output_la-${k}.$objext eval test_cmds=\"$reload_cmds\" func_len " $test_cmds" len0=$func_len_result len=$len0 # Loop over the list of objects to be linked. for obj in $save_libobjs do func_len " $obj" func_arith $len + $func_len_result len=$func_arith_result if test "X$objlist" = X || test "$len" -lt "$max_cmd_len"; then func_append objlist " $obj" else # The command $test_cmds is almost too long, add a # command to the queue. if test "$k" -eq 1 ; then # The first file doesn't have a previous command to add. eval concat_cmds=\"$reload_cmds $objlist $last_robj\" else # All subsequent reloadable object files will link in # the last one created. eval concat_cmds=\"\$concat_cmds~$reload_cmds $objlist $last_robj~\$RM $last_robj\" fi last_robj=$output_objdir/$output_la-${k}.$objext func_arith $k + 1 k=$func_arith_result output=$output_objdir/$output_la-${k}.$objext objlist=$obj func_len " $last_robj" func_arith $len0 + $func_len_result len=$func_arith_result fi done # Handle the remaining objects by creating one last # reloadable object file. All subsequent reloadable object # files will link in the last one created. test -z "$concat_cmds" || concat_cmds=$concat_cmds~ eval concat_cmds=\"\${concat_cmds}$reload_cmds $objlist $last_robj\" if test -n "$last_robj"; then eval concat_cmds=\"\${concat_cmds}~\$RM $last_robj\" fi delfiles="$delfiles $output" else output= fi if ${skipped_export-false}; then func_verbose "generating symbol list for \`$libname.la'" export_symbols="$output_objdir/$libname.exp" $opt_dry_run || $RM $export_symbols libobjs=$output # Append the command to create the export file. test -z "$concat_cmds" || concat_cmds=$concat_cmds~ eval concat_cmds=\"\$concat_cmds$export_symbols_cmds\" if test -n "$last_robj"; then eval concat_cmds=\"\$concat_cmds~\$RM $last_robj\" fi fi test -n "$save_libobjs" && func_verbose "creating a temporary reloadable object file: $output" # Loop through the commands generated above and execute them. save_ifs="$IFS"; IFS='~' for cmd in $concat_cmds; do IFS="$save_ifs" $opt_silent || { func_quote_for_expand "$cmd" eval "func_echo $func_quote_for_expand_result" } $opt_dry_run || eval "$cmd" || { lt_exit=$? # Restore the uninstalled library and exit if test "$mode" = relink; then ( cd "$output_objdir" && \ $RM "${realname}T" && \ $MV "${realname}U" "$realname" ) fi exit $lt_exit } done IFS="$save_ifs" if test -n "$export_symbols_regex" && ${skipped_export-false}; then func_show_eval '$EGREP -e "$export_symbols_regex" "$export_symbols" > "${export_symbols}T"' func_show_eval '$MV "${export_symbols}T" "$export_symbols"' fi fi if ${skipped_export-false}; then if test -n "$export_symbols" && test -n "$include_expsyms"; then tmp_export_symbols="$export_symbols" test -n "$orig_export_symbols" && tmp_export_symbols="$orig_export_symbols" $opt_dry_run || eval '$ECHO "X$include_expsyms" | $Xsed | $SP2NL >> "$tmp_export_symbols"' fi if test -n "$orig_export_symbols"; then # The given exports_symbols file has to be filtered, so filter it. func_verbose "filter symbol list for \`$libname.la' to tag DATA exports" # FIXME: $output_objdir/$libname.filter potentially contains lots of # 's' commands which not all seds can handle. GNU sed should be fine # though. Also, the filter scales superlinearly with the number of # global variables. join(1) would be nice here, but unfortunately # isn't a blessed tool. $opt_dry_run || $SED -e '/[ ,]DATA/!d;s,\(.*\)\([ \,].*\),s|^\1$|\1\2|,' < $export_symbols > $output_objdir/$libname.filter delfiles="$delfiles $export_symbols $output_objdir/$libname.filter" export_symbols=$output_objdir/$libname.def $opt_dry_run || $SED -f $output_objdir/$libname.filter < $orig_export_symbols > $export_symbols fi fi libobjs=$output # Restore the value of output. output=$save_output if test -n "$convenience" && test -n "$whole_archive_flag_spec"; then eval libobjs=\"\$libobjs $whole_archive_flag_spec\" test "X$libobjs" = "X " && libobjs= fi # Expand the library linking commands again to reset the # value of $libobjs for piecewise linking. # Do each of the archive commands. if test "$module" = yes && test -n "$module_cmds" ; then if test -n "$export_symbols" && test -n "$module_expsym_cmds"; then cmds=$module_expsym_cmds else cmds=$module_cmds fi else if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then cmds=$archive_expsym_cmds else cmds=$archive_cmds fi fi fi if test -n "$delfiles"; then # Append the command to remove temporary files to $cmds. eval cmds=\"\$cmds~\$RM $delfiles\" fi # Add any objects from preloaded convenience libraries if test -n "$dlprefiles"; then gentop="$output_objdir/${outputname}x" generated="$generated $gentop" func_extract_archives $gentop $dlprefiles libobjs="$libobjs $func_extract_archives_result" test "X$libobjs" = "X " && libobjs= fi save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" eval cmd=\"$cmd\" $opt_silent || { func_quote_for_expand "$cmd" eval "func_echo $func_quote_for_expand_result" } $opt_dry_run || eval "$cmd" || { lt_exit=$? # Restore the uninstalled library and exit if test "$mode" = relink; then ( cd "$output_objdir" && \ $RM "${realname}T" && \ $MV "${realname}U" "$realname" ) fi exit $lt_exit } done IFS="$save_ifs" # Restore the uninstalled library and exit if test "$mode" = relink; then $opt_dry_run || eval '(cd $output_objdir && $RM ${realname}T && $MV $realname ${realname}T && $MV ${realname}U $realname)' || exit $? if test -n "$convenience"; then if test -z "$whole_archive_flag_spec"; then func_show_eval '${RM}r "$gentop"' fi fi exit $EXIT_SUCCESS fi # Create links to the real library. for linkname in $linknames; do if test "$realname" != "$linkname"; then func_show_eval '(cd "$output_objdir" && $RM "$linkname" && $LN_S "$realname" "$linkname")' 'exit $?' fi done # If -module or -export-dynamic was specified, set the dlname. if test "$module" = yes || test "$export_dynamic" = yes; then # On all known operating systems, these are identical. dlname="$soname" fi fi ;; obj) if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then func_warning "\`-dlopen' is ignored for objects" fi case " $deplibs" in *\ -l* | *\ -L*) func_warning "\`-l' and \`-L' are ignored for objects" ;; esac test -n "$rpath" && \ func_warning "\`-rpath' is ignored for objects" test -n "$xrpath" && \ func_warning "\`-R' is ignored for objects" test -n "$vinfo" && \ func_warning "\`-version-info' is ignored for objects" test -n "$release" && \ func_warning "\`-release' is ignored for objects" case $output in *.lo) test -n "$objs$old_deplibs" && \ func_fatal_error "cannot build library object \`$output' from non-libtool objects" libobj=$output func_lo2o "$libobj" obj=$func_lo2o_result ;; *) libobj= obj="$output" ;; esac # Delete the old objects. $opt_dry_run || $RM $obj $libobj # Objects from convenience libraries. This assumes # single-version convenience libraries. Whenever we create # different ones for PIC/non-PIC, this we'll have to duplicate # the extraction. reload_conv_objs= gentop= # reload_cmds runs $LD directly, so let us get rid of # -Wl from whole_archive_flag_spec and hope we can get by with # turning comma into space.. wl= if test -n "$convenience"; then if test -n "$whole_archive_flag_spec"; then eval tmp_whole_archive_flags=\"$whole_archive_flag_spec\" reload_conv_objs=$reload_objs\ `$ECHO "X$tmp_whole_archive_flags" | $Xsed -e 's|,| |g'` else gentop="$output_objdir/${obj}x" generated="$generated $gentop" func_extract_archives $gentop $convenience reload_conv_objs="$reload_objs $func_extract_archives_result" fi fi # Create the old-style object. reload_objs="$objs$old_deplibs "`$ECHO "X$libobjs" | $SP2NL | $Xsed -e '/\.'${libext}$'/d' -e '/\.lib$/d' -e "$lo2o" | $NL2SP`" $reload_conv_objs" ### testsuite: skip nested quoting test output="$obj" func_execute_cmds "$reload_cmds" 'exit $?' # Exit if we aren't doing a library object file. if test -z "$libobj"; then if test -n "$gentop"; then func_show_eval '${RM}r "$gentop"' fi exit $EXIT_SUCCESS fi if test "$build_libtool_libs" != yes; then if test -n "$gentop"; then func_show_eval '${RM}r "$gentop"' fi # Create an invalid libtool object if no PIC, so that we don't # accidentally link it into a program. # $show "echo timestamp > $libobj" # $opt_dry_run || eval "echo timestamp > $libobj" || exit $? exit $EXIT_SUCCESS fi if test -n "$pic_flag" || test "$pic_mode" != default; then # Only do commands if we really have different PIC objects. reload_objs="$libobjs $reload_conv_objs" output="$libobj" func_execute_cmds "$reload_cmds" 'exit $?' fi if test -n "$gentop"; then func_show_eval '${RM}r "$gentop"' fi exit $EXIT_SUCCESS ;; prog) case $host in *cygwin*) func_stripname '' '.exe' "$output" output=$func_stripname_result.exe;; esac test -n "$vinfo" && \ func_warning "\`-version-info' is ignored for programs" test -n "$release" && \ func_warning "\`-release' is ignored for programs" test "$preload" = yes \ && test "$dlopen_support" = unknown \ && test "$dlopen_self" = unknown \ && test "$dlopen_self_static" = unknown && \ func_warning "\`LT_INIT([dlopen])' not used. Assuming no dlopen support." case $host in *-*-rhapsody* | *-*-darwin1.[012]) # On Rhapsody replace the C library is the System framework compile_deplibs=`$ECHO "X $compile_deplibs" | $Xsed -e 's/ -lc / System.ltframework /'` finalize_deplibs=`$ECHO "X $finalize_deplibs" | $Xsed -e 's/ -lc / System.ltframework /'` ;; esac case $host in *-*-darwin*) # Don't allow lazy linking, it breaks C++ global constructors # But is supposedly fixed on 10.4 or later (yay!). if test "$tagname" = CXX ; then case ${MACOSX_DEPLOYMENT_TARGET-10.0} in 10.[0123]) compile_command="$compile_command ${wl}-bind_at_load" finalize_command="$finalize_command ${wl}-bind_at_load" ;; esac fi # Time to change all our "foo.ltframework" stuff back to "-framework foo" compile_deplibs=`$ECHO "X $compile_deplibs" | $Xsed -e 's% \([^ $]*\).ltframework% -framework \1%g'` finalize_deplibs=`$ECHO "X $finalize_deplibs" | $Xsed -e 's% \([^ $]*\).ltframework% -framework \1%g'` ;; esac # move library search paths that coincide with paths to not yet # installed libraries to the beginning of the library search list new_libs= for path in $notinst_path; do case " $new_libs " in *" -L$path/$objdir "*) ;; *) case " $compile_deplibs " in *" -L$path/$objdir "*) new_libs="$new_libs -L$path/$objdir" ;; esac ;; esac done for deplib in $compile_deplibs; do case $deplib in -L*) case " $new_libs " in *" $deplib "*) ;; *) new_libs="$new_libs $deplib" ;; esac ;; *) new_libs="$new_libs $deplib" ;; esac done compile_deplibs="$new_libs" compile_command="$compile_command $compile_deplibs" finalize_command="$finalize_command $finalize_deplibs" if test -n "$rpath$xrpath"; then # If the user specified any rpath flags, then add them. for libdir in $rpath $xrpath; do # This is the magic to use -rpath. case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" ;; esac done fi # Now hardcode the library paths rpath= hardcode_libdirs= for libdir in $compile_rpath $finalize_rpath; do if test -n "$hardcode_libdir_flag_spec"; then if test -n "$hardcode_libdir_separator"; then if test -z "$hardcode_libdirs"; then hardcode_libdirs="$libdir" else # Just accumulate the unique libdirs. case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) ;; *) hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" ;; esac fi else eval flag=\"$hardcode_libdir_flag_spec\" rpath="$rpath $flag" fi elif test -n "$runpath_var"; then case "$perm_rpath " in *" $libdir "*) ;; *) perm_rpath="$perm_rpath $libdir" ;; esac fi case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*) testbindir=`${ECHO} "$libdir" | ${SED} -e 's*/lib$*/bin*'` case :$dllsearchpath: in *":$libdir:"*) ;; ::) dllsearchpath=$libdir;; *) dllsearchpath="$dllsearchpath:$libdir";; esac case :$dllsearchpath: in *":$testbindir:"*) ;; ::) dllsearchpath=$testbindir;; *) dllsearchpath="$dllsearchpath:$testbindir";; esac ;; esac done # Substitute the hardcoded libdirs into the rpath. if test -n "$hardcode_libdir_separator" && test -n "$hardcode_libdirs"; then libdir="$hardcode_libdirs" eval rpath=\" $hardcode_libdir_flag_spec\" fi compile_rpath="$rpath" rpath= hardcode_libdirs= for libdir in $finalize_rpath; do if test -n "$hardcode_libdir_flag_spec"; then if test -n "$hardcode_libdir_separator"; then if test -z "$hardcode_libdirs"; then hardcode_libdirs="$libdir" else # Just accumulate the unique libdirs. case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) ;; *) hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" ;; esac fi else eval flag=\"$hardcode_libdir_flag_spec\" rpath="$rpath $flag" fi elif test -n "$runpath_var"; then case "$finalize_perm_rpath " in *" $libdir "*) ;; *) finalize_perm_rpath="$finalize_perm_rpath $libdir" ;; esac fi done # Substitute the hardcoded libdirs into the rpath. if test -n "$hardcode_libdir_separator" && test -n "$hardcode_libdirs"; then libdir="$hardcode_libdirs" eval rpath=\" $hardcode_libdir_flag_spec\" fi finalize_rpath="$rpath" if test -n "$libobjs" && test "$build_old_libs" = yes; then # Transform all the library objects into standard objects. compile_command=`$ECHO "X$compile_command" | $SP2NL | $Xsed -e "$lo2o" | $NL2SP` finalize_command=`$ECHO "X$finalize_command" | $SP2NL | $Xsed -e "$lo2o" | $NL2SP` fi func_generate_dlsyms "$outputname" "@PROGRAM@" "no" # template prelinking step if test -n "$prelink_cmds"; then func_execute_cmds "$prelink_cmds" 'exit $?' fi wrappers_required=yes case $host in *cygwin* | *mingw* ) if test "$build_libtool_libs" != yes; then wrappers_required=no fi ;; *cegcc) # Disable wrappers for cegcc, we are cross compiling anyway. wrappers_required=no ;; *) if test "$need_relink" = no || test "$build_libtool_libs" != yes; then wrappers_required=no fi ;; esac if test "$wrappers_required" = no; then # Replace the output file specification. compile_command=`$ECHO "X$compile_command" | $Xsed -e 's%@OUTPUT@%'"$output"'%g'` link_command="$compile_command$compile_rpath" # We have no uninstalled library dependencies, so finalize right now. exit_status=0 func_show_eval "$link_command" 'exit_status=$?' # Delete the generated files. if test -f "$output_objdir/${outputname}S.${objext}"; then func_show_eval '$RM "$output_objdir/${outputname}S.${objext}"' fi exit $exit_status fi if test -n "$compile_shlibpath$finalize_shlibpath"; then compile_command="$shlibpath_var=\"$compile_shlibpath$finalize_shlibpath\$$shlibpath_var\" $compile_command" fi if test -n "$finalize_shlibpath"; then finalize_command="$shlibpath_var=\"$finalize_shlibpath\$$shlibpath_var\" $finalize_command" fi compile_var= finalize_var= if test -n "$runpath_var"; then if test -n "$perm_rpath"; then # We should set the runpath_var. rpath= for dir in $perm_rpath; do rpath="$rpath$dir:" done compile_var="$runpath_var=\"$rpath\$$runpath_var\" " fi if test -n "$finalize_perm_rpath"; then # We should set the runpath_var. rpath= for dir in $finalize_perm_rpath; do rpath="$rpath$dir:" done finalize_var="$runpath_var=\"$rpath\$$runpath_var\" " fi fi if test "$no_install" = yes; then # We don't need to create a wrapper script. link_command="$compile_var$compile_command$compile_rpath" # Replace the output file specification. link_command=`$ECHO "X$link_command" | $Xsed -e 's%@OUTPUT@%'"$output"'%g'` # Delete the old output file. $opt_dry_run || $RM $output # Link the executable and exit func_show_eval "$link_command" 'exit $?' exit $EXIT_SUCCESS fi if test "$hardcode_action" = relink; then # Fast installation is not supported link_command="$compile_var$compile_command$compile_rpath" relink_command="$finalize_var$finalize_command$finalize_rpath" func_warning "this platform does not like uninstalled shared libraries" func_warning "\`$output' will be relinked during installation" else if test "$fast_install" != no; then link_command="$finalize_var$compile_command$finalize_rpath" if test "$fast_install" = yes; then relink_command=`$ECHO "X$compile_var$compile_command$compile_rpath" | $Xsed -e 's%@OUTPUT@%\$progdir/\$file%g'` else # fast_install is set to needless relink_command= fi else link_command="$compile_var$compile_command$compile_rpath" relink_command="$finalize_var$finalize_command$finalize_rpath" fi fi # Replace the output file specification. link_command=`$ECHO "X$link_command" | $Xsed -e 's%@OUTPUT@%'"$output_objdir/$outputname"'%g'` # Delete the old output files. $opt_dry_run || $RM $output $output_objdir/$outputname $output_objdir/lt-$outputname func_show_eval "$link_command" 'exit $?' # Now create the wrapper script. func_verbose "creating $output" # Quote the relink command for shipping. if test -n "$relink_command"; then # Preserve any variables that may affect compiler behavior for var in $variables_saved_for_relink; do if eval test -z \"\${$var+set}\"; then relink_command="{ test -z \"\${$var+set}\" || $lt_unset $var || { $var=; export $var; }; }; $relink_command" elif eval var_value=\$$var; test -z "$var_value"; then relink_command="$var=; export $var; $relink_command" else func_quote_for_eval "$var_value" relink_command="$var=$func_quote_for_eval_result; export $var; $relink_command" fi done relink_command="(cd `pwd`; $relink_command)" relink_command=`$ECHO "X$relink_command" | $Xsed -e "$sed_quote_subst"` fi # Quote $ECHO for shipping. if test "X$ECHO" = "X$SHELL $progpath --fallback-echo"; then case $progpath in [\\/]* | [A-Za-z]:[\\/]*) qecho="$SHELL $progpath --fallback-echo";; *) qecho="$SHELL `pwd`/$progpath --fallback-echo";; esac qecho=`$ECHO "X$qecho" | $Xsed -e "$sed_quote_subst"` else qecho=`$ECHO "X$ECHO" | $Xsed -e "$sed_quote_subst"` fi # Only actually do things if not in dry run mode. $opt_dry_run || { # win32 will think the script is a binary if it has # a .exe suffix, so we strip it off here. case $output in *.exe) func_stripname '' '.exe' "$output" output=$func_stripname_result ;; esac # test for cygwin because mv fails w/o .exe extensions case $host in *cygwin*) exeext=.exe func_stripname '' '.exe' "$outputname" outputname=$func_stripname_result ;; *) exeext= ;; esac case $host in *cygwin* | *mingw* ) func_dirname_and_basename "$output" "" "." output_name=$func_basename_result output_path=$func_dirname_result cwrappersource="$output_path/$objdir/lt-$output_name.c" cwrapper="$output_path/$output_name.exe" $RM $cwrappersource $cwrapper trap "$RM $cwrappersource $cwrapper; exit $EXIT_FAILURE" 1 2 15 func_emit_cwrapperexe_src > $cwrappersource # The wrapper executable is built using the $host compiler, # because it contains $host paths and files. If cross- # compiling, it, like the target executable, must be # executed on the $host or under an emulation environment. $opt_dry_run || { $LTCC $LTCFLAGS -o $cwrapper $cwrappersource $STRIP $cwrapper } # Now, create the wrapper script for func_source use: func_ltwrapper_scriptname $cwrapper $RM $func_ltwrapper_scriptname_result trap "$RM $func_ltwrapper_scriptname_result; exit $EXIT_FAILURE" 1 2 15 $opt_dry_run || { # note: this script will not be executed, so do not chmod. if test "x$build" = "x$host" ; then $cwrapper --lt-dump-script > $func_ltwrapper_scriptname_result else func_emit_wrapper no > $func_ltwrapper_scriptname_result fi } ;; * ) $RM $output trap "$RM $output; exit $EXIT_FAILURE" 1 2 15 func_emit_wrapper no > $output chmod +x $output ;; esac } exit $EXIT_SUCCESS ;; esac # See if we need to build an old-fashioned archive. for oldlib in $oldlibs; do if test "$build_libtool_libs" = convenience; then oldobjs="$libobjs_save $symfileobj" addlibs="$convenience" build_libtool_libs=no else if test "$build_libtool_libs" = module; then oldobjs="$libobjs_save" build_libtool_libs=no else oldobjs="$old_deplibs $non_pic_objects" if test "$preload" = yes && test -f "$symfileobj"; then oldobjs="$oldobjs $symfileobj" fi fi addlibs="$old_convenience" fi if test -n "$addlibs"; then gentop="$output_objdir/${outputname}x" generated="$generated $gentop" func_extract_archives $gentop $addlibs oldobjs="$oldobjs $func_extract_archives_result" fi # Do each command in the archive commands. if test -n "$old_archive_from_new_cmds" && test "$build_libtool_libs" = yes; then cmds=$old_archive_from_new_cmds else # Add any objects from preloaded convenience libraries if test -n "$dlprefiles"; then gentop="$output_objdir/${outputname}x" generated="$generated $gentop" func_extract_archives $gentop $dlprefiles oldobjs="$oldobjs $func_extract_archives_result" fi # POSIX demands no paths to be encoded in archives. We have # to avoid creating archives with duplicate basenames if we # might have to extract them afterwards, e.g., when creating a # static archive out of a convenience library, or when linking # the entirety of a libtool archive into another (currently # not supported by libtool). if (for obj in $oldobjs do func_basename "$obj" $ECHO "$func_basename_result" done | sort | sort -uc >/dev/null 2>&1); then : else $ECHO "copying selected object files to avoid basename conflicts..." gentop="$output_objdir/${outputname}x" generated="$generated $gentop" func_mkdir_p "$gentop" save_oldobjs=$oldobjs oldobjs= counter=1 for obj in $save_oldobjs do func_basename "$obj" objbase="$func_basename_result" case " $oldobjs " in " ") oldobjs=$obj ;; *[\ /]"$objbase "*) while :; do # Make sure we don't pick an alternate name that also # overlaps. newobj=lt$counter-$objbase func_arith $counter + 1 counter=$func_arith_result case " $oldobjs " in *[\ /]"$newobj "*) ;; *) if test ! -f "$gentop/$newobj"; then break; fi ;; esac done func_show_eval "ln $obj $gentop/$newobj || cp $obj $gentop/$newobj" oldobjs="$oldobjs $gentop/$newobj" ;; *) oldobjs="$oldobjs $obj" ;; esac done fi eval cmds=\"$old_archive_cmds\" func_len " $cmds" len=$func_len_result if test "$len" -lt "$max_cmd_len" || test "$max_cmd_len" -le -1; then cmds=$old_archive_cmds else # the command line is too long to link in one step, link in parts func_verbose "using piecewise archive linking..." save_RANLIB=$RANLIB RANLIB=: objlist= concat_cmds= save_oldobjs=$oldobjs oldobjs= # Is there a better way of finding the last object in the list? for obj in $save_oldobjs do last_oldobj=$obj done eval test_cmds=\"$old_archive_cmds\" func_len " $test_cmds" len0=$func_len_result len=$len0 for obj in $save_oldobjs do func_len " $obj" func_arith $len + $func_len_result len=$func_arith_result func_append objlist " $obj" if test "$len" -lt "$max_cmd_len"; then : else # the above command should be used before it gets too long oldobjs=$objlist if test "$obj" = "$last_oldobj" ; then RANLIB=$save_RANLIB fi test -z "$concat_cmds" || concat_cmds=$concat_cmds~ eval concat_cmds=\"\${concat_cmds}$old_archive_cmds\" objlist= len=$len0 fi done RANLIB=$save_RANLIB oldobjs=$objlist if test "X$oldobjs" = "X" ; then eval cmds=\"\$concat_cmds\" else eval cmds=\"\$concat_cmds~\$old_archive_cmds\" fi fi fi func_execute_cmds "$cmds" 'exit $?' done test -n "$generated" && \ func_show_eval "${RM}r$generated" # Now create the libtool archive. case $output in *.la) old_library= test "$build_old_libs" = yes && old_library="$libname.$libext" func_verbose "creating $output" # Preserve any variables that may affect compiler behavior for var in $variables_saved_for_relink; do if eval test -z \"\${$var+set}\"; then relink_command="{ test -z \"\${$var+set}\" || $lt_unset $var || { $var=; export $var; }; }; $relink_command" elif eval var_value=\$$var; test -z "$var_value"; then relink_command="$var=; export $var; $relink_command" else func_quote_for_eval "$var_value" relink_command="$var=$func_quote_for_eval_result; export $var; $relink_command" fi done # Quote the link command for shipping. relink_command="(cd `pwd`; $SHELL $progpath $preserve_args --mode=relink $libtool_args @inst_prefix_dir@)" relink_command=`$ECHO "X$relink_command" | $Xsed -e "$sed_quote_subst"` if test "$hardcode_automatic" = yes ; then relink_command= fi # Only create the output if not a dry run. $opt_dry_run || { for installed in no yes; do if test "$installed" = yes; then if test -z "$install_libdir"; then break fi output="$output_objdir/$outputname"i # Replace all uninstalled libtool libraries with the installed ones newdependency_libs= for deplib in $dependency_libs; do case $deplib in *.la) func_basename "$deplib" name="$func_basename_result" eval libdir=`${SED} -n -e 's/^libdir=\(.*\)$/\1/p' $deplib` test -z "$libdir" && \ func_fatal_error "\`$deplib' is not a valid libtool archive" newdependency_libs="$newdependency_libs $libdir/$name" ;; *) newdependency_libs="$newdependency_libs $deplib" ;; esac done dependency_libs="$newdependency_libs" newdlfiles= for lib in $dlfiles; do case $lib in *.la) func_basename "$lib" name="$func_basename_result" eval libdir=`${SED} -n -e 's/^libdir=\(.*\)$/\1/p' $lib` test -z "$libdir" && \ func_fatal_error "\`$lib' is not a valid libtool archive" newdlfiles="$newdlfiles $libdir/$name" ;; *) newdlfiles="$newdlfiles $lib" ;; esac done dlfiles="$newdlfiles" newdlprefiles= for lib in $dlprefiles; do case $lib in *.la) # Only pass preopened files to the pseudo-archive (for # eventual linking with the app. that links it) if we # didn't already link the preopened objects directly into # the library: func_basename "$lib" name="$func_basename_result" eval libdir=`${SED} -n -e 's/^libdir=\(.*\)$/\1/p' $lib` test -z "$libdir" && \ func_fatal_error "\`$lib' is not a valid libtool archive" newdlprefiles="$newdlprefiles $libdir/$name" ;; esac done dlprefiles="$newdlprefiles" else newdlfiles= for lib in $dlfiles; do case $lib in [\\/]* | [A-Za-z]:[\\/]*) abs="$lib" ;; *) abs=`pwd`"/$lib" ;; esac newdlfiles="$newdlfiles $abs" done dlfiles="$newdlfiles" newdlprefiles= for lib in $dlprefiles; do case $lib in [\\/]* | [A-Za-z]:[\\/]*) abs="$lib" ;; *) abs=`pwd`"/$lib" ;; esac newdlprefiles="$newdlprefiles $abs" done dlprefiles="$newdlprefiles" fi $RM $output # place dlname in correct position for cygwin tdlname=$dlname case $host,$output,$installed,$module,$dlname in *cygwin*,*lai,yes,no,*.dll | *mingw*,*lai,yes,no,*.dll | *cegcc*,*lai,yes,no,*.dll) tdlname=../bin/$dlname ;; esac $ECHO > $output "\ # $outputname - a libtool library file # Generated by $PROGRAM (GNU $PACKAGE$TIMESTAMP) $VERSION # # Please DO NOT delete this file! # It is necessary for linking the library. # The name that we can dlopen(3). dlname='$tdlname' # Names of this library. library_names='$library_names' # The name of the static archive. old_library='$old_library' # Linker flags that can not go in dependency_libs. inherited_linker_flags='$new_inherited_linker_flags' # Libraries that this one depends upon. dependency_libs='$dependency_libs' # Names of additional weak libraries provided by this library weak_library_names='$weak_libs' # Version information for $libname. current=$current age=$age revision=$revision # Is this an already installed library? installed=$installed # Should we warn about portability when linking against -modules? shouldnotlink=$module # Files to dlopen/dlpreopen dlopen='$dlfiles' dlpreopen='$dlprefiles' # Directory that this library needs to be installed in: libdir='$install_libdir'" if test "$installed" = no && test "$need_relink" = yes; then $ECHO >> $output "\ relink_command=\"$relink_command\"" fi done } # Do a symbolic link so that the libtool archive can be found in # LD_LIBRARY_PATH before the program is installed. func_show_eval '( cd "$output_objdir" && $RM "$outputname" && $LN_S "../$outputname" "$outputname" )' 'exit $?' ;; esac exit $EXIT_SUCCESS } { test "$mode" = link || test "$mode" = relink; } && func_mode_link ${1+"$@"} # func_mode_uninstall arg... func_mode_uninstall () { $opt_debug RM="$nonopt" files= rmforce= exit_status=0 # This variable tells wrapper scripts just to set variables rather # than running their programs. libtool_install_magic="$magic" for arg do case $arg in -f) RM="$RM $arg"; rmforce=yes ;; -*) RM="$RM $arg" ;; *) files="$files $arg" ;; esac done test -z "$RM" && \ func_fatal_help "you must specify an RM program" rmdirs= origobjdir="$objdir" for file in $files; do func_dirname "$file" "" "." dir="$func_dirname_result" if test "X$dir" = X.; then objdir="$origobjdir" else objdir="$dir/$origobjdir" fi func_basename "$file" name="$func_basename_result" test "$mode" = uninstall && objdir="$dir" # Remember objdir for removal later, being careful to avoid duplicates if test "$mode" = clean; then case " $rmdirs " in *" $objdir "*) ;; *) rmdirs="$rmdirs $objdir" ;; esac fi # Don't error if the file doesn't exist and rm -f was used. if { test -L "$file"; } >/dev/null 2>&1 || { test -h "$file"; } >/dev/null 2>&1 || test -f "$file"; then : elif test -d "$file"; then exit_status=1 continue elif test "$rmforce" = yes; then continue fi rmfiles="$file" case $name in *.la) # Possibly a libtool archive, so verify it. if func_lalib_p "$file"; then func_source $dir/$name # Delete the libtool libraries and symlinks. for n in $library_names; do rmfiles="$rmfiles $objdir/$n" done test -n "$old_library" && rmfiles="$rmfiles $objdir/$old_library" case "$mode" in clean) case " $library_names " in # " " in the beginning catches empty $dlname *" $dlname "*) ;; *) rmfiles="$rmfiles $objdir/$dlname" ;; esac test -n "$libdir" && rmfiles="$rmfiles $objdir/$name $objdir/${name}i" ;; uninstall) if test -n "$library_names"; then # Do each command in the postuninstall commands. func_execute_cmds "$postuninstall_cmds" 'test "$rmforce" = yes || exit_status=1' fi if test -n "$old_library"; then # Do each command in the old_postuninstall commands. func_execute_cmds "$old_postuninstall_cmds" 'test "$rmforce" = yes || exit_status=1' fi # FIXME: should reinstall the best remaining shared library. ;; esac fi ;; *.lo) # Possibly a libtool object, so verify it. if func_lalib_p "$file"; then # Read the .lo file func_source $dir/$name # Add PIC object to the list of files to remove. if test -n "$pic_object" && test "$pic_object" != none; then rmfiles="$rmfiles $dir/$pic_object" fi # Add non-PIC object to the list of files to remove. if test -n "$non_pic_object" && test "$non_pic_object" != none; then rmfiles="$rmfiles $dir/$non_pic_object" fi fi ;; *) if test "$mode" = clean ; then noexename=$name case $file in *.exe) func_stripname '' '.exe' "$file" file=$func_stripname_result func_stripname '' '.exe' "$name" noexename=$func_stripname_result # $file with .exe has already been added to rmfiles, # add $file without .exe rmfiles="$rmfiles $file" ;; esac # Do a test to see if this is a libtool program. if func_ltwrapper_p "$file"; then if func_ltwrapper_executable_p "$file"; then func_ltwrapper_scriptname "$file" relink_command= func_source $func_ltwrapper_scriptname_result rmfiles="$rmfiles $func_ltwrapper_scriptname_result" else relink_command= func_source $dir/$noexename fi # note $name still contains .exe if it was in $file originally # as does the version of $file that was added into $rmfiles rmfiles="$rmfiles $objdir/$name $objdir/${name}S.${objext}" if test "$fast_install" = yes && test -n "$relink_command"; then rmfiles="$rmfiles $objdir/lt-$name" fi if test "X$noexename" != "X$name" ; then rmfiles="$rmfiles $objdir/lt-${noexename}.c" fi fi fi ;; esac func_show_eval "$RM $rmfiles" 'exit_status=1' done objdir="$origobjdir" # Try to remove the ${objdir}s in the directories where we deleted files for dir in $rmdirs; do if test -d "$dir"; then func_show_eval "rmdir $dir >/dev/null 2>&1" fi done exit $exit_status } { test "$mode" = uninstall || test "$mode" = clean; } && func_mode_uninstall ${1+"$@"} test -z "$mode" && { help="$generic_help" func_fatal_help "you must specify a MODE" } test -z "$exec_cmd" && \ func_fatal_help "invalid operation mode \`$mode'" if test -n "$exec_cmd"; then eval exec "$exec_cmd" exit $EXIT_FAILURE fi exit $exit_status # The TAGs below are defined such that we never get into a situation # in which we disable both kinds of libraries. Given conflicting # choices, we go for a static library, that is the most portable, # since we can't tell whether shared libraries were disabled because # the user asked for that or because the platform doesn't support # them. This is particularly important on AIX, because we don't # support having both static and shared libraries enabled at the same # time on that platform, so we default to a shared-only configuration. # If a disable-shared tag is given, we'll fallback to a static-only # configuration. But we'll never go from static-only to shared-only. # ### BEGIN LIBTOOL TAG CONFIG: disable-shared build_libtool_libs=no build_old_libs=yes # ### END LIBTOOL TAG CONFIG: disable-shared # ### BEGIN LIBTOOL TAG CONFIG: disable-static build_old_libs=`case $build_libtool_libs in yes) echo no;; *) echo yes;; esac` # ### END LIBTOOL TAG CONFIG: disable-static # Local Variables: # mode:shell-script # sh-indentation:2 # End: # vi:sw=2 librep-0.90.2/install-sh0000755000175200017520000003246411245011162014073 0ustar chrischris#!/bin/sh # install - install a program, script, or datafile scriptversion=2006-12-25.00 # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # 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 # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. nl=' ' IFS=" "" $nl" # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit=${DOITPROG-} if test -z "$doit"; then doit_exec=exec else doit_exec=$doit fi # Put in absolute file names if you don't have them in your path; # or use environment vars. chgrpprog=${CHGRPPROG-chgrp} chmodprog=${CHMODPROG-chmod} chownprog=${CHOWNPROG-chown} cmpprog=${CMPPROG-cmp} cpprog=${CPPROG-cp} mkdirprog=${MKDIRPROG-mkdir} mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} posix_glob='?' initialize_posix_glob=' test "$posix_glob" != "?" || { if (set -f) 2>/dev/null; then posix_glob= else posix_glob=: fi } ' posix_mkdir= # Desired mode of installed file. mode=0755 chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false no_target_directory= usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... In the 1st form, copy SRCFILE to DSTFILE. In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. In the 4th, create DIRECTORIES. Options: --help display this help and exit. --version display version info and exit. -c (ignored) -C install only if different (preserve the last data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. Environment variables override the default commands: CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG " while test $# -ne 0; do case $1 in -c) ;; -C) copy_on_change=true;; -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 case $mode in *' '* | *' '* | *' '* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -s) stripcmd=$stripprog;; -t) dst_arg=$2 shift;; -T) no_target_directory=true;; --version) echo "$0 $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do if test -n "$dst_arg"; then # $@ is not empty: it contains at least $arg. set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call `install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then trap '(exit $?); exit' 1 2 13 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names starting with `-'. case $src in -*) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # Protect names starting with `-'. case $dst in -*) dst=./$dst;; esac # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then if test -n "$no_target_directory"; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dst=$dstdir/`basename "$src"` dstdir_status=0 else # Prefer dirname, but fall back on a substitute if dirname fails. dstdir=` (dirname "$dst") 2>/dev/null || expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$dst" : 'X\(//\)[^/]' \| \ X"$dst" : 'X\(//\)$' \| \ X"$dst" : 'X\(/\)' \| . 2>/dev/null || echo X"$dst" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q' ` test -d "$dstdir" dstdir_status=$? fi fi obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # Create intermediate dirs using mode 755 as modified by the umask. # This is like FreeBSD 'install' as of 1997-10-28. umask=`umask` case $stripcmd.$umask in # Optimize common cases. *[2367][2367]) mkdir_umask=$umask;; .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; *[0-7]) mkdir_umask=`expr $umask + 22 \ - $umask % 100 % 40 + $umask % 20 \ - $umask % 10 % 4 + $umask % 2 `;; *) mkdir_umask=$umask,go-w;; esac # With -d, create the new directory with the user-specified mode. # Otherwise, rely on $mkdir_umask. if test -n "$dir_arg"; then mkdir_mode=-m$mode else mkdir_mode= fi posix_mkdir=false case $umask in *[123567][0-7][0-7]) # POSIX mkdir -p sets u+wx bits regardless of umask, which # is incompatible with FreeBSD 'install' when (umask & 300) != 0. ;; *) tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 if (umask $mkdir_umask && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 then if test -z "$dir_arg" || { # Check for POSIX incompatibilities with -m. # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or # other-writeable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. ls_ld_tmpdir=`ls -ld "$tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/d" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null fi trap '' 0;; esac;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # The umask is ridiculous, or mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in /*) prefix='/';; -*) prefix='./';; *) prefix='';; esac eval "$initialize_posix_glob" oIFS=$IFS IFS=/ $posix_glob set -f set fnord $dstdir shift $posix_glob set +f IFS=$oIFS prefixes= for d do test -z "$d" && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask=$mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=$dstdir/_inst.$$_ rmtmp=$dstdir/_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $cpprog $src $dsttmp" command. # { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && eval "$initialize_posix_glob" && $posix_glob set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && $posix_glob set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # Rename the file to the real destination. $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { # Now remove or move aside any old file at destination location. # We try this two ways since rm can't unlink itself on some # systems and the destination file might be busy for other # reasons. In this case, the final cleanup might fail but the new # file should still install successfully. { test ! -f "$dst" || $doit $rmcmd -f "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } } || { echo "$0: cannot unlink or rename $dst" >&2 (exit 1); exit 1 } } && # Now rename the file to the real destination. $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-end: "$" # End: librep-0.90.2/config.sub0000755000175200017520000010242511245011162014045 0ustar chrischris#! /bin/sh # Configuration validation subroutine script. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 # Free Software Foundation, Inc. timestamp='2009-06-11' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software # can handle that machine. It does not imply ALL GNU software can. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Please send patches to . Submit a context # diff and a properly formatted ChangeLog entry. # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS $0 [OPTION] ALIAS Canonicalize a configuration name. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" exit 1 ;; *local*) # First pass through any local machine types. echo $1 exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-dietlibc | linux-newlib* | linux-uclibc* | \ uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | \ kopensolaris*-gnu* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; *) basic_machine=`echo $1 | sed 's/-[^-]*$//'` if [ $basic_machine != $1 ] then os=`echo $1 | sed 's/.*-/-/'` else os=; fi ;; esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also ### recognize some manufacturers as not being operating systems, so we ### can provide default operating systems below. case $os in -sun*os*) # Prevent following clause from handling this invalid input. ;; -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -apple | -axis | -knuth | -cray) os= basic_machine=$1 ;; -bluegene*) os=-cnk ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 ;; -scout) ;; -wrs) os=-vxworks basic_machine=$1 ;; -chorusos*) os=-chorusos basic_machine=$1 ;; -chorusrdb) os=-chorusrdb basic_machine=$1 ;; -hiux*) os=-hiuxwe2 ;; -sco6) os=-sco5v6 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5) os=-sco3.2v5 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5v6*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -udk*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` ;; -windowsnt*) os=`echo $os | sed -e 's/windowsnt/winnt/'` ;; -psos*) os=-psos ;; -mint | -mint[0-9]*) basic_machine=m68k-atari os=-mint ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. 1750a | 580 \ | a29k \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \ | bfin \ | c4x | clipper \ | d10v | d30v | dlx | dsp16xx \ | fido | fr30 | frv \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ | maxq | mb | microblaze | mcore | mep | metag \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ | mips64octeon | mips64octeonel \ | mips64orion | mips64orionel \ | mips64r5900 | mips64r5900el \ | mips64vr | mips64vrel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | moxie \ | mt \ | msp430 \ | nios | nios2 \ | ns16k | ns32k \ | or32 \ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ | pyramid \ | score \ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ | spu | strongarm \ | tahoe | thumb | tic4x | tic80 | tron \ | v850 | v850e \ | we32k \ | x86 | xc16x | xscale | xscalee[bl] | xstormy16 | xtensa \ | z8k | z80) basic_machine=$basic_machine-unknown ;; m6811 | m68hc11 | m6812 | m68hc12) # Motorola 68HC11/12. basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) ;; ms1) basic_machine=mt-unknown ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) basic_machine=$basic_machine-pc ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. 580-* \ | a29k-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \ | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | i*86-* | i860-* | i960-* | ia64-* \ | ip2k-* | iq2000-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ | mips64octeon-* | mips64octeonel-* \ | mips64orion-* | mips64orionel-* \ | mips64r5900-* | mips64r5900el-* \ | mips64vr-* | mips64vrel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | mt-* \ | msp430-* \ | nios-* | nios2-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ | pyramid-* \ | romp-* | rs6000-* \ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ | sparclite-* \ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | strongarm-* | sv1-* | sx?-* \ | tahoe-* | thumb-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* | tile-* \ | tron-* \ | v850-* | v850e-* | vax-* \ | we32k-* \ | x86-* | x86_64-* | xc16x-* | xps100-* | xscale-* | xscalee[bl]-* \ | xstormy16-* | xtensa*-* \ | ymp-* \ | z8k-* | z80-*) ;; # Recognize the basic CPU types without company name, with glob match. xtensa*) basic_machine=$basic_machine-unknown ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) basic_machine=i386-unknown os=-bsd ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; a29khif) basic_machine=a29k-amd os=-udi ;; abacus) basic_machine=abacus-unknown ;; adobe68k) basic_machine=m68010-adobe os=-scout ;; alliant | fx80) basic_machine=fx80-alliant ;; altos | altos3068) basic_machine=m68k-altos ;; am29k) basic_machine=a29k-none os=-bsd ;; amd64) basic_machine=x86_64-pc ;; amd64-*) basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; amdahl) basic_machine=580-amdahl os=-sysv ;; amiga | amiga-*) basic_machine=m68k-unknown ;; amigaos | amigados) basic_machine=m68k-unknown os=-amigaos ;; amigaunix | amix) basic_machine=m68k-unknown os=-sysv4 ;; apollo68) basic_machine=m68k-apollo os=-sysv ;; apollo68bsd) basic_machine=m68k-apollo os=-bsd ;; aros) basic_machine=i386-pc os=-aros ;; aux) basic_machine=m68k-apple os=-aux ;; balance) basic_machine=ns32k-sequent os=-dynix ;; blackfin) basic_machine=bfin-unknown os=-linux ;; blackfin-*) basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; bluegene*) basic_machine=powerpc-ibm os=-cnk ;; c90) basic_machine=c90-cray os=-unicos ;; cegcc) basic_machine=arm-unknown os=-cegcc ;; convex-c1) basic_machine=c1-convex os=-bsd ;; convex-c2) basic_machine=c2-convex os=-bsd ;; convex-c32) basic_machine=c32-convex os=-bsd ;; convex-c34) basic_machine=c34-convex os=-bsd ;; convex-c38) basic_machine=c38-convex os=-bsd ;; cray | j90) basic_machine=j90-cray os=-unicos ;; craynv) basic_machine=craynv-cray os=-unicosmp ;; cr16) basic_machine=cr16-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; crisv32 | crisv32-* | etraxfs*) basic_machine=crisv32-axis ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; crx) basic_machine=crx-unknown os=-elf ;; da30 | da30-*) basic_machine=m68k-da30 ;; decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; decsystem10* | dec10*) basic_machine=pdp10-dec os=-tops10 ;; decsystem20* | dec20*) basic_machine=pdp10-dec os=-tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola ;; delta88) basic_machine=m88k-motorola os=-sysv3 ;; dicos) basic_machine=i686-pc os=-dicos ;; djgpp) basic_machine=i586-pc os=-msdosdjgpp ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx ;; dpx2* | dpx2*-bull) basic_machine=m68k-bull os=-sysv3 ;; ebmon29k) basic_machine=a29k-amd os=-ebmon ;; elxsi) basic_machine=elxsi-elxsi os=-bsd ;; encore | umax | mmax) basic_machine=ns32k-encore ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson os=-ose ;; fx2800) basic_machine=i860-alliant ;; genix) basic_machine=ns32k-ns ;; gmicro) basic_machine=tron-gmicro os=-sysv ;; go32) basic_machine=i386-pc os=-go32 ;; h3050r* | hiux*) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; h8300hms) basic_machine=h8300-hitachi os=-hms ;; h8300xray) basic_machine=h8300-hitachi os=-xray ;; h8500hms) basic_machine=h8500-hitachi os=-hms ;; harris) basic_machine=m88k-harris os=-sysv3 ;; hp300-*) basic_machine=m68k-hp ;; hp300bsd) basic_machine=m68k-hp os=-bsd ;; hp300hpux) basic_machine=m68k-hp os=-hpux ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; hp9k3[2-9][0-9]) basic_machine=m68k-hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) basic_machine=hppa1.1-hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) basic_machine=hppa1.1-hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; hppa-next) os=-nextstep3 ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; # I'm not sure what "Sysv32" means. Should this be sysv3.2? i*86v32) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; i*86v4*) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; i*86v) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv ;; i*86sol2) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; i386mach) basic_machine=i386-mach os=-mach ;; i386-vsta | vsta) basic_machine=i386-unknown os=-vsta ;; iris | iris4d) basic_machine=mips-sgi case $os in -irix*) ;; *) os=-irix4 ;; esac ;; isi68 | isi) basic_machine=m68k-isi os=-sysv ;; m68knommu) basic_machine=m68k-unknown os=-linux ;; m68knommu-*) basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; m88k-omron*) basic_machine=m88k-omron ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; mingw32) basic_machine=i386-pc os=-mingw32 ;; mingw32ce) basic_machine=arm-unknown os=-mingw32ce ;; miniframe) basic_machine=m68000-convergent ;; *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) basic_machine=m68k-atari os=-mint ;; mips3*-*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` ;; mips3*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown ;; monitor) basic_machine=m68k-rom68k os=-coff ;; morphos) basic_machine=powerpc-unknown os=-morphos ;; msdos) basic_machine=i386-pc os=-msdos ;; ms1-*) basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` ;; mvs) basic_machine=i370-ibm os=-mvs ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; netbsd386) basic_machine=i386-unknown os=-netbsd ;; netwinder) basic_machine=armv4l-rebel os=-linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos ;; news1000) basic_machine=m68030-sony os=-newsos ;; news-3600 | risc-news) basic_machine=mips-sony os=-newsos ;; necv70) basic_machine=v70-nec os=-sysv ;; next | m*-next ) basic_machine=m68k-next case $os in -nextstep* ) ;; -ns2*) os=-nextstep2 ;; *) os=-nextstep3 ;; esac ;; nh3000) basic_machine=m68k-harris os=-cxux ;; nh[45]000) basic_machine=m88k-harris os=-cxux ;; nindy960) basic_machine=i960-intel os=-nindy ;; mon960) basic_machine=i960-intel os=-mon960 ;; nonstopux) basic_machine=mips-compaq os=-nonstopux ;; np1) basic_machine=np1-gould ;; nsr-tandem) basic_machine=nsr-tandem ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf ;; openrisc | openrisc-*) basic_machine=or32-unknown ;; os400) basic_machine=powerpc-ibm os=-os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose ;; os68k) basic_machine=m68k-none os=-os68k ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; paragon) basic_machine=i860-intel os=-osf ;; parisc) basic_machine=hppa-unknown os=-linux ;; parisc-*) basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; pbd) basic_machine=sparc-tti ;; pbb) basic_machine=m68k-tti ;; pc532 | pc532-*) basic_machine=ns32k-pc532 ;; pc98) basic_machine=i386-pc ;; pc98-*) basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; pentium4) basic_machine=i786-pc ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium4-*) basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould ;; power) basic_machine=power-ibm ;; ppc) basic_machine=powerpc-unknown ;; ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle | ppc-le | powerpc-little) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64) basic_machine=powerpc64-unknown ;; ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little | ppc64-le | powerpc64-little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ps2) basic_machine=i386-ibm ;; pw32) basic_machine=i586-unknown os=-pw32 ;; rdos) basic_machine=i386-pc os=-rdos ;; rom68k) basic_machine=m68k-rom68k os=-coff ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; s390 | s390-*) basic_machine=s390-ibm ;; s390x | s390x-*) basic_machine=s390x-ibm ;; sa29200) basic_machine=a29k-amd os=-udi ;; sb1) basic_machine=mipsisa64sb1-unknown ;; sb1el) basic_machine=mipsisa64sb1el-unknown ;; sde) basic_machine=mipsisa32-sde os=-elf ;; sei) basic_machine=mips-sei os=-seiux ;; sequent) basic_machine=i386-sequent ;; sh) basic_machine=sh-hitachi os=-hms ;; sh5el) basic_machine=sh5le-unknown ;; sh64) basic_machine=sh64-unknown ;; sparclite-wrs | simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; sps7) basic_machine=m68k-bull os=-sysv2 ;; spur) basic_machine=spur-unknown ;; st2000) basic_machine=m68k-tandem ;; stratus) basic_machine=i860-stratus os=-sysv4 ;; sun2) basic_machine=m68000-sun ;; sun2os3) basic_machine=m68000-sun os=-sunos3 ;; sun2os4) basic_machine=m68000-sun os=-sunos4 ;; sun3os3) basic_machine=m68k-sun os=-sunos3 ;; sun3os4) basic_machine=m68k-sun os=-sunos4 ;; sun4os3) basic_machine=sparc-sun os=-sunos3 ;; sun4os4) basic_machine=sparc-sun os=-sunos4 ;; sun4sol2) basic_machine=sparc-sun os=-solaris2 ;; sun3 | sun3-*) basic_machine=m68k-sun ;; sun4) basic_machine=sparc-sun ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun ;; sv1) basic_machine=sv1-cray os=-unicos ;; symmetry) basic_machine=i386-sequent os=-dynix ;; t3e) basic_machine=alphaev5-cray os=-unicos ;; t90) basic_machine=t90-cray os=-unicos ;; tic54x | c54x*) basic_machine=tic54x-unknown os=-coff ;; tic55x | c55x*) basic_machine=tic55x-unknown os=-coff ;; tic6x | c6x*) basic_machine=tic6x-unknown os=-coff ;; tile*) basic_machine=tile-unknown os=-linux-gnu ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; toad1) basic_machine=pdp10-xkl os=-tops20 ;; tower | tower-32) basic_machine=m68k-ncr ;; tpf) basic_machine=s390x-ibm os=-tpf ;; udi29k) basic_machine=a29k-amd os=-udi ;; ultra3) basic_machine=a29k-nyu os=-sym1 ;; v810 | necv810) basic_machine=v810-nec os=-none ;; vaxv) basic_machine=vax-dec os=-sysv ;; vms) basic_machine=vax-dec os=-vms ;; vpp*|vx|vx-*) basic_machine=f301-fujitsu ;; vxworks960) basic_machine=i960-wrs os=-vxworks ;; vxworks68) basic_machine=m68k-wrs os=-vxworks ;; vxworks29k) basic_machine=a29k-wrs os=-vxworks ;; w65*) basic_machine=w65-wdc os=-none ;; w89k-*) basic_machine=hppa1.1-winbond os=-proelf ;; xbox) basic_machine=i686-pc os=-mingw32 ;; xps | xps100) basic_machine=xps100-honeywell ;; ymp) basic_machine=ymp-cray os=-unicos ;; z8k-*-coff) basic_machine=z8k-unknown os=-sim ;; z80-*-coff) basic_machine=z80-unknown os=-sim ;; none) basic_machine=none-none os=-none ;; # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) basic_machine=hppa1.1-winbond ;; op50n) basic_machine=hppa1.1-oki ;; op60c) basic_machine=hppa1.1-oki ;; romp) basic_machine=romp-ibm ;; mmix) basic_machine=mmix-knuth ;; rs6000) basic_machine=rs6000-ibm ;; vax) basic_machine=vax-dec ;; pdp10) # there are many clones, so DEC is not a safe bet basic_machine=pdp10-unknown ;; pdp11) basic_machine=pdp11-dec ;; we32k) basic_machine=we32k-att ;; sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) basic_machine=sparc-sun ;; cydra) basic_machine=cydra-cydrome ;; orion) basic_machine=orion-highlevel ;; orion105) basic_machine=clipper-highlevel ;; mac | mpw | mac-mpw) basic_machine=m68k-apple ;; pmac | pmac-mpw) basic_machine=powerpc-apple ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; *) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; esac # Here we canonicalize certain aliases for manufacturers. case $basic_machine in *-digital*) basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` ;; *-commodore*) basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if [ x"$os" != x"" ] then case $os in # First match some system type aliases # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; -solaris) os=-solaris2 ;; -svr4*) os=-sysv4 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # First accept the basic system types. # The portable systems comes first. # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ | -kopensolaris* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* | -aros* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ | -openbsd* | -solidbsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ | -chorusos* | -chorusrdb* | -cegcc* \ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -mingw32* | -linux-gnu* | -linux-newlib* | -linux-uclibc* \ | -uxpv* | -beos* | -mpeix* | -udk* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ | -skyos* | -haiku* | -rdos* | -toppers* | -drops*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) case $basic_machine in x86-* | i*86-*) ;; *) os=-nto$os ;; esac ;; -nto-qnx*) ;; -nto*) os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) os=`echo $os | sed -e 's|mac|macos|'` ;; -linux-dietlibc) os=-linux-dietlibc ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; -sunos6*) os=`echo $os | sed -e 's|sunos6|solaris3|'` ;; -opened*) os=-openedition ;; -os400*) os=-os400 ;; -wince*) os=-wince ;; -osfrose*) os=-osfrose ;; -osf*) os=-osf ;; -utek*) os=-bsd ;; -dynix*) os=-bsd ;; -acis*) os=-aos ;; -atheos*) os=-atheos ;; -syllable*) os=-syllable ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; -nova*) os=-rtmk-nova ;; -ns2 ) os=-nextstep2 ;; -nsk*) os=-nsk ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` ;; -sinix*) os=-sysv4 ;; -tpf*) os=-tpf ;; -triton*) os=-sysv3 ;; -oss*) os=-sysv3 ;; -svr4) os=-sysv4 ;; -svr3) os=-sysv3 ;; -sysvr4) os=-sysv4 ;; # This must come after -sysvr4. -sysv*) ;; -ose*) os=-ose ;; -es1800*) os=-ose ;; -xenix) os=-xenix ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -aros*) os=-aros ;; -kaos*) os=-kaos ;; -zvmoe) os=-zvmoe ;; -dicos*) os=-dicos ;; -none) ;; *) # Get rid of the `-' at the beginning of $os. os=`echo $os | sed 's/[^-]*-//'` echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 exit 1 ;; esac else # Here we handle the default operating systems that come with various machines. # The value should be what the vendor currently ships out the door with their # machine or put another way, the most popular os provided with the machine. # Note that if you're going to try to match "-MANUFACTURER" here (say, # "-sun"), then you have to tell the case statement up towards the top # that MANUFACTURER isn't an operating system. Otherwise, code above # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. case $basic_machine in score-*) os=-elf ;; spu-*) os=-elf ;; *-acorn) os=-riscix1.2 ;; arm*-rebel) os=-linux ;; arm*-semi) os=-aout ;; c4x-* | tic4x-*) os=-coff ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; pdp11-*) os=-none ;; *-dec | vax-*) os=-ultrix4.2 ;; m68*-apollo) os=-domain ;; i386-sun) os=-sunos4.0.2 ;; m68000-sun) os=-sunos3 # This also exists in the configure program, but was not the # default. # os=-sunos4 ;; m68*-cisco) os=-aout ;; mep-*) os=-elf ;; mips*-cisco) os=-elf ;; mips*-*) os=-elf ;; or32-*) os=-coff ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; sparc-* | *-sun) os=-sunos4.1.1 ;; *-be) os=-beos ;; *-haiku) os=-haiku ;; *-ibm) os=-aix ;; *-knuth) os=-mmixware ;; *-wec) os=-proelf ;; *-winbond) os=-proelf ;; *-oki) os=-proelf ;; *-hp) os=-hpux ;; *-hitachi) os=-hiux ;; i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) os=-sysv ;; *-cbm) os=-amigaos ;; *-dg) os=-dgux ;; *-dolphin) os=-sysv3 ;; m68k-ccur) os=-rtu ;; m88k-omron*) os=-luna ;; *-next ) os=-nextstep ;; *-sequent) os=-ptx ;; *-crds) os=-unos ;; *-ns) os=-genix ;; i370-*) os=-mvs ;; *-next) os=-nextstep3 ;; *-gould) os=-sysv ;; *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; *-sgi) os=-irix ;; *-siemens) os=-sysv4 ;; *-masscomp) os=-rtu ;; f30[01]-fujitsu | f700-fujitsu) os=-uxpv ;; *-rom68k) os=-coff ;; *-*bug) os=-coff ;; *-apple) os=-macos ;; *-atari*) os=-mint ;; *) os=-none ;; esac fi # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. vendor=unknown case $basic_machine in *-unknown) case $os in -riscix*) vendor=acorn ;; -sunos*) vendor=sun ;; -cnk*|-aix*) vendor=ibm ;; -beos*) vendor=be ;; -hpux*) vendor=hp ;; -mpeix*) vendor=hp ;; -hiux*) vendor=hitachi ;; -unos*) vendor=crds ;; -dgux*) vendor=dg ;; -luna*) vendor=omron ;; -genix*) vendor=ns ;; -mvs* | -opened*) vendor=ibm ;; -os400*) vendor=ibm ;; -ptx*) vendor=sequent ;; -tpf*) vendor=ibm ;; -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) vendor=apple ;; -hms*) vendor=hitachi ;; -mpw* | -macos*) vendor=apple ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; -vos*) vendor=stratus ;; esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; esac echo $basic_machine$os exit # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: librep-0.90.2/config.guess0000755000175200017520000013105411245011162014402 0ustar chrischris#! /bin/sh # Attempt to guess a canonical system name. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 # Free Software Foundation, Inc. timestamp='2009-06-10' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Originally written by Per Bothner . # Please send patches to . Submit a context # diff and a properly formatted ChangeLog entry. # # This script attempts to guess a canonical system name similar to # config.sub. If it succeeds, it prints the system name on stdout, and # exits with 0. Otherwise, it exits with 1. # # The plan is that this can be called by configure scripts if you # don't specify an explicit build system type. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; * ) break ;; esac done if test $# != 0; then echo "$me: too many arguments$help" >&2 exit 1 fi trap 'exit 1' 1 2 15 # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. # Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still # use `HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. set_cc_for_build=' trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; : ${TMPDIR=/tmp} ; { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; dummy=$tmp/dummy ; tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; case $CC_FOR_BUILD,$HOST_CC,$CC in ,,) echo "int x;" > $dummy.c ; for c in cc gcc c89 c99 ; do if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then CC_FOR_BUILD="$c"; break ; fi ; done ; if test x"$CC_FOR_BUILD" = x ; then CC_FOR_BUILD=no_compiler_found ; fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; esac ; set_cc_for_build= ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) if (test -f /.attbin/uname) >/dev/null 2>&1 ; then PATH=$PATH:/.attbin ; export PATH fi UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently # switched to ELF, *-*-netbsd* would select the old # object file format. This provides both forward # compatibility and a consistent mechanism for selecting the # object file format. # # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ /usr/sbin/$sysctl 2>/dev/null || echo unknown)` case "${UNAME_MACHINE_ARCH}" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched # to ELF recently, or will in the future. case "${UNAME_MACHINE_ARCH}" in arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ELF__ then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? os=netbsd else os=netbsdelf fi ;; *) os=netbsd ;; esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. case "${UNAME_VERSION}" in Debian*) release='-gnu' ;; *) release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. echo "${machine}-${os}${release}" exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} exit ;; *:SolidBSD:*:*) echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} exit ;; macppc:MirBSD:*:*) echo powerpc-unknown-mirbsd${UNAME_RELEASE} exit ;; *:MirBSD:*:*) echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` ;; *5.*) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` ;; esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU # types through head -n 1, so we only detect the type of CPU 0. ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") UNAME_MACHINE="alpha" ;; "EV4.5 (21064)") UNAME_MACHINE="alpha" ;; "LCA4 (21066/21068)") UNAME_MACHINE="alpha" ;; "EV5 (21164)") UNAME_MACHINE="alphaev5" ;; "EV5.6 (21164A)") UNAME_MACHINE="alphaev56" ;; "EV5.6 (21164PC)") UNAME_MACHINE="alphapca56" ;; "EV5.7 (21164PC)") UNAME_MACHINE="alphapca57" ;; "EV6 (21264)") UNAME_MACHINE="alphaev6" ;; "EV6.7 (21264A)") UNAME_MACHINE="alphaev67" ;; "EV6.8CB (21264C)") UNAME_MACHINE="alphaev68" ;; "EV6.8AL (21264B)") UNAME_MACHINE="alphaev68" ;; "EV6.8CX (21264D)") UNAME_MACHINE="alphaev68" ;; "EV6.9A (21264/EV69A)") UNAME_MACHINE="alphaev69" ;; "EV7 (21364)") UNAME_MACHINE="alphaev7" ;; "EV7.9 (21364A)") UNAME_MACHINE="alphaev79" ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` exit ;; Alpha\ *:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # Should we change UNAME_MACHINE based on the output of uname instead # of the specific Alpha model? echo alpha-pc-interix exit ;; 21064:Windows_NT:50:3) echo alpha-dec-winnt3.5 exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition exit ;; *:z/VM:*:*) echo s390-ibm-zvmoe exit ;; *:OS400:*:*) echo powerpc-ibm-os400 exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} exit ;; arm:riscos:*:*|arm:RISCOS:*:*) echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 else echo pyramid-pyramid-bsd fi exit ;; NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 exit ;; DRS?6000:unix:4.0:6*) echo sparc-icl-nx6 exit ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) echo sparc-icl-nx7; exit ;; esac ;; s390x:SunOS:*:*) echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) eval $set_cc_for_build SUN_ARCH="i386" # If there is a compiler, see if it is configured for 64-bit objects. # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. # This test works for both compilers. if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH="x86_64" fi fi echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in Series*|S4*) UNAME_RELEASE=`uname -v` ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` exit ;; sun3*:SunOS:*:*) echo m68k-sun-sunos${UNAME_RELEASE} exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) echo m68k-sun-sunos${UNAME_RELEASE} ;; sun4) echo sparc-sun-sunos${UNAME_RELEASE} ;; esac exit ;; aushp:SunOS:*:*) echo sparc-auspex-sunos${UNAME_RELEASE} exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor # > m68000). The system name ranges from "MiNT" over "FreeMiNT" # to the lowercase version "mint" (or "freemint"). Finally # the system name "TOS" denotes a system which is actually not # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) echo m68k-milan-mint${UNAME_RELEASE} exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) echo m68k-hades-mint${UNAME_RELEASE} exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) echo m68k-unknown-mint${UNAME_RELEASE} exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} exit ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit ;; RISC*:ULTRIX:*:*) echo mips-dec-ultrix${UNAME_RELEASE} exit ;; VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) echo clipper-intergraph-clix${UNAME_RELEASE} exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { #else int main (argc, argv) int argc; char *argv[]; { #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && SYSTEM_NAME=`$dummy $dummyarg` && { echo "$SYSTEM_NAME"; exit; } echo mips-mips-riscos${UNAME_RELEASE} exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax exit ;; Motorola:*:4.3:PL8-*) echo powerpc-harris-powermax exit ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) echo powerpc-harris-powermax exit ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix exit ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 exit ;; m88k:*:4*:R4*) echo m88k-motorola-sysv4 exit ;; m88k:*:3*:R3*) echo m88k-motorola-sysv3 exit ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ [ ${TARGET_BINARY_INTERFACE}x = x ] then echo m88k-dg-dgux${UNAME_RELEASE} else echo m88k-dg-dguxbcs${UNAME_RELEASE} fi else echo i586-dg-dgux${UNAME_RELEASE} fi exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 exit ;; M88*:*:R3*:*) # Delta 88k system running SVR3 echo m88k-motorola-sysv3 exit ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) echo m88k-tektronix-sysv3 exit ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) echo m68k-tektronix-bsd exit ;; *:IRIX*:*:*) echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) echo i386-ibm-aix exit ;; ia64:AIX:*:*) if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include main() { if (!__power_pc()) exit(1); puts("powerpc-ibm-aix3.2.5"); exit(0); } EOF if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` then echo "$SYSTEM_NAME" else echo rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 else echo rs6000-ibm-aix3.2 fi exit ;; *:AIX:*:[456]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${IBM_ARCH}-ibm-aix${IBM_REV} exit ;; *:AIX:*:*) echo rs6000-ibm-aix exit ;; ibmrt:4.4BSD:*|romp-ibm:BSD:*) echo romp-ibm-bsd4.4 exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx exit ;; DPX/2?00:B.O.S.:*:*) echo m68k-bull-sysv3 exit ;; 9000/[34]??:4.3bsd:1.*:*) echo m68k-hp-bsd exit ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case "${sc_cpu_version}" in 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case "${sc_kernel_bits}" in 32) HP_ARCH="hppa2.0n" ;; 64) HP_ARCH="hppa2.0w" ;; '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 esac ;; esac fi if [ "${HP_ARCH}" = "" ]; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #define _HPUX_SOURCE #include #include int main () { #if defined(_SC_KERNEL_BITS) long bits = sysconf(_SC_KERNEL_BITS); #endif long cpu = sysconf (_SC_CPU_VERSION); switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0"); break; case CPU_PA_RISC1_1: puts ("hppa1.1"); break; case CPU_PA_RISC2_0: #if defined(_SC_KERNEL_BITS) switch (bits) { case 64: puts ("hppa2.0w"); break; case 32: puts ("hppa2.0n"); break; default: puts ("hppa2.0"); break; } break; #else /* !defined(_SC_KERNEL_BITS) */ puts ("hppa2.0"); break; #endif default: puts ("hppa1.0"); break; } exit (0); } EOF (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac if [ ${HP_ARCH} = "hppa2.0w" ] then eval $set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler # generating 64-bit code. GNU and HP use different nomenclature: # # $ CC_FOR_BUILD=cc ./config.guess # => hppa2.0w-hp-hpux11.23 # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then HP_ARCH="hppa2.0w" else HP_ARCH="hppa64" fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} exit ;; ia64:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ia64-hp-hpux${HPUX_REV} exit ;; 3050*:HI-UX:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include int main () { long cpu = sysconf (_SC_CPU_VERSION); /* The order matters, because CPU_IS_HP_MC68K erroneously returns true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct results, however. */ if (CPU_IS_PA_RISC (cpu)) { switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; default: puts ("hppa-hitachi-hiuxwe2"); break; } } else if (CPU_IS_HP_MC68K (cpu)) puts ("m68k-hitachi-hiuxwe2"); else puts ("unknown-hitachi-hiuxwe2"); exit (0); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 exit ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd exit ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf exit ;; hp8??:OSF1:*:*) echo hppa1.0-hp-osf exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then echo ${UNAME_MACHINE}-unknown-osf1mk else echo ${UNAME_MACHINE}-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) echo hppa1.1-hp-lites exit ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) echo c1-convex-bsd exit ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) echo c34-convex-bsd exit ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) echo c38-convex-bsd exit ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) echo c4-convex-bsd exit ;; CRAY*Y-MP:*:*:*) echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*[A-Z]90:*:*:*) echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*T3E:*:*:*) echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*SV1:*:*:*) echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; *:UNICOS/mp:*:*) echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit ;; sparc*:BSD/OS:*:*) echo sparc-unknown-bsdi${UNAME_RELEASE} exit ;; *:BSD/OS:*:*) echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} exit ;; *:FreeBSD:*:*) case ${UNAME_MACHINE} in pc98) echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; amd64) echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; *) echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; esac exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin exit ;; *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; i*:windows32*:*) # uname -m includes "-pc" on this system. echo ${UNAME_MACHINE}-mingw32 exit ;; i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit ;; *:Interix*:[3456]*) case ${UNAME_MACHINE} in x86) echo i586-pc-interix${UNAME_RELEASE} exit ;; EM64T | authenticamd | genuineintel) echo x86_64-unknown-interix${UNAME_RELEASE} exit ;; IA64) echo ia64-unknown-interix${UNAME_RELEASE} exit ;; esac ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks exit ;; 8664:Windows_NT:*) echo x86_64-pc-mks exit ;; i*:Windows_NT*:* | Pentium*:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we # UNAME_MACHINE based on the output of uname instead of i386? echo i586-pc-interix exit ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) echo x86_64-unknown-cygwin exit ;; p*:CYGWIN*:*) echo powerpcle-unknown-cygwin exit ;; prep*:SunOS:5.*:*) echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; *:GNU:*:*) # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit ;; arm*:Linux:*:*) eval $set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then echo ${UNAME_MACHINE}-unknown-linux-gnu else echo ${UNAME_MACHINE}-unknown-linux-gnueabi fi exit ;; avr32*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; cris:Linux:*:*) echo cris-axis-linux-gnu exit ;; crisv32:Linux:*:*) echo crisv32-axis-linux-gnu exit ;; frv:Linux:*:*) echo frv-unknown-linux-gnu exit ;; ia64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m32r*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m68*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; mips:Linux:*:* | mips64:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU #undef ${UNAME_MACHINE} #undef ${UNAME_MACHINE}el #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) CPU=${UNAME_MACHINE}el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) CPU=${UNAME_MACHINE} #else CPU= #endif #endif EOF eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' /^CPU/{ s: ::g p }'`" test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } ;; or32:Linux:*:*) echo or32-unknown-linux-gnu exit ;; ppc:Linux:*:*) echo powerpc-unknown-linux-gnu exit ;; ppc64:Linux:*:*) echo powerpc64-unknown-linux-gnu exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; PCA57) UNAME_MACHINE=alphapca56 ;; EV6) UNAME_MACHINE=alphaev6 ;; EV67) UNAME_MACHINE=alphaev67 ;; EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} exit ;; padre:Linux:*:*) echo sparc-unknown-linux-gnu exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) echo hppa1.1-unknown-linux-gnu ;; PA8*) echo hppa2.0-unknown-linux-gnu ;; *) echo hppa-unknown-linux-gnu ;; esac exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) echo hppa64-unknown-linux-gnu exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux exit ;; sh64*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; vax:Linux:*:*) echo ${UNAME_MACHINE}-dec-linux-gnu exit ;; x86_64:Linux:*:*) echo x86_64-unknown-linux-gnu exit ;; xtensa*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; i*86:Linux:*:*) # The BFD linker knows what the default object file format is, so # first see if it will tell us. cd to the root directory to prevent # problems with other programs or directories called `ld' in the path. # Set LC_ALL=C to ensure ld outputs messages in English. ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ | sed -ne '/supported targets:/!d s/[ ][ ]*/ /g s/.*supported targets: *// s/ .*// p'` case "$ld_supported_targets" in elf32-i386) TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" ;; esac # Determine whether the default compiler is a.out or elf eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include #ifdef __ELF__ # ifdef __GLIBC__ # if __GLIBC__ >= 2 LIBC=gnu # else LIBC=gnulibc1 # endif # else LIBC=gnulibc1 # endif #else #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC) LIBC=gnu #else LIBC=gnuaout #endif #endif #ifdef __dietlibc__ LIBC=dietlibc #endif EOF eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' /^LIBC/{ s: ::g p }'`" test x"${LIBC}" != x && { echo "${UNAME_MACHINE}-pc-linux-${LIBC}" exit } test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; } ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. echo i386-sequent-sysv4 exit ;; i*86:UNIX_SV:4.2MP:2.*) # Unixware is an offshoot of SVR4, but it has its own version # number series starting with 2... # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. echo ${UNAME_MACHINE}-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) echo ${UNAME_MACHINE}-unknown-stop exit ;; i*86:atheos:*:*) echo ${UNAME_MACHINE}-unknown-atheos exit ;; i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) echo i386-unknown-lynxos${UNAME_RELEASE} exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp exit ;; i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} else echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} fi exit ;; i*86:*:5:[678]*) # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 echo ${UNAME_MACHINE}-pc-sco$UNAME_REL else echo ${UNAME_MACHINE}-pc-sysv32 fi exit ;; pc:*:*:*) # Left here for compatibility: # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub # prints for the "djgpp" host, or else GDB configury will decide that # this is a cross-build. echo i586-pc-msdosdjgpp exit ;; Intel:Mach:3*:*) echo i386-pc-mach3 exit ;; paragon:*:*:*) echo i860-intel-osf1 exit ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) # "miniframe" echo m68010-convergent-sysv exit ;; mc68k:UNIX:SYSTEM5:3.51m) echo m68k-convergent-sysv exit ;; M680?0:D-NIX:5.3:*) echo m68k-diab-dnix exit ;; M68*:*:R3V[5678]*:*) test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; NCR*:*:4.2:* | MPRAS*:*:4.2:*) OS_REL='.3' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) echo m68k-unknown-lynxos${UNAME_RELEASE} exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) echo sparc-unknown-lynxos${UNAME_RELEASE} exit ;; rs6000:LynxOS:2.*:*) echo rs6000-unknown-lynxos${UNAME_RELEASE} exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) echo powerpc-unknown-lynxos${UNAME_RELEASE} exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 exit ;; RM*:SINIX-*:*:*) echo mips-sni-sysv4 exit ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` echo ${UNAME_MACHINE}-sni-sysv4 else echo ns32k-sni-sysv fi exit ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says echo i586-unisys-sysv4 exit ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm echo hppa1.1-stratus-sysv4 exit ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 exit ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. echo ${UNAME_MACHINE}-stratus-vos exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos exit ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. echo powerpc-be-beos exit ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. echo powerpc-apple-beos exit ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. echo i586-pc-beos exit ;; BePC:Haiku:*:*) # Haiku running on Intel PC compatible. echo i586-pc-haiku exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} exit ;; SX-5:SUPER-UX:*:*) echo sx5-nec-superux${UNAME_RELEASE} exit ;; SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} exit ;; SX-7:SUPER-UX:*:*) echo sx7-nec-superux${UNAME_RELEASE} exit ;; SX-8:SUPER-UX:*:*) echo sx8-nec-superux${UNAME_RELEASE} exit ;; SX-8R:SUPER-UX:*:*) echo sx8r-nec-superux${UNAME_RELEASE} exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; *:Rhapsody:*:*) echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} exit ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown case $UNAME_PROCESSOR in unknown) UNAME_PROCESSOR=powerpc ;; esac echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = "x86"; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} exit ;; *:QNX:*:4*) echo i386-pc-qnx exit ;; NSE-?:NONSTOP_KERNEL:*:*) echo nse-tandem-nsk${UNAME_RELEASE} exit ;; NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; BS2000:POSIX*:*:*) echo bs2000-siemens-sysv exit ;; DS/*:UNIX_System_V:*:*) echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. if test "$cputype" = "386"; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" fi echo ${UNAME_MACHINE}-unknown-plan9 exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 exit ;; *:TENEX:*:*) echo pdp10-unknown-tenex exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 exit ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) echo pdp10-xkl-tops20 exit ;; *:TOPS-20:*:*) echo pdp10-unknown-tops20 exit ;; *:ITS:*:*) echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) echo mips-sei-seiux${UNAME_RELEASE} exit ;; *:DragonFly:*:*) echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case "${UNAME_MACHINE}" in A*) echo alpha-dec-vms ; exit ;; I*) echo ia64-dec-vms ; exit ;; V*) echo vax-dec-vms ; exit ;; esac ;; *:XENIX:*:SysV) echo i386-pc-xenix exit ;; i*86:skyos:*:*) echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' exit ;; i*86:rdos:*:*) echo ${UNAME_MACHINE}-pc-rdos exit ;; i*86:AROS:*:*) echo ${UNAME_MACHINE}-pc-aros exit ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 #echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 eval $set_cc_for_build cat >$dummy.c < # include #endif main () { #if defined (sony) #if defined (MIPSEB) /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, I don't know.... */ printf ("mips-sony-bsd\n"); exit (0); #else #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 "4" #else "" #endif ); exit (0); #endif #endif #if defined (__arm) && defined (__acorn) && defined (__unix) printf ("arm-acorn-riscix\n"); exit (0); #endif #if defined (hp300) && !defined (hpux) printf ("m68k-hp-bsd\n"); exit (0); #endif #if defined (NeXT) #if !defined (__ARCHITECTURE__) #define __ARCHITECTURE__ "m68k" #endif int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; if (version < 4) printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); else printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif #if defined (MULTIMAX) || defined (n16) #if defined (UMAXV) printf ("ns32k-encore-sysv\n"); exit (0); #else #if defined (CMU) printf ("ns32k-encore-mach\n"); exit (0); #else printf ("ns32k-encore-bsd\n"); exit (0); #endif #endif #endif #if defined (__386BSD__) printf ("i386-pc-bsd\n"); exit (0); #endif #if defined (sequent) #if defined (i386) printf ("i386-sequent-dynix\n"); exit (0); #endif #if defined (ns32000) printf ("ns32k-sequent-dynix\n"); exit (0); #endif #endif #if defined (_SEQUENT_) struct utsname un; uname(&un); if (strncmp(un.version, "V2", 2) == 0) { printf ("i386-sequent-ptx2\n"); exit (0); } if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ printf ("i386-sequent-ptx1\n"); exit (0); } printf ("i386-sequent-ptx\n"); exit (0); #endif #if defined (vax) # if !defined (ultrix) # include # if defined (BSD) # if BSD == 43 printf ("vax-dec-bsd4.3\n"); exit (0); # else # if BSD == 199006 printf ("vax-dec-bsd4.3reno\n"); exit (0); # else printf ("vax-dec-bsd\n"); exit (0); # endif # endif # else printf ("vax-dec-bsd\n"); exit (0); # endif # else printf ("vax-dec-ultrix\n"); exit (0); # endif #endif #if defined (alliant) && defined (i860) printf ("i860-alliant-bsd\n"); exit (0); #endif exit (1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } # Convex versions that predate uname can use getsysinfo(1) if [ -x /usr/convex/getsysinfo ] then case `getsysinfo -f cpu_type` in c1*) echo c1-convex-bsd exit ;; c2*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; c34*) echo c34-convex-bsd exit ;; c38*) echo c38-convex-bsd exit ;; c4*) echo c4-convex-bsd exit ;; esac fi cat >&2 < in order to provide the needed information to handle your system. config.guess timestamp = $timestamp uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` /bin/uname -X = `(/bin/uname -X) 2>/dev/null` hostinfo = `(hostinfo) 2>/dev/null` /bin/universe = `(/bin/universe) 2>/dev/null` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` /bin/arch = `(/bin/arch) 2>/dev/null` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` UNAME_MACHINE = ${UNAME_MACHINE} UNAME_RELEASE = ${UNAME_RELEASE} UNAME_SYSTEM = ${UNAME_SYSTEM} UNAME_VERSION = ${UNAME_VERSION} EOF exit 1 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: librep-0.90.2/test0000755000175200017520000000060711245011153012766 0ustar chrischris#!/bin/sh top=${REPTOP:-.} name=${REPNAME:-rep} if [ "x$1" != "x-g" ]; then REP_DL_LOAD_PATH=${top}/src/.libexec \ REPLISPDIR=${top}/lisp \ REPDOCFILE=${top}/doc-strings \ ${top}/src/${name} $* else shift REP_DL_LOAD_PATH=${top}/src/.libexec \ REPLISPDIR=${top}/lisp \ REPDOCFILE=${top}/doc-strings \ ${top}/libtool gdb ${top}/src/${name} $* fi librep-0.90.2/rules.mk.sh0000644000175200017520000000140611245011153014153 0ustar chrischris# rules.mk.sh -- Build dynamically-loadable objects for librep # $Id$ repdir=$1 repcommonexecdir=$2 repdocfile=$3 cat < ;; Author: John Harper ;; Keywords: unix, tools, rep ;; Copyright (C) 1992, 93, 94, 95, 96, 1998 Free Software Foundation, Inc. ;; This file is part of Librep. ;; Librep is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; Librep is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with Librep; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;; This file is the perldb portions of gud.el with trivial substitutions ;; to make it work with rep.. (require 'gud) ;; ====================================================================== ;; rep functions ;;; History of argument lists passed to rep. (defvar gud-rep-history nil) (defun gud-rep-massage-args (file args) (cons "--debug" (cons (car args) (cons "--emacs-debug" (cdr args))))) ;; There's no guarantee that Emacs will hand the filter the entire ;; marker at once; it could be broken up across several strings. We ;; might even receive a big chunk with several markers in it. If we ;; receive a chunk of text which looks like it might contain the ;; beginning of a marker, we save it here between calls to the ;; filter. (defun gud-rep-marker-filter (string) (setq gud-marker-acc (concat gud-marker-acc string)) (let ((output "")) ;; Process all the complete markers in this chunk. (while (string-match "\032\032\\(\\([a-zA-Z]:\\)?[^:\n]*\\):\\([0-9]*\\):.*\n" gud-marker-acc) (setq ;; Extract the frame position from the marker. gud-last-frame (cons (substring gud-marker-acc (match-beginning 1) (match-end 1)) (string-to-int (substring gud-marker-acc (match-beginning 3) (match-end 3)))) ;; Append any text before the marker to the output we're going ;; to return - we don't include the marker in this text. output (concat output (substring gud-marker-acc 0 (match-beginning 0))) ;; Set the accumulator to the remaining text. gud-marker-acc (substring gud-marker-acc (match-end 0)))) ;; Does the remaining text look like it might end with the ;; beginning of another marker? If it does, then keep it in ;; gud-marker-acc until we receive the rest of it. Since we ;; know the full marker regexp above failed, it's pretty simple to ;; test for marker starts. (if (string-match "\032.*\\'" gud-marker-acc) (progn ;; Everything before the potential marker start can be output. (setq output (concat output (substring gud-marker-acc 0 (match-beginning 0)))) ;; Everything after, we save, to combine with later input. (setq gud-marker-acc (substring gud-marker-acc (match-beginning 0)))) (setq output (concat output gud-marker-acc) gud-marker-acc "")) output)) (defun gud-rep-find-file (f) (save-excursion (let ((buf (find-file-noselect f))) (set-buffer buf) (gud-make-debug-menu) buf))) (defcustom gud-rep-command-name "rep" "File name for executing rep." :type 'string :group 'gud) ;;;###autoload (defun rep-debugger (command-line) "Run the rep debugger on program FILE in buffer *gud-FILE*. The directory containing FILE becomes the initial working directory and source-file directory for your debugger." (interactive (list (read-from-minibuffer "Run rep debugger (like this): " (if (consp gud-rep-history) (car gud-rep-history) (concat gud-rep-command-name " " (buffer-file-name) " ")) nil nil '(gud-rep-history . 1)))) (gud-common-init command-line 'gud-rep-massage-args 'gud-rep-marker-filter 'gud-rep-find-file) ; (gud-def gud-break "b %l" "\C-b" "Set breakpoint at current line.") ; (gud-def gud-remove "d %l" "\C-d" "Remove breakpoint at current line") (gud-def gud-step "s" "\C-s" "Step one source line with display.") (gud-def gud-next "n" "\C-n" "Step one line (skip functions).") (gud-def gud-cont "c" "\C-r" "Continue with display.") ; (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") (gud-def gud-up "u %p" "<" "Up N stack frames (numeric arg).") (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") (gud-def gud-print "p %e" "\C-p" "Evaluate perl expression at point.") (setq comint-prompt-regexp "^rep-db> ") (setq paragraph-start comint-prompt-regexp) (run-hooks 'rep-debugger-mode-hook)) (provide 'rep-debugger) ;; rep-debugger.el ends here librep-0.90.2/mkinstalldirs0000755000175200017520000000124411245011153014665 0ustar chrischris#! /bin/sh # mkinstalldirs --- make directory hierarchy # Author: Noah Friedman # Created: 1993-05-16 # Public domain # $Id$ errstatus=0 for file do set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'` shift pathcomp= for d do pathcomp="$pathcomp$d" case "$pathcomp" in -* ) pathcomp=./$pathcomp ;; esac if test ! -d "$pathcomp"; then echo "mkdir $pathcomp" 1>&2 mkdir "$pathcomp" || lasterr=$? if test ! -d "$pathcomp"; then errstatus=$lasterr fi fi pathcomp="$pathcomp/" done done exit $errstatus # mkinstalldirs ends here librep-0.90.2/librep.spec.in0000644000175200017520000000604011245011153014614 0ustar chrischrisName: librep Version: @version@ Release: 1 Summary: An embeddable LISP environment License: GPL Group: Development/Languages Source: http://download.sourceforge.net/librep/librep-%{version}.tar.bz2 URL: http://librep.sourceforge.net/ Packager: Christopher Bratusek Buildroot: %{_tmppath}/%{name}-%{version}-%{release}-root BuildRequires: gmp-devel gdbm-devel readline-devel texinfo %if %($(pkg-config emacs) ; echo $?) %define emacs_lispdir %{_datadir}/emacs/site-lisp %else %define emacs_lispdir %(pkg-config emacs --variable sitepkglispdir) %endif %description This is a lightweight Lisp environment for UNIX. It contains a Lisp interpreter, byte-code compiler and virtual machine. Applications may use the Lisp interpreter as an extension language, or it may be used for standalone scripts. Originally inspired by Emacs Lisp, the language dialect combines many of the elisp features while trying to remove some of the main deficiencies, with features from Common Lisp and Scheme. %package devel Summary: librep include files and link libraries Group: Development/Languages Requires: %{name} = @version@, pkgconfig %description devel Link libraries and C header files for librep development. %package -n emacs-%{name}-el Group: System Environment/Libraries Summary: Emacs bindings for the librep main application %description -n emacs-%{name}-el The librep-emacs package contains the emacs related .el files so that librep nicely interacts and integrates into emacs. %prep %setup -q %build %configure --with-readline --enable-shared --disable-rpath --libexecdir=%{_libdir} make %{?_smp_mflags} %install rm -rf $RPM_BUILD_ROOT make install DESTDIR=$RPM_BUILD_ROOT rm -f $RPM_BUILD_ROOT%{_infodir}/dir %clean rm -rf $RPM_BUILD_ROOT %post /sbin/ldconfig /sbin/install-info %{_infodir}/%{name}.info %{_infodir}/dir || : %preun if [ $1 = 0 ]; then /sbin/install-info --delete %{_infodir}/%{name}.info %{_infodir}/dir || : fi %postun -p /sbin/ldconfig %files %defattr(-,root,root,-) %doc NEWS README THANKS TODO BUGS TREE HACKING %dir %{_libdir}/rep/ %{_bindir}/rep %{_bindir}/rep-remote %{_datadir}/rep/ %{_infodir}/librep.info* %{_libdir}/librep.so.* %{_libdir}/rep/%{version}/%{_host}/ %files devel %defattr(-,root,root,-) %{_bindir}/rep-config %{_bindir}/rep-xgettext %{_bindir}/repdoc %{_includedir}/rep*.h %{_libdir}/rep/%{_host}/ %{_libdir}/pkgconfig/librep.pc %{_libdir}/librep.so %exclude %{_libdir}/librep.la %exclude %{_libdir}/librep.a %files -n emacs-%{name}-el %defattr(-,root,root,-) %{emacs_lispdir}/*.el %changelog * Sun Jan 18 2009 Christopher Bratusek - several updates * Fri Jan 02 2009 Christopher Bratusek - source archive is a .tar.bz2 * Thu Dec 18 2008 Christopher Bratusek - rep.m4 no longer available - install librep.pc * Tue Jun 13 2000 John Harper - use better macros * Wed Nov 10 1999 Michael K. Johnson - post{,un} use -p * Mon Sep 13 1999 Aron Griffis - 0.5 spec file update: added buildroot librep-0.90.2/librep.pc.in0000644000175200017520000000056411245011153014271 0ustar chrischrisversion=@version@ host_type=@host@ prefix=@prefix@ exec_prefix=@exec_prefix@ libdir=@libdir@ libexecdir=@libexecdir@ repexecdir=@repexecdir@ repcommonexecdir=@repcommonexecdir@ includedir=@includedir@ Cflags: -I${includedir}/ -I${repcommonexecdir}/ Libs: -L@libdir@ -lrep -lcrypt -lgmp -lm Name: librep Description: librep - a lisp dialect Version: @version@ Requires: librep-0.90.2/librep.ebuild.in0000644000175200017520000000247611245011153015137 0ustar chrischris# Copyright 1999-2008 Gentoo Foundation # Distributed under the terms of the GNU General Public License v2 # $Header: /var/cvsroot/gentoo-x86/dev-libs/librep/librep-0.17-r2.ebuild,v 1.11 2006/10/20 00:24:49 kloeri Exp $ inherit eutils libtool toolchain-funcs multilib autotools DESCRIPTION="Shared library implementing a Lisp dialect" HOMEPAGE="http://librep.sourceforge.net/" SRC_URI="mirror://sourceforge/${PN}/${P}.tar.bz2" LICENSE="GPL-2" SLOT="0" KEYWORDS="alpha amd64 ia64 ppc sparc x86 ppc64" IUSE="readline" RDEPEND=">=sys-libs/gdbm-1.8.0 readline? ( sys-libs/readline )" DEPEND="${RDEPEND} sys-apps/texinfo" src_unpack() { unpack ${A} cd "${S}" eautoreconf elibtoolize || die "elibtoolize failed" epunt_cxx } src_compile() { local myconf="$(use_with readline)" use ppc && myconf="${myconf} --with-stack-direction=1" # It seems that stack-direction=-1 for gcc-3.x and 1 for gcc-4.x on ia64 if use ia64 && [[ $(gcc-major-version) -ge 4 ]]; then myconf="${myconf} --with-stack-direction=1" fi econf \ --libexecdir=/usr/$(get_libdir) \ --without-gmp \ --without-ffi \ ${myconf} || die "configure failed" LC_ALL=C emake || die "make failed" } src_install() { make DESTDIR="${D}" install || die "make install failed" dodoc AUTHORS BUGS ChangeLog NEWS README THANKS TODO TREE docinto doc dodoc doc/* } librep-0.90.2/aclocal.m40000644000175200017520000001613211245011165013724 0ustar chrischris# generated automatically by aclocal 1.11 -*- Autoconf -*- # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, # 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. # lcmessage.m4 serial 4 (gettext-0.14.2) dnl Copyright (C) 1995-2002, 2004-2005 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. dnl dnl This file can can be used in projects which are not available under dnl the GNU General Public License or the GNU Library General Public dnl License but which still want to provide support for the GNU gettext dnl functionality. dnl Please note that the actual code of the GNU gettext library is covered dnl by the GNU Library General Public License, and the rest of the GNU dnl gettext package package is covered by the GNU General Public License. dnl They are *not* in the public domain. dnl Authors: dnl Ulrich Drepper , 1995. # Check whether LC_MESSAGES is available in . AC_DEFUN([gt_LC_MESSAGES], [ AC_CACHE_CHECK([for LC_MESSAGES], gt_cv_val_LC_MESSAGES, [AC_TRY_LINK([#include ], [return LC_MESSAGES], gt_cv_val_LC_MESSAGES=yes, gt_cv_val_LC_MESSAGES=no)]) if test $gt_cv_val_LC_MESSAGES = yes; then AC_DEFINE(HAVE_LC_MESSAGES, 1, [Define if your file defines LC_MESSAGES.]) fi ]) # pkg.m4 - Macros to locate and utilise pkg-config. -*- Autoconf -*- # # Copyright © 2004 Scott James Remnant . # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # PKG_PROG_PKG_CONFIG([MIN-VERSION]) # ---------------------------------- AC_DEFUN([PKG_PROG_PKG_CONFIG], [m4_pattern_forbid([^_?PKG_[A-Z_]+$]) m4_pattern_allow([^PKG_CONFIG(_PATH)?$]) AC_ARG_VAR([PKG_CONFIG], [path to pkg-config utility])dnl if test "x$ac_cv_env_PKG_CONFIG_set" != "xset"; then AC_PATH_TOOL([PKG_CONFIG], [pkg-config]) fi if test -n "$PKG_CONFIG"; then _pkg_min_version=m4_default([$1], [0.9.0]) AC_MSG_CHECKING([pkg-config is at least version $_pkg_min_version]) if $PKG_CONFIG --atleast-pkgconfig-version $_pkg_min_version; then AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) PKG_CONFIG="" fi fi[]dnl ])# PKG_PROG_PKG_CONFIG # PKG_CHECK_EXISTS(MODULES, [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND]) # # Check to see whether a particular set of modules exists. Similar # to PKG_CHECK_MODULES(), but does not set variables or print errors. # # # Similar to PKG_CHECK_MODULES, make sure that the first instance of # this or PKG_CHECK_MODULES is called, or make sure to call # PKG_CHECK_EXISTS manually # -------------------------------------------------------------- AC_DEFUN([PKG_CHECK_EXISTS], [AC_REQUIRE([PKG_PROG_PKG_CONFIG])dnl if test -n "$PKG_CONFIG" && \ AC_RUN_LOG([$PKG_CONFIG --exists --print-errors "$1"]); then m4_ifval([$2], [$2], [:]) m4_ifvaln([$3], [else $3])dnl fi]) # _PKG_CONFIG([VARIABLE], [COMMAND], [MODULES]) # --------------------------------------------- m4_define([_PKG_CONFIG], [if test -n "$PKG_CONFIG"; then if test -n "$$1"; then pkg_cv_[]$1="$$1" else PKG_CHECK_EXISTS([$3], [pkg_cv_[]$1=`$PKG_CONFIG --[]$2 "$3" 2>/dev/null`], [pkg_failed=yes]) fi else pkg_failed=untried fi[]dnl ])# _PKG_CONFIG # _PKG_SHORT_ERRORS_SUPPORTED # ----------------------------- AC_DEFUN([_PKG_SHORT_ERRORS_SUPPORTED], [AC_REQUIRE([PKG_PROG_PKG_CONFIG]) if $PKG_CONFIG --atleast-pkgconfig-version 0.20; then _pkg_short_errors_supported=yes else _pkg_short_errors_supported=no fi[]dnl ])# _PKG_SHORT_ERRORS_SUPPORTED # PKG_CHECK_MODULES(VARIABLE-PREFIX, MODULES, [ACTION-IF-FOUND], # [ACTION-IF-NOT-FOUND]) # # # Note that if there is a possibility the first call to # PKG_CHECK_MODULES might not happen, you should be sure to include an # explicit call to PKG_PROG_PKG_CONFIG in your configure.ac # # # -------------------------------------------------------------- AC_DEFUN([PKG_CHECK_MODULES], [AC_REQUIRE([PKG_PROG_PKG_CONFIG])dnl AC_ARG_VAR([$1][_CFLAGS], [C compiler flags for $1, overriding pkg-config])dnl AC_ARG_VAR([$1][_LIBS], [linker flags for $1, overriding pkg-config])dnl pkg_failed=no AC_MSG_CHECKING([for $1]) _PKG_CONFIG([$1][_CFLAGS], [cflags], [$2]) _PKG_CONFIG([$1][_LIBS], [libs], [$2]) m4_define([_PKG_TEXT], [Alternatively, you may set the environment variables $1[]_CFLAGS and $1[]_LIBS to avoid the need to call pkg-config. See the pkg-config man page for more details.]) if test $pkg_failed = yes; then _PKG_SHORT_ERRORS_SUPPORTED if test $_pkg_short_errors_supported = yes; then $1[]_PKG_ERRORS=`$PKG_CONFIG --short-errors --errors-to-stdout --print-errors "$2"` else $1[]_PKG_ERRORS=`$PKG_CONFIG --errors-to-stdout --print-errors "$2"` fi # Put the nasty error message in config.log where it belongs echo "$$1[]_PKG_ERRORS" >&AS_MESSAGE_LOG_FD ifelse([$4], , [AC_MSG_ERROR(dnl [Package requirements ($2) were not met: $$1_PKG_ERRORS Consider adjusting the PKG_CONFIG_PATH environment variable if you installed software in a non-standard prefix. _PKG_TEXT ])], [AC_MSG_RESULT([no]) $4]) elif test $pkg_failed = untried; then ifelse([$4], , [AC_MSG_FAILURE(dnl [The pkg-config script could not be found or is too old. Make sure it is in your PATH or set the PKG_CONFIG environment variable to the full path to pkg-config. _PKG_TEXT To get pkg-config, see .])], [$4]) else $1[]_CFLAGS=$pkg_cv_[]$1[]_CFLAGS $1[]_LIBS=$pkg_cv_[]$1[]_LIBS AC_MSG_RESULT([yes]) ifelse([$3], , :, [$3]) fi[]dnl ])# PKG_CHECK_MODULES m4_include([m4/libtool.m4]) m4_include([m4/ltoptions.m4]) m4_include([m4/ltsugar.m4]) m4_include([m4/ltversion.m4]) m4_include([m4/lt~obsolete.m4]) librep-0.90.2/install-aliases0000755000175200017520000000561711245011152015101 0ustar chrischris#!/bin/sh # script to extract and create aliases from source files # $Id$ verbose=no dry_run=no # copy a .la file, editing the `dlname=' line to the new stem copy_la_file () { la_src="$1"; la_dest="$2"; shift 2 old_stem=`echo "$la_src" | sed -e 's|^.*/\([^/]*\)\.[^/]*$|\1|'` new_stem=`echo "$la_dest" | sed -e 's|^.*/\([^/]*\)\.[^/]*$|\1|'` sed -e '/^dlname=/ s/'"${old_stem}"'/'"${new_stem}"'/' \ < "$la_src" > "$la_dest" } # return the outermost directory of the filename prefix () { case "$1" in */*) echo "$1" | sed -e 's|^\([^/]*\)/.*$|\1|' ;; *) echo "" ;; esac } # return the filename without its outermost directory postfix () { echo "$1" | sed -e 's|^[^/]*/\(.*\)$|\1|' } # strip common leading directories from $2 strip_common_prefix () { str1="$1"; str2="$2"; shift 2 pfx=`prefix "$str1"`; str1=`postfix "$str1"` while [ x"$pfx" != x ]; do case "$str2" in $pfx*) str2=`postfix "$str2"` ;; *) break ;; esac pfx=`prefix "$str1"`; str1=`postfix "$str1"` done echo "$str2" } # turns `FOO/BAR/BAZ' into `FOO/BAR/libBAZ' lib_prefixed () { echo "$1" | sed -e 's|\([^/]*\)$|lib\1|' } dosome () { destroot="$1"; src="$2"; dest="$3"; shift 3 for g in `echo "${destroot}/${src}.*"`; do if [ -r "$g" ]; then suf=`echo "$g" | sed -e 's|^'"${destroot}/${src}"'\(.*\)$|\1|'` if [ $verbose = yes ]; then echo "${src}${suf} -> ${dest}${suf}" fi if [ $dry_run = no ]; then rm -f "${destroot}/${dest}${suf}" case "$suf" in .la) copy_la_file "${destroot}/${src}${suf}" \ "${destroot}/${dest}${suf}" ;; *) # make sure links are relative to their own directory local_src=`strip_common_prefix "$dest" "$src"` ln -s "${local_src}${suf}" "${destroot}/${dest}${suf}" ;; esac fi fi done } doit () { destroot="$1"; shift for f in $*; do src=`echo "$f" | sed -e 's/^\(.*\)#\(.*\)$/\1/'` dest=`echo "$f" | sed -e 's/^\(.*\)#\(.*\)$/\2/'` dosome "$destroot" "$src" "$dest" # libtool sometimes needs to prefix module libraries with a `lib' # prefix; this will try to pick up such libraries dosome "$destroot" `lib_prefixed "$src"` `lib_prefixed "$dest"` done } while [ x"$1" != x ]; do case $1 in -l) files=`find "$2" -name '*.jl' -print` aliases=`grep '(define-structure-alias' $files | sed -e 's/^.*(define-structure-alias \([^ ]*\) \([^ ]*\)).*$/\2#\1/' | tr . /` doit "$3" $aliases shift 3 ;; -c) files=`find "$2" -name '*.c' -print` aliases=`grep '::alias:' $files | sed -e 's/^.*::alias:\([^ ]*\) \(.*\)::.*$/\2#\1/' | tr . /` doit "$3" $aliases shift 3 ;; -v) verbose=yes; shift ;; -n) dry_run=yes; verbose=yes; shift ;; *) echo "usage [-v] [-n] [-l LISP-SRC-DIR LISP-INST-DIR] [-c C-SRC-DIR LA-INST-DIR]" exit 1 ;; esac done librep-0.90.2/emulate-gnu-tar0000755000175200017520000000470711245011152015022 0ustar chrischris#!/bin/sh # emulate-gnu-tar -- emulate the options of GNU tar that librep uses # in its tar-file handling code. # $Id$ compression_mode="" command="" tarfile="" to_stdout="" version="1.0" original_directory=`pwd` usage () { cat <&2 exit 1 ;; esac shift done if [ "x$command" = x ]; then usage exit 1 fi case "$compression_mode" in gzip) input="gzip -d -c \"$tarfile\" |" ;; compress) input="compress -d -c \"$tarfile\" |" ;; bzip2) input="bzip2 -d -c \"$tarfile\" |" ;; xz) input="xz -d -c \"$tarfile\" |" ;; lzma) input="lzma -d -c \"$tarfile\" |" ;; *) input="cat \"$tarfile\" |" ;; esac case "$command" in list) eval "$input tar tvf -" ;; extract) if [ "x$to_stdout" = "x" ]; then eval "$input tar xf -" exit $? else # Extract the file to a temporary directory, then cat it.. tmpdir="/tmp/rep-emulate-gnu-tar.$$.output" mkdir "$tmpdir" || exit $? cd "$tmpdir" eval "$input tar xf - $to_stdout" || ( rm -rf $tmpdir && exit $? ) cat "$to_stdout" cd "$original_directory" rm -rf "$tmpdir" exit 0 fi ;; *) echo "Unimplemented command: $command" exit 1 ;; esac librep-0.90.2/configure.in0000644000175200017520000005116411245011152014375 0ustar chrischrisdnl Process this file with autoconf to produce a configure script. dnl Copyright (C) 1998 John Harper dnl $Id: configure.in,v 1.146 2006/02/01 05:47:41 jsh Exp $ dnl dnl This file is part of librep. dnl dnl librep is free software; you can redistribute it and/or modify it dnl under the terms of the GNU General Public License as published by dnl the Free Software Foundation; either version 2, or (at your option) dnl any later version. dnl dnl librep is distributed in the hope that it will be useful, but dnl WITHOUT ANY WARRANTY; without even the implied warranty of dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the dnl GNU General Public License for more details. dnl dnl You should have received a copy of the GNU General Public License dnl along with librep; see the file COPYING. If not, write to dnl the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. AC_REVISION($Revision: 1.146 $) AC_INIT(src/rep_subrs.h) AC_CONFIG_HEADER(config.h src/rep_config.h) AC_CONFIG_MACRO_DIR([m4]) AM_PROG_LIBTOOL dnl Release versioning info version="0.90.2" dnl libtool versioning info: `CURRENT:REVISION:AGE'. CURRENT is the dnl current interface id, REVISION is the version number of this dnl implementation, AGE defines the first interface id also supported dnl (i.e. all interfaces between CURRENT-AGE and CURRENT are supported) libcurrent=13 librevision=0 libage=4 libversion="$libcurrent:$librevision:$libage" makefile_template="Makefile.in:Makedefs.in" output_files="src/Makefile:Makedefs.in:src/Makefile.in\ lisp/Makefile:Makedefs.in:lisp/Makefile.in\ Makefile:Makedefs.in:Makefile.in\ man/Makefile:Makedefs.in:man/Makefile.in\ intl/Makefile librep.spec librep.pc librep.ebuild" dnl Find the system type AC_CANONICAL_HOST dnl Remove trailing slash in $prefix if necessary case "${prefix}" in */) prefix=`echo ${prefix} | sed -e 's/^\(.*\)\/$/\1/'` ;; esac repdir='${datadir}/rep' replispdir='${repdir}/${version}/lisp' repexecdir='${libexecdir}/rep/${version}/${host_type}' repcommonexecdir='${libexecdir}/rep/${host_type}' repdocfile='${repexecdir}/doc-strings' emacssitelispdir='${datadir}/emacs/site-lisp' dnl make sure we can find libraries and headers under $prefix case "$prefix" in /|/usr|/usr/local|NONE) ;; *) LDFLAGS="${LDFLAGS} -L$prefix/lib" CPPFLAGS="${CPPFLAGS} -I$prefix/include" ;; esac EXTRA_LIBOBJS="" AC_SUBST(EXTRA_LIBOBJS) AC_SUBST(LDFLAGS) AC_SUBST(CPPFLAGS) AC_SUBST(CFLAGS) dnl Checks for programs. AC_PROG_CC AC_ISC_POSIX AC_PROG_CPP AC_PROG_INSTALL AC_PROG_LN_S AC_PROG_MAKE_SET AC_PROG_GCC_TRADITIONAL AC_DISABLE_STATIC AC_PROG_LIBTOOL dnl Abort if shared libraries aren't enabled if test "${enable_shared}" != "yes"; then AC_MSG_ERROR([Need shared libraries enabled]) fi dnl Checks for libraries. AC_CHECK_FUNC(gethostent, , AC_CHECK_LIB(nsl, gethostent)) AC_CHECK_FUNC(setsockopt, , AC_CHECK_LIB(socket, setsockopt)) AC_CHECK_FUNC(dlopen, , AC_CHECK_LIB(dl, dlopen)) dnl Checks for header files. AC_HEADER_DIRENT AC_HEADER_STDC AC_HEADER_SYS_WAIT AC_HEADER_TIME AC_CHECK_HEADERS(fcntl.h sys/ioctl.h sys/time.h sys/utsname.h unistd.h siginfo.h memory.h stropts.h termios.h string.h limits.h argz.h locale.h nl_types.h malloc.h sys/param.h) dnl Check for GNU MP library and header files AC_ARG_WITH(gmp, [ --without-gmp Don't use GMP for bignum/rational numbers], [], [with_gmp=maybe]) GMP_LIBS="-lm" if test "$with_gmp" != "no"; then AC_ARG_WITH(gmp-prefix, [ --with-gmp-prefix=DIR path to GMP], [if test "$withval" != "no"; then CPPFLAGS="${CPPFLAGS} -I$withval/include" LDFLAGS="${LDFLAGS} -L$withval/lib" fi], dnl debian brain-damage [if test -d /usr/include/gmp2; then CPPFLAGS="${CPPFLAGS} -I/usr/include/gmp2" fi]) found_gmp=no AC_CHECK_HEADER(gmp.h, [AC_CHECK_LIB(gmp, mpz_init, [GMP_LIBS="-lgmp -lm"; found_gmp=yes], [AC_CHECK_LIB(gmp, __gmpz_init, [GMP_LIBS="-lgmp -lm"; found_gmp=yes])])]) if test "$found_gmp" = "yes"; then AC_DEFINE(HAVE_GMP, 1, [Have libgmp]) _libs="$LIBS" LIBS="$LIBS $GMP_LIBS" AC_CHECK_FUNC(__gmp_randinit, AC_DEFINE(HAVE_GMP_RANDINIT, 1, [Have randinit in libgmp])) LIBS="$_libs" elif test "$with_gmp" != "no"; then AC_MSG_ERROR([Can't find GMP (--without-gmp for cut-down non-GMP build)]) fi fi AC_SUBST(GMP_LIBS) dnl Check for GNU DBM library and header files AC_ARG_WITH(gdbm-prefix, [ --with-gdbm-prefix=DIR path to GDBM],[ if test "$withval" != "no"; then CPPFLAGS="${CPPFLAGS} -I$withval/include" LDFLAGS="${LDFLAGS} -L$withval/lib" fi ]) AC_CHECK_HEADER(gdbm.h, AC_CHECK_LIB(gdbm, gdbm_open, GDBM_LIBS="-lgdbm", AC_MSG_ERROR(Cannot find GDBM library)), AC_MSG_ERROR(Cannot find GDBM header)) AC_SUBST(GDBM_LIBS) dnl Check for Doug Lea's malloc in libc doug_lea_malloc=yes AC_CHECK_FUNC(malloc_get_state, , doug_lea_malloc=no) AC_CHECK_FUNC(malloc_set_state, , doug_lea_malloc=no) if test "$doug_lea_malloc" = "no"; then dnl We used to compile our own version of dlmalloc on most dnl platforms that didn't have it in their libc. But the list dnl of exceptions was growing too long.. AC_DEFINE(LIBC_MALLOC, 1, [Have libc malloc]) else AC_DEFINE(DOUG_LEA_MALLOC, 1, [Have doug lea malloc]) AC_DEFINE(LIBC_MALLOC, 1, [Have libc malloc]) fi dnl Check for readline AC_ARG_WITH(readline, [ --with-readline support fancy command input editing --without-readline Don't use readline], [], [with_readline=maybe]) if test "$with_readline" != "no"; then dnl Save in case test with directory specified fails _cppflags=${CPPFLAGS} _ldflags=${LDFLAGS} AC_ARG_WITH(readline-prefix, [ --with-readline-prefix=DIR path to readline], [ if test "$withval" != "no" -a "$withval" != "yes"; then CPPFLAGS="${CPPFLAGS} -I$withval/include" LDFLAGS="${LDFLAGS} -L$withval/lib" fi ]) dnl check for terminal library dnl this is a very cool solution from octave's configure.in unset tcap for termlib in ncurses curses termcap terminfo termlib; do AC_CHECK_LIB(${termlib}, tputs, [tcap="$tcap -l$termlib"]) case "$tcap" in *-l${termlib}*) break ;; esac done AC_CHECK_HEADER(readline/readline.h, AC_CHECK_LIB(readline, readline,[ READLINE_LIBS=" -L/lib${libsuff} -lreadline $tcap" AC_DEFINE(HAVE_LIBREADLINE, 1, [Have libreadline])] found_readline=yes, , $tcap)) if test -z "$READLINE_LIBS"; then if test "$with_readline_prefix" = "yes"; then AC_MSG_ERROR([Can't find readline libraries]) else CPPFLAGS=${_cppflags} LDFLAGS=${_ldflags} fi fi fi AC_SUBST(READLINE_LIBS) dnl Check for ffi FFI_MIN_VER=3.0 AC_ARG_WITH(ffi, [ --with-ffi Support for ffi --without-ffi Don't use ffi], [], [with_ffi=yes]) if test "$with_ffi" != "no"; then PKG_CHECK_MODULES(LIBFFI, libffi >= $FFI_MIN_VER ,found_ffi=yes ,AC_MSG_ERROR([can't locate libffi])) fi dnl Check for dynamic loading AC_CHECK_HEADER(dlfcn.h, [AC_DEFINE(HAVE_DLFCN_H, 1, [Have dlfcn header])]) AC_CHECK_HEADER(dl.h, [AC_DEFINE(HAVE_DL_H, 1, [Have dl header])]) AC_CHECK_HEADER(sys/dl.h, [AC_DEFINE(HAVE_SYS_DL_H, 1, [Have sysdl header])]) dl_ok=no AC_CHECK_FUNC(dlopen, [AC_DEFINE(HAVE_DLOPEN, 1, [Have dlopen]) dl_ok=dl], AC_CHECK_LIB(dl, dlopen, [AC_DEFINE(HAVE_DLOPEN, 1, [Have dlopen]) dl_ok=dl])) AC_CHECK_FUNC(shl_load, [AC_DEFINE(HAVE_SHL_LOAD, 1, [Have shlload]) dl_ok=shl], AC_CHECK_LIB(dld, shl_load, [AC_DEFINE(HAVE_DLOPEN, 1, [Have dlopen]) dl_ok=shl])) if test $dl_ok = dl; then AC_MSG_CHECKING([for preceding underscore in symbols]) dnl copied from glib configure.in AC_TRY_RUN([#ifdef HAVE_DLFCN_H # include #endif int glib_underscore_test (void) { return 42; } int main() { void *f1 = (void*)0, *f2 = (void*)0, *handle; handle = dlopen ((void*)0, 0); if (handle) { f1 = dlsym (handle, "glib_underscore_test"); f2 = dlsym (handle, "_glib_underscore_test"); } return (!f2 || f1); }], [AC_DEFINE(DLSYM_NEED_USCORE, 1, [Need dlsym uscore]) AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)]) dnl RTLD_GLOBAL is broken for Tru64 UNIX V5.0 and V5.0A, such that dnl xh = dlopen("libx.so", RTLD_GLOBAL|RTLD_LAZY); /* provides func */ dnl yh = dlopen("liby.so", RTLD_GLOBAL|RTLD_LAZY); /* provides func */ dnl yf = dlsym(yh, "func"); /* Error: returns func from libx.so */ dnl It's hard to test for this apart from the version string, so dnl that's what we use. case ${host} in *-dec-osf5*) AC_MSG_CHECKING([for broken RTLD_GLOBAL on Tru64]) if /usr/sbin/sizer -v | grep -E -q -e 'UNIX [[TVX]]5\.0A?(-[[[:digit:]]]+)? '; then AC_DEFINE(BROKEN_RTLD_GLOBAL, 1, [Broken rtld global]) AC_MSG_RESULT(yes) else AC_MSG_RESULT(no) fi ;; esac fi if test $dl_ok != no; then AC_DEFINE(HAVE_DYNAMIC_LOADING, 1, [Have dynamic Loading]) else AC_MSG_ERROR([can't figure out how to do dynamic loading]) fi dnl Checks for typedefs, structures, and compiler characteristics. AC_C_CONST AC_C_INLINE AC_TYPE_OFF_T AC_TYPE_PID_T AC_TYPE_SIZE_T AC_TYPE_SIGNAL dnl Checks for library functions. AC_FUNC_ALLOCA AC_FUNC_MMAP AC_FUNC_MEMCMP AC_FUNC_VPRINTF AC_CHECK_FUNCS(getcwd gethostname select socket strcspn strerror strstr stpcpy strtol psignal strsignal snprintf grantpt lrand48 getpagesize setitimer dladdr dlerror munmap putenv setenv setlocale strchr strcasecmp strncasecmp strdup __argz_count __argz_stringify __argz_next siginterrupt gettimeofday strtoll strtoq) AC_REPLACE_FUNCS(realpath) dnl check for crypt () function AC_CHECK_FUNC(crypt, [AC_DEFINE(HAVE_CRYPT)], AC_CHECK_LIB(crypt, crypt, [AC_DEFINE(HAVE_CRYPT, 1, [Have crypt]) LIBS="$LIBS -lcrypt"])) dnl Custom tests dnl How do we get dependency lines in the Makefile? if test "x${GCC}" = "xyes"; then MAKEDEP='$(CC) -MM' else case ${host} in *-dec-osf*) dnl works on Tru64 MAKEDEP='$(CC) -M' ;; *-sun-solaris*) dnl works on Solaris MAKEDEP='/usr/ccs/lib/cpp -M' ;; *) dnl disable dependences? MAKEDEP='true' ;; esac fi AC_SUBST(MAKEDEP) dnl If using GCC and it doesn't look as though the cflags have been dnl set explicitly, add some warning options. if test "x${GCC}" = "xyes" -a "x$CFLAGS" = "x-g -O2"; then CFLAGS="${CFLAGS} -Wall -Wpointer-arith -Wmissing-prototypes" case ${host} in *-sun-solaris*) dnl Turn off implicit-int warnings since the X11 includes dnl on Solaris generate a lot of these CFLAGS="${CFLAGS} -Wno-implicit-int" ;; *-apple-darwin) dnl use -no-cpp-precomp with apple cc CFLAGS="${CFLAGS} -no-cpp-precomp" ;; esac fi AC_ARG_WITH(extra-cflags, [ --with-extra-cflags=FLAGS Extra flags to pass to C compiler], CFLAGS="${CFLAGS} $with_extra_cflags") dnl Does declare char **environ? AC_CACHE_CHECK([whether unistd.h declares environ], jade_cv_decl_environ, AC_TRY_COMPILE([#include ], [char **foo = environ;], [jade_cv_decl_environ=yes], [jade_cv_decl_environ=no])) if test ${jade_cv_decl_environ} = no; then AC_DEFINE(ENVIRON_UNDECLARED, 1, [Env undeclared]) fi dnl Are ptys available, and if so, how? AC_MSG_CHECKING([whether /dev/ptmx exists]) if test -r /dev/ptmx; then AC_MSG_RESULT([yes]) AC_DEFINE(HAVE_PTYS, 1, [Have ptys]) AC_DEFINE(HAVE_DEV_PTMX, 1, [Have dev/ptmx]) else AC_MSG_RESULT([no]) fi dnl Look for old-style /dev/ptyXN devices AC_CACHE_CHECK([whether /dev/ptyXN devices exist], jade_cv_sys_dev_pty, jade_cv_sys_dev_pty=no for c in p q r s t u v w x y z a b c d e f g h i j k l m n o; do if test -r "/dev/pty${c}0"; then jade_cv_sys_dev_pty=${c} break fi done) if test ${jade_cv_sys_dev_pty} != no; then AC_DEFINE(HAVE_PTYS, 1, [Have ptys]) AC_DEFINE_UNQUOTED(FIRST_PTY_LETTER, '${jade_cv_sys_dev_pty}', [The first pty letter]) fi dnl Try to find the aclocal directory for installation aclocaldir=none AC_ARG_WITH(aclocaldir, [ --with-aclocaldir=DIR Directory in which to install autoconf macros], aclocaldir=$withval) AC_MSG_CHECKING([for aclocal directory]) if test "$aclocaldir" = none; then aclocaldir="`aclocal --print-ac-dir 2>/dev/null`" if test "x${aclocaldir}" = "x"; then aclocaldir='${datadir}/aclocal' fi fi AC_MSG_RESULT([${aclocaldir}]) AC_SUBST(aclocaldir) AC_ARG_ENABLE(continuations, [ --disable-continuations Don't include support for continuations or multi-threading], [if test "$enableval" != "no"; then AC_DEFINE(WITH_CONTINUATIONS, 1, [Have continuations]) fi], [AC_DEFINE(WITH_CONTINUATIONS, 1, [Have continuations])]) AC_ARG_ENABLE(dballoc, [ --enable-dballoc Trace all memory allocations], [if test "$enableval" != "no"; then AC_DEFINE(DEBUG_SYS_ALLOC, 1, [Debug sys alloc]) fi]) AC_ARG_ENABLE(dbsyms, [ --disable-dbsyms When writing debug output, don't translate addresses to symbol names], [if test "$enableval" != "no"; then AC_DEFINE(DB_RESOLVE_SYMBOLS, 1, [DB resolve symbols]) fi], [AC_DEFINE(DB_RESOLVE_SYMBOLS, 1, [DB resolve symbols])]) AC_ARG_ENABLE(gprof, [ --enable-gprof Build for gprof (needs --enable-static)], [CFLAGS="${CFLAGS} -pg"; LDFLAGS="${LDFLAGS} -pg"]) AC_ARG_ENABLE(full-name-terminator, [ --enable-full-name-terminator=C Full name in gecos field of passwd file is terminated by first C character], [if test "$enableval" != "no"; then enableval="'$enableval'" AC_DEFINE_UNQUOTED(FULL_NAME_TERMINATOR, $enableval, [Have Fullname Terminator]) fi]) dnl Assumption for now HAVE_UNIX=1 AC_DEFINE(rep_HAVE_UNIX, 1, [Having Unix]) dnl We need to find an integer type that's big enough to store any pointer AC_MSG_CHECKING([for data type to store Lisp values]) AC_ARG_WITH(value-type, [ --with-value-type=TYPE Implicitly signed integer type, at least as wide as a pointer. [TYPE=] (see README)], [], [with_value_type="undef"]) if test "${with_value_type}" = "undef"; then AC_TRY_RUN([main () { exit (!(sizeof (int) >= sizeof (void *)));}], [with_value_type=int]) fi if test "${with_value_type}" = "undef"; then AC_TRY_RUN([main () { exit (!(sizeof (long int) >= sizeof (void *)));}], [with_value_type="long int"]) fi if test "${with_value_type}" = "undef"; then AC_TRY_RUN([main () { exit (!(sizeof (long long int) >= sizeof (void *)));}], [with_value_type="long long int"]) fi if test "${with_value_type}" = "undef"; then AC_MSG_ERROR([can't find Lisp value type; set --with-value-type (see README)]) fi AC_MSG_RESULT([${with_value_type}]) AC_DEFINE_UNQUOTED(rep_PTR_SIZED_INT, ${with_value_type}, [Have ptr sized int]) dnl Find the size (in bits) of the chosen value type AC_MSG_CHECKING([for size of Lisp value type]) AC_ARG_WITH(value-sizeof, [ --with-value-sizeof=N Size (in bytes) of value type. [N=]], [], [with_value_sizeof="undef"]) if test "${with_value_sizeof}" = "undef"; then dnl the following fragment is inspired by AC_CHECK_SIZEOF AC_TRY_RUN([#include main () { FILE *f = fopen ("conftestval", "w"); if (!f) exit (1); fprintf (f, "%d\n", sizeof (${with_value_type})); exit (0); }], [ with_value_sizeof=`cat conftestval`; rm -f conftestval]) fi AC_MSG_RESULT([${with_value_sizeof} bytes]) AC_DEFINE_UNQUOTED(rep_PTR_SIZED_INT_SIZEOF, ${with_value_sizeof}, [Have ptr sized int sizeof]) dnl What's the suffix to get an integer constant of the above size? AC_MSG_CHECKING([for value type constant suffix]) case "${with_value_type}" in "long long int"|"long long") rep_value_suffix=LL ;; *) dnl We should be okay to default to longs.. rep_value_suffix=L ;; esac AC_MSG_RESULT([${rep_value_suffix}]) AC_DEFINE_UNQUOTED(rep_PTR_SIZED_INT_SUFFIX, ${rep_value_suffix}, [Have ptr sized suffix]) dnl What's the printf integer conversion for this type? AC_MSG_CHECKING([for value type printf conversion]) case "${with_value_type}" in "long long int"|"long long") dnl other options would be L or q!? rep_value_conv=ll ;; long|"long int") rep_value_conv=l ;; *) rep_value_conv= ;; esac AC_MSG_RESULT([${rep_value_conv}]) AC_DEFINE_UNQUOTED(rep_PTR_SIZED_INT_CONV, "${rep_value_conv}", [Have ptr sized int conv]) dnl Check for size of some types AC_CHECK_SIZEOF(long) AC_CHECK_SIZEOF(long long) AC_CHECK_SIZEOF(void *) if test "x$ac_cv_sizeof_long_long" != "x0"; then AC_DEFINE(rep_HAVE_LONG_LONG, 1, [Have long long]) fi dnl This is the malloc granularity. It's unlikely that anything has dnl less alignment than the default value of the number of bytes in dnl the value type AC_ARG_WITH(malloc-alignment, [ --with-malloc-alignment=BYTES Must be less than or equal to the alignment returned by the malloc function. [BYTES=N]], [], [with_malloc_alignment=${with_value_sizeof}]) AC_DEFINE_UNQUOTED(rep_MALLOC_ALIGNMENT, ${with_malloc_alignment}, [Have malloc alignment]) dnl Check for gcc crashes on alpha (seems to be fixed in new snapshots, but dnl just to make it compile on all machines) if test "x${GCC}" = "xyes"; then AC_MSG_CHECKING([for broken alpha gcc]) AC_TRY_COMPILE([],[__builtin_return_address(1);], [AC_MSG_RESULT(no)], [AC_DEFINE(BROKEN_ALPHA_GCC, 1, [Have broken alpha gcc]) AC_MSG_RESULT(yes) AC_MSG_WARN([Backtrace support will not be compiled])]) fi AC_MSG_CHECKING([for stack growth direction]) AC_ARG_WITH(stack-direction, [ --with-stack-direction=DIR Stack growth direction. -1 for downwards, +1 for upwards.], [AC_MSG_RESULT(${with_stack_direction})], [with_stack_direction=unknown]) if test "${with_stack_direction}" = unknown; then case ${host_cpu} in sparc|i?86|powerpc) AC_MSG_RESULT([assuming downwards]) with_stack_direction="-1" ;; dnl any other known stack directions..? esac fi if test "${with_stack_direction}" = unknown; then AC_TRY_RUN([ void inner (char *foo) { char bar; exit (!(foo >= &bar)); } void main () { char foo; inner (&foo); } ], [AC_MSG_RESULT([downwards]) with_stack_direction=-1], [AC_MSG_RESULT([upwards]) with_stack_direction=+1]) fi if test "${with_stack_direction}" != unknown; then AC_DEFINE_UNQUOTED(STACK_DIRECTION, ${with_stack_direction}, [Have stack direction]) fi AC_ARG_ENABLE(paranoia, [ --enable-paranoia use wall, wno-error, ansi, pedantic compiler flags], [paranoia=$enableval], [paranoia="no"]) if test $paranoia = "yes"; then CFLAGS+=" -Wall -ansi -pedantic" fi dnl Nonstandard exported symbols AC_SUBST(version) AC_SUBST(libversion) AC_SUBST(repdir) AC_SUBST(repexecdir) AC_SUBST(repcommonexecdir) AC_SUBST(replispdir) AC_SUBST(repdocfile) AC_SUBST(emacssitelispdir) AC_SUBST(HAVE_UNIX) AC_SUBST(HAVE_X11) AC_SUBST(datarootdir) AC_DEFINE_UNQUOTED(rep_VERSION, "${version}", [Rep version]) AC_DEFINE_UNQUOTED(rep_INTERFACE, ${libcurrent}, [Rep interface]) dnl Hacks for libintl gt_LC_MESSAGES VERSION="$version" PACKAGE="librep" DATADIRNAME="share" MKINSTALLDIRS='${top_srcdir}/mkinstalldirs' INTLOBJS="\$(GETTOBJS)" GT_YES='#' GT_NO='' l=l AC_SUBST(VERSION) AC_SUBST(PACKAGE) AC_SUBST(DATADIRNAME) AC_SUBST(MKINSTALLDIRS) AC_SUBST(INTLOBJS) AC_SUBST(GT_YES) AC_SUBST(GT_NO) AC_SUBST(l) AC_SUBST(LIBFFI_LIBS) dnl If it looks like GNU gettext is in libc, don't compile a local copy USE_INCLUDED_LIBINTL=yes AC_SUBST(USE_INCLUDED_LIBINTL) AC_CHECK_FUNC(_nl_msg_cat_cntr, [AC_DEFINE(LIBC_GETTEXT, 1, [Have libc gettext]) AC_CHECK_HEADERS(libintl.h) USE_INCLUDED_LIBINTL=no]) dnl Build all files. Makes sure rules.mk is rebuild each time AC_OUTPUT(${output_files}, [rm -f rules.mk]) mv librep.ebuild librep-$version.ebuild if test "$with_gmp" != "no" && test "$found_gmp" == "yes" ; then with_gmp=yes else with_gmp=no fi if test "$with_readline" != "no" && test "$found_readline" == "yes"; then with_readline=yes else with_readline=no fi if test "$with_libffi" != "no" && test "$found_ffi" == "yes"; then with_ffi=yes else with_ffi=no fi echo " == == == == == == == == == == == == == librep: $version == == == == == == == == == == == == == prefix: $prefix exec_prefix: $exec_prefix libdir: $libdir libexecdir: $libexecdir == == == == == == == == == == == == == compiler: $CC cflags: $CFLAGS $DEVELOPMENT_CFLAGS preprocessor: $CPP cppflags: $CPPFLAGS ldflags: $LDFLAGS makeflags: $MAKEFLAGS == == == == == == == == == == == == == libgmp: $with_gmp libgdbm: yes readline: $with_readline libffi: $with_ffi == == == == == == == == == == == == == " dnl If it doesn't look like GNU Make is being used, give a friendly warning tem=`make --version -f /dev/null 2>&1 | grep GNU` if test "x$tem" = "x"; then AC_MSG_WARN([You need to use GNU Make when compiling]) fi dnl Local variables: dnl major-mode: sh-mode dnl End: librep-0.90.2/config.h.in0000644000175200017520000002160111245011152014100 0ustar chrischris/* config.h.in. Generated from configure.in by autoheader. */ /* Have broken alpha gcc */ #undef BROKEN_ALPHA_GCC /* Broken rtld global */ #undef BROKEN_RTLD_GLOBAL /* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP systems. This function is required for `alloca.c' support on those systems. */ #undef CRAY_STACKSEG_END /* Define to 1 if using `alloca.c'. */ #undef C_ALLOCA /* DB resolve symbols */ #undef DB_RESOLVE_SYMBOLS /* Debug sys alloc */ #undef DEBUG_SYS_ALLOC /* Need dlsym uscore */ #undef DLSYM_NEED_USCORE /* Have doug lea malloc */ #undef DOUG_LEA_MALLOC /* Env undeclared */ #undef ENVIRON_UNDECLARED /* The first pty letter */ #undef FIRST_PTY_LETTER /* Have Fullname Terminator */ #undef FULL_NAME_TERMINATOR /* Define to 1 if you have `alloca', as a function or macro. */ #undef HAVE_ALLOCA /* Define to 1 if you have and it should be used (not on Ultrix). */ #undef HAVE_ALLOCA_H /* Define to 1 if you have the header file. */ #undef HAVE_ARGZ_H /* Have crypt */ #undef HAVE_CRYPT /* Have dev/ptmx */ #undef HAVE_DEV_PTMX /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_DIRENT_H /* Define to 1 if you have the `dladdr' function. */ #undef HAVE_DLADDR /* Define to 1 if you have the `dlerror' function. */ #undef HAVE_DLERROR /* Have dlfcn header */ #undef HAVE_DLFCN_H /* Have dlopen */ #undef HAVE_DLOPEN /* Have dl header */ #undef HAVE_DL_H /* Define to 1 if you don't have `vprintf' but do have `_doprnt.' */ #undef HAVE_DOPRNT /* Have dynamic Loading */ #undef HAVE_DYNAMIC_LOADING /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H /* Define to 1 if you have the `getcwd' function. */ #undef HAVE_GETCWD /* Define to 1 if you have the `gethostname' function. */ #undef HAVE_GETHOSTNAME /* Define to 1 if you have the `getpagesize' function. */ #undef HAVE_GETPAGESIZE /* Define to 1 if you have the `gettimeofday' function. */ #undef HAVE_GETTIMEOFDAY /* Have libgmp */ #undef HAVE_GMP /* Have randinit in libgmp */ #undef HAVE_GMP_RANDINIT /* Define to 1 if you have the `grantpt' function. */ #undef HAVE_GRANTPT /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H /* Define to 1 if you have the `dl' library (-ldl). */ #undef HAVE_LIBDL /* Define to 1 if you have the header file. */ #undef HAVE_LIBINTL_H /* Define to 1 if you have the `nsl' library (-lnsl). */ #undef HAVE_LIBNSL /* Have libreadline */ #undef HAVE_LIBREADLINE /* Define to 1 if you have the `socket' library (-lsocket). */ #undef HAVE_LIBSOCKET /* Define to 1 if you have the header file. */ #undef HAVE_LIMITS_H /* Define to 1 if you have the header file. */ #undef HAVE_LOCALE_H /* Define to 1 if you have the `lrand48' function. */ #undef HAVE_LRAND48 /* Define to 1 if you have the header file. */ #undef HAVE_MALLOC_H /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H /* Define to 1 if you have a working `mmap' system call. */ #undef HAVE_MMAP /* Define to 1 if you have the `munmap' function. */ #undef HAVE_MUNMAP /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_NDIR_H /* Define to 1 if you have the header file. */ #undef HAVE_NL_TYPES_H /* Define to 1 if you have the `psignal' function. */ #undef HAVE_PSIGNAL /* Have ptys */ #undef HAVE_PTYS /* Define to 1 if you have the `putenv' function. */ #undef HAVE_PUTENV /* Define to 1 if you have the `realpath' function. */ #undef HAVE_REALPATH /* Define to 1 if you have the `select' function. */ #undef HAVE_SELECT /* Define to 1 if you have the `setenv' function. */ #undef HAVE_SETENV /* Define to 1 if you have the `setitimer' function. */ #undef HAVE_SETITIMER /* Define to 1 if you have the `setlocale' function. */ #undef HAVE_SETLOCALE /* Have shlload */ #undef HAVE_SHL_LOAD /* Define to 1 if you have the header file. */ #undef HAVE_SIGINFO_H /* Define to 1 if you have the `siginterrupt' function. */ #undef HAVE_SIGINTERRUPT /* Define to 1 if you have the `snprintf' function. */ #undef HAVE_SNPRINTF /* Define to 1 if you have the `socket' function. */ #undef HAVE_SOCKET /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the `stpcpy' function. */ #undef HAVE_STPCPY /* Define to 1 if you have the `strcasecmp' function. */ #undef HAVE_STRCASECMP /* Define to 1 if you have the `strchr' function. */ #undef HAVE_STRCHR /* Define to 1 if you have the `strcspn' function. */ #undef HAVE_STRCSPN /* Define to 1 if you have the `strdup' function. */ #undef HAVE_STRDUP /* Define to 1 if you have the `strerror' function. */ #undef HAVE_STRERROR /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H /* Define to 1 if you have the `strncasecmp' function. */ #undef HAVE_STRNCASECMP /* Define to 1 if you have the header file. */ #undef HAVE_STROPTS_H /* Define to 1 if you have the `strsignal' function. */ #undef HAVE_STRSIGNAL /* Define to 1 if you have the `strstr' function. */ #undef HAVE_STRSTR /* Define to 1 if you have the `strtol' function. */ #undef HAVE_STRTOL /* Define to 1 if you have the `strtoll' function. */ #undef HAVE_STRTOLL /* Define to 1 if you have the `strtoq' function. */ #undef HAVE_STRTOQ /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_DIR_H /* Have sysdl header */ #undef HAVE_SYS_DL_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_IOCTL_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_NDIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_PARAM_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_UTSNAME_H /* Define to 1 if you have that is POSIX.1 compatible. */ #undef HAVE_SYS_WAIT_H /* Define to 1 if you have the header file. */ #undef HAVE_TERMIOS_H /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Define to 1 if you have the `vprintf' function. */ #undef HAVE_VPRINTF /* Define to 1 if you have the `__argz_count' function. */ #undef HAVE___ARGZ_COUNT /* Define to 1 if you have the `__argz_next' function. */ #undef HAVE___ARGZ_NEXT /* Define to 1 if you have the `__argz_stringify' function. */ #undef HAVE___ARGZ_STRINGIFY /* Have libc gettext */ #undef LIBC_GETTEXT /* Have libc malloc */ #undef LIBC_MALLOC /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Define as the return type of signal handlers (`int' or `void'). */ #undef RETSIGTYPE /* The size of `long', as computed by sizeof. */ #undef SIZEOF_LONG /* The size of `long long', as computed by sizeof. */ #undef SIZEOF_LONG_LONG /* The size of `void *', as computed by sizeof. */ #undef SIZEOF_VOID_P /* Have stack direction */ #undef STACK_DIRECTION /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* Define to 1 if you can safely include both and . */ #undef TIME_WITH_SYS_TIME /* Have continuations */ #undef WITH_CONTINUATIONS /* Define to empty if `const' does not conform to ANSI C. */ #undef const /* Define to `__inline__' or `__inline' if that's what the C compiler calls it, or to nothing if 'inline' is not supported under any name. */ #ifndef __cplusplus #undef inline #endif /* Define to `long int' if does not define. */ #undef off_t /* Define to `int' if does not define. */ #undef pid_t /* Have long long */ #undef rep_HAVE_LONG_LONG /* Having Unix */ #undef rep_HAVE_UNIX /* Rep interface */ #undef rep_INTERFACE /* Have malloc alignment */ #undef rep_MALLOC_ALIGNMENT /* Have ptr sized int */ #undef rep_PTR_SIZED_INT /* Have ptr sized int conv */ #undef rep_PTR_SIZED_INT_CONV /* Have ptr sized int sizeof */ #undef rep_PTR_SIZED_INT_SIZEOF /* Have ptr sized suffix */ #undef rep_PTR_SIZED_INT_SUFFIX /* Rep version */ #undef rep_VERSION /* Define to `unsigned int' if does not define. */ #undef size_t librep-0.90.2/build-info0000755000175200017520000000170411245011152014035 0ustar chrischris#!/bin/sh # build-info -- Generate header file containing build details # $Id$ host_type="$1" rep_version="$2" repdir="$3" replispdir="$4" repexecdir="$5" repdocfile="$6" repcommonexecdir="$7" [ -n "$HOSTNAME" ] \ || HOSTNAME=`hostname` \ || HOSTNAME=unknown sys_name="$HOSTNAME" user_name="$LOGNAME" build_date="`date +'%a %b %e %Y'`" build_time="`date +'%T %Z'`" cat </dev/null; then echo "Running autoheader" autoheader || exit 1 fi if grep "AM_PROG_LIBTOOL" configure.in >/dev/null; then echo "Running libtoolize" lver=$(libtool --version | grep 1.5) if [ "x${lver}" != "x" ]; then libtoolize --force --copy || exit 1 else libtoolize --force --copy --install || exit 1 fi fi echo "Running aclocal $ACLOCAL_FLAGS" aclocal -I m4 $ACLOCAL_FLAGS || exit 1 echo "Running autoconf $AUTOCONF_FLAGS" autoconf $AUTOCONF_FLAGS || exit 1 fi ./configure "$@" librep-0.90.2/TREE0000644000175200017520000000203111245011152012533 0ustar chrischris-*- indented-text -*- Proposed module hierarchy ========================= rep lang interpreter debug symbols math profiler backquote debugger vm bytecodes disassembler interpreter compiler io streams files processes file-handlers readline timers db gdbm sdbm data datums tables ring queues records symbol-table threads regexp system module-system structures ... i18n gettext file-handlers scheme mail www gui gtk [gdk] gtk libglade gdk-pixbuf gnome lib ui canvas canvas-pixbuf libglade corba orbit sawfish wm ui Notes ===== - Everything under `rep.' is reserved for rep distribution - opening `rep' gets the old default environment (less thread support) - use aliases (w/ symlinks in fs) to preserve compatibility where possible librep-0.90.2/TODO0000644000175200017520000001676411245011152012563 0ustar chrischris[ This is -*-Indented-Text-*- ] TODO list for librep ******************** Bugs are marked !, things that should be done soon are marked +, and more long-term ideas are marked - Outstanding bugs ================ ! uses setlocale("LC_NUMERIC", "C") to make floating point I/O work, need to reimplement this locally [ this is only done temporarily now, but rep-gtk still has some instances that can't be removed until librep 0.14 I guess.. ] ! modules with `(set-binds)' config shouldn't inline constants? ! #!key params can't be inlined by the compiler ! non-top-level compiled defvar's aren't quite right ! scheme define/lambda doesn't splice begin forms ! the scheme module fails some of the guile test.scm cases ! the first level lookup of foo#bar isn't cached ! interfaces aren't re-parsed when modules are reloaded ! environment of macro expanders is not consistent interpreted code closes macros in the usual lexical environment, the compiler closes them in the *root-strcucture* since the lexical environment of the compiled file doesn't exist Xerox scheme closes all macros in the `initial environment', this would provide consistency, but would break existing code ! macro memoization loses e.g. if same (eq) expression is expanded in different structures OTOH, there is little or no chance of this ever happening ! doesn't handle NaN or Inf in floats properly (at all) ! Putting a breakpoint in a .jaderc file doesn't work correctly; the debugger is entered, but the commands don't work ! if load can't find the file, its error message is confusing (especially if the named file does exist, but no suffixed file exists) ! non-fixnum numbers can't be dumped / dump totally broken re: modules ! it's legal to do (set foo 42) where the contents of foo has a lexical binding this breaks: (let ((var 'loop)) (let loop ((foo t)) (set var print) (loop foo))) + document in manual: current-utime, new read syntaxes + deprecated: * 0xNN and 0NN integer syntaxes [0.13+] * &optional and &rest (replaced by #!optional and #!rest) [0.13+] General programming tasks: ========================== + allow the rng to be seeded with a given value + comparison of datums currently compares type id and contents should be defined by programmer, e.g.: (define-datum-comparer ID FUN) by analogy with define-datum-discloser (but do callers of rep_value_cmp () assume that it may GC?) + avoid spurious init-bind and unbind instructions (generated when lexical bindings aren't heap allocated) + rename backquote* as quasiquote* -- helps scheme, doesn't affect rep + add restricted load to gaol? (same directory only?) + %make-structure shouldn't map names to structures itself it's done this way to allow mutually recursive structures (debatable itself) but really %make-structure should just create the thing (with an optional name for printing) - allow ML-like functors (parameterized modules) the basic support is there. Can do: (define (my-functor x) (structure (export foo) (open rep) (define (foo y) (+ x y)))) but there's currently no clean way to import the first-class structure (without resorting to open-structures) I think the way is to require the functor to implement a named interface which is specified in the module signature: (define-structure foo (open rep (functor (my-functor x) some-interface)) ... `(my-functor x) would get evaluated in the environment containing the define-structure form? Or in the environment created up to that point? The named-interface trick could also be useful for importing normal modules (to avoid having to load them at compile time) [ I have a first-stab at this, needs compiler support.. ] - add a facility for dumping a set of structures, for later reloading - move the gtk-independent parts of the rep-gtk glue generator and support code to librep [ I've rewritten the glue-code generator in an oo style so that it can be easily extended. Need to rewrite the runtime support. Will do this in time for GTK 2.0 ] - add defadvice (port from elisp? other implementations?) - Compiler could annotate output files with their dependences - I/O shouldn't block all threads wait_for_input () already groks threads, so I think the only problem is the use of stdio/fd functions. How does stdio handle streams that have been set non-blocking? Maybe reimplement basic stdio? (there is now support for waking threads via polling) [ I have a patch that adds support for threads to be woken when one of a set of fds is available for writing and reading. It also has a blocking I/O function that suspends the thread while it blocks.. ] - add regression tests [ partially done, there is a test framework now, but only a couple of modules define tests ] - scheme compilation is worse than rep compilation should be able to make this a lot better, maybe not as good as rep code (since the vm primitives are designed for that), but still a lot better.. [ it's better now, but still room for improvement ] - the gc sucks is it possible to add a good (generational?) gc? could sweeping be sped up by prefetching cache lines? do lazy sweeping of block-allocated objects? (problem with cons mark bit?) do mostly non-recursive marking? (mark stack) [ tried this -- marginally slower than current method ] - remove special forms (replacing them with macros) where both possible and desirable The current (July 2000) list of special forms is: cond %define defvar lambda progn quote setq - most subrs can't be called tail recursively (apply is special-cased) - add a hygienic macro facility this may be overkill? capture of introduced bindings can be avoided using gensyms, capture of introduced free variables could be avoided by introducing a way of tagging variable references with the structure they need to be dereferenced in. [ I have an experimental low-level hygienic macro implementation, but it's a long way from being useful ] - do JIT compilation of bytecode where profitable there's now GNU lightning, a VCODE-like system, using C macros to do portable runtime code generation Only do this for _heavily_ used bytecode subrs. Measure this by adding an extra vector slot, and counting the number of vm instructions executed (and dividing by the length of the code-string?) Another option is to generate direct-threaded code from the bytecode (and cache it). I have an attempt at this but it needs either (1) an extra pass to detect labels, or (2) to maintain a strict mapping between bytecode addresses and direct-code addresses There's an interesting paper about automatically generating meta instructions to suit individual instruction sequences, PLDI 98 or something (check citeseer for it). Applied with reasonable success to Caml interpreter - Optimize compilation of case statements 1. handle constant keys 2. optimize the search (binary search if all clauses have same type and are orderable?) - Add more backends for accessing remote files Make remote-rcp work properly, and add others (ssh, http, ..?) - Make the compiler optimise its output now the lisp is mostly lexically scoped, there should be much more potential for aggressive optimisation Manual tasks: ============= + Document the error-mode and interrupt-mode variables + Document the internals (i.e. the C interface) librep-0.90.2/THANKS0000644000175200017520000000073711245011152012777 0ustar chrischris-*- indented-text -*- THANKS ****** * Henry Spencer for his excellent regexp matcher * Ozan Yigit for SDBM * Rick Sladkey for the Emacs backquote implementation * Jamie Zawinski for the Emacs peephole optimiser patterns * Yukihiro Nakai for the first rep-gettext implementation * Mikolaj J. Habryn for being the first 64-bit guinea-pig, and for building Debian packages * Aron Griffis for porting to Tru64 * numerous other people for bug-reports and patches librep-0.90.2/README0000644000175200017520000001051211245011152012734 0ustar chrischris[ this is -*-Text-*- ] This is librep, a Lisp system for UNIX. It contains a Lisp interpreter, byte-code compiler and virtual machine. Applications may use the Lisp interpreter as an extension language, or it may be used for stand-alone scripts. The Lisp dialect was originally inspired by Emacs Lisp, but with the worst features removed. It also borrows many ideas from Scheme. It is known to compile on at least Solaris/sparc and Linux/ix86; it is released under the terms of the GNU GPL, copyright John Harper For more details see: http://librep.sourceforge.net/ Browse the SVN tree at: http://svn.gnome.org/viewvc/librep/ To compile this you'll need GNU make, the GNU MP library (see below) and GNU dbm installed. Basically, just do: $ ./configure $ make $ make install (if building from the SVN tree use ./autogen.sh instead of ./configure) Notes ===== 64-bit systems -------------- If you're on a 64-bit architecture you may want to look at the `--with-value-type' configure option. This is an implicitly signed integer type (i.e. `int', `long', etc) that is wide enough to store an arbitrary pointer without losing any bits. It should be detected automatically by the configure script, but if not there are two most likely required settings: 1. For a machine with 64-bit pointers and longs, but only 32-bit ints the following could be done: $ ./configure --with-value-type=long 2. For a machine with both int and long 32-bits, but with 64-bit pointers and long long ints, then: $ ./configure --with-value-type="long long" If this option is set incorrectly (i.e. to an integer type that is too small) a run-time assertion will be triggered when the interpreter initialises itself. Also, if this option is set to anything but int, long, or long long, then the src/rep_config.h file will need to be edited for the constant suffix and printf conversion of the chosen type. libgmp ------ rep uses GNU MP for it's bignum/rational implementation; you can find it at any GNU mirror. GMP versions 2 and 3 are both known to work (though version 3 is recommended) shared libraries ---------------- rep includes plugins providing language bindings for several libraries. Because these plugins are implemented as shared objects that are loaded at runtime, the libraries they wrap must also be shared libraries on most systems. This means that the installed libgdm must be shared, and if compiling with readline support, so must libreadline cut-down version ---------------- The configure script accepts the following options to build restricted versions of librep. The resulting library is binary-compatible with the normal version. --without-gmp Don't use GNU MP for bignums. Use `long long' as biggest integer type (if available, else just `long'). Also, there is no support for exact rationals, thus (/ 1 2) => 0.5 not 1/2 --disable-continuations Don't include support for call/cc or multi-threading. This may be useful for machines with non-linear stacks (old crays?) obscure configure options ------------------------- --enable-dballoc Trace all memory allocations. Not for general use --disable-dbsyms When printing C stack backtraces, don't try to output symbolic addresses --enable-gprof Compile with flags enabling profiling. Also needs --enable-static to be given. Use the `srep' target in the src directory to build a statically linked interpreter (since gprof doesn't profile shared libraries) --with-malloc-alignment=BYTES The minimum alignment of memory returned from malloc (). Defaults to the machine's word size. It's unlikely this will ever need to be specified explicitly --with-stack-direction=DIRECTION Direction of stack growth. -1 for downwards (grows from higher addresses to lower addresses), +1 for upwards. If not given, will try to infer this automatically (though it has been known to fail) --enable-full-name-terminator=CHARACTER If the GECOS fields in your password file contain extra information after the user's full name, this option allows the separator character to be given, letting rep's user-full-name function return the correct information. E.g. some systems have GECOS as a comma-separated list of values, the first of which is the full name. For this case: --enable-full-name-terminator=, librep-0.90.2/Makefile.in0000644000175200017520000001134611245011152014127 0ustar chrischris# Makefile.in for Jade version 4 # Copyright (C) 1998 John Harper # $Id: Makefile.in,v 1.33 2003/09/04 05:57:43 jsh Exp $ # # This file is part of Jade. # # Jade is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # Jade is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Jade; see the file COPYING. If not, write to # the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ETAGS:= etags top_builddir=. VPATH=@srcdir@ ALL_SUBDIRS = intl src lisp man INSTALL_SUBDIRS = src lisp man all : build.h rules.mk doc-strings for dir in $(ALL_SUBDIRS); do \ [ -d $$dir ] && ( cd $$dir && $(MAKE) $@ ) || exit 1; \ done build.h : build-info config.status $(SHELL) $< $(host_type) $(version) \ '$(repdir)' '$(replispdir)' '$(repexecdir)' \ '$(repdocfile)' '$(repcommonexecdir)' >$@ rules.mk : rules.mk.sh config.status $(SHELL) $< '$(repdir)' '$(repcommonexecdir)' '$(repdocfile)' >$@ check : for dir in $(ALL_SUBDIRS); do \ [ -d $$dir ] && ( cd $$dir && $(MAKE) $@ ) || exit 1; \ done install : all installdirs for dir in $(INSTALL_SUBDIRS); do \ ( cd $$dir && $(MAKE) $@ ) || exit 1; \ done $(INSTALL_DATA) doc-strings $(DESTDIR)$(repexecdir) $(INSTALL_SCRIPT) emulate-gnu-tar $(DESTDIR)$(repexecdir) $(INSTALL_SCRIPT) libtool $(DESTDIR)$(repcommonexecdir) $(INSTALL_DATA) rules.mk $(DESTDIR)$(repcommonexecdir) $(INSTALL_SCRIPT) install-aliases $(DESTDIR)$(repcommonexecdir) $(INSTALL_DATA) rep-debugger.el $(DESTDIR)$(emacssitelispdir) mkdir -p $(DESTDIR)$(libdir)/pkgconfig $(INSTALL_DATA) $(top_srcdir)/librep.pc $(DESTDIR)$(libdir)/pkgconfig/ installdirs : mkinstalldirs $(SHELL) $< $(DESTDIR)$(repdir)/$(version) \ $(DESTDIR)$(bindir) $(DESTDIR)$(aclocaldir) \ $(DESTDIR)$(repcommonexecdir) $(DESTDIR)$(repexecdir) \ $(DESTDIR)$(emacssitelispdir) uninstall : -for dir in $(INSTALL_SUBDIRS); do \ ( cd $$dir && $(MAKE) $@ ) || exit 1; \ done rm -rf $(DESTDIR)$(repdir)/$(version) rm -rf $(DESTDIR)$(repexecdir) rm -f $(DESTDIR)$(repcommonexecdir)/rules.mk rm -f $(DESTDIR)$(repcommonexecdir)/install-aliases rm -f $(DESTDIR)$(repcommonexecdir)/libtool rm -f $(DESTDIR)$(emacssitelispdir)/rep-debugger.el rm -f $(DESTDIR)$(libdir)/pkgconfig/librep.pc doc-strings : src/repdoc src/repdoc doc-strings `find $(top_srcdir) -name '*.c' -print` src/repdoc : ( cd src && $(MAKE) repdoc ) NEWS : man/news.texi ( cd man && $(MAKE) ../NEWS ) clean : -for dir in $(ALL_SUBDIRS); do \ [ -d $$dir ] && ( cd $$dir && $(MAKE) $@ ) || exit 1; \ done rm -f *~ NEWS doc-strings TAGS build.h distclean : -for dir in $(ALL_SUBDIRS); do \ [ -d $$dir ] && ( cd $$dir && $(MAKE) $@ ) || exit 1; \ done rm -f config.cache config.h config.log config.status Makefile libtool rm -f *~ NEWS doc-strings TAGS build.h rules.mk librep.spec rm -f configure.orig librep-*.ebuild librep.pc realclean : distclean tags: TAGS # # Use separate and explicit expressions rather than "(def.*" to avoid # grabbing: # ./lisp/rep.jl:54: (default-error-handler (car error-data) [...] # ./lisp/define.jl:146: (define-scan-internals body)) # TAGS : -rm -f $@ set -e; \ c_files=`find $(top_srcdir) -name '*.[hc]' -print`; \ rep_files=`find $(top_srcdir) -name '*.jl' -print`; \ ${ETAGS} --language=c $$c_files \ --language=none \ --regex='/[ \t]*DEFSTRING[ \t]*([ \t]*\([^ \t,]+\)/\1/' \ --regex='/[ \t]*DEFSYM[ \t]*([ \t]*\([^ \t,]+\)/Q\1/' \ --regex='/[ \t]*DEFSYM[ \t]*([ \t]*[^ \t,]+[ \t,]+"\([^"]+\)/\1/' \ --regex='/[ \t]*DEFUN\(_INT\)?[ \t]*([ \t]*"\([^"]+\)/\2/' \ $$c_files \ --language=lisp $$rep_files \ --language=none \ --regex='/[ \t]+([ \t]*defun[ \t]+(?[ \t]*\([^ \t)]+\)/\1/' \ --regex='/[ \t]+([ \t]*define[ \t]+(?[ \t]*\([^ \t)]+\)/\1/' \ --regex='/[ \t]+([ \t]*defmacro[ \t]+(?[ \t]*\([^ \t)]+\)/\1/' \ --regex='/[ \t]+([ \t]*defsubst[ \t]+(?[ \t]*\([^ \t)]+\)/\1/' \ --regex='/[ \t]+([ \t]*defconst[ \t]+(?[ \t]*\([^ \t)]+\)/\1/' \ --regex='/[ \t]+([ \t]*defvar[ \t]+(?[ \t]*\([^ \t)]+\)/\1/' \ --regex="/[ \t]+([ \t]*define-file-handler[ \t]+'\([^ \t)]+\)/\1/" \ --regex="/[ \t]+([ \t]*define-datum-printer[ \t]+'\([^ \t)]+\)/\1/"\ $$rep_files .PHONY: install uninstall nobak clean realclean TAGS tags distclean librep-0.90.2/Makedefs.in0000644000175200017520000000554311245011152014133 0ustar chrischris# Makedefs.in -- input for the common Makefile definitions # Copyright (C) 1998 John Harper # $Id: Makedefs.in,v 1.35 2003/09/04 05:57:43 jsh Exp $ # # This file is part of Jade. # # Jade is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # Jade is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Jade; see the file COPYING. If not, write to # the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. version=@version@ libversion=@libversion@ SHELL=/bin/sh top_srcdir=@top_srcdir@ srcdir=@srcdir@ prefix=@prefix@ exec_prefix=@exec_prefix@ datarootdir=@datarootdir@ datadir=@datadir@ bindir=@bindir@ includedir=@includedir@ infodir=@infodir@ libdir=@libdir@ libexecdir=@libexecdir@ localstatedir=@localstatedir@ mandir=@mandir@ sharedstatedir=@sharedstatedir@ aclocaldir=@aclocaldir@ emacssitelispdir=@emacssitelispdir@ host_type=@host@ repdir=@repdir@ replispdir=@replispdir@ repexecdir=@repexecdir@ repcommonexecdir=@repcommonexecdir@ repdocfile=@repdocfile@ CC=@CC@ LIBTOOL=@LIBTOOL@ MAKEDEP=@MAKEDEP@ CPPFLAGS=-DHAVE_CONFIG_H -I. -I$(top_srcdir)/src -I.. @CPPFLAGS@ CFLAGS=@CFLAGS@ LDFLAGS=@LDFLAGS@ LIBS=@LIBS@ LIBOBJS=@LIBOBJS@ EXTRA_LIBOBJS=@EXTRA_LIBOBJS@ READLINE_LIBS=@READLINE_LIBS@ GMP_LIBS=@GMP_LIBS@ GDBM_LIBS=@GDBM_LIBS@ LIBFFI_LIBS=@LIBFFI_LIBS@ ALLOCA=@ALLOCA@ DESTDIR= INSTALL=@INSTALL@ INSTALL_DATA=@INSTALL_DATA@ INSTALL_PROGRAM=@INSTALL_PROGRAM@ INSTALL_SCRIPT=@INSTALL_SCRIPT@ MAKEINFO = makeinfo --no-split MAKEINFOFLAGS = TEXI2DVI = texi2dvi TEXI2PDF = texi2pdf DVIPS = dvips HAVE_X11=@HAVE_X11@ HAVE_UNIX=@HAVE_UNIX@ .PHONY: clean realclean install rep_prog = $(top_builddir)/src/rep COMPILE_ENV = REPLISPDIR=$(top_builddir)/lisp \ REP_DL_LOAD_PATH=$(top_builddir)/src/.libexec \ REPDOCFILE=$(top_builddir)/doc-strings include $(top_srcdir)/rules.mk rep_LIBTOOL=@LIBTOOL@ # Rule for ``normal'' C objects %.o : %.c $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< # Rule for ``normal'' executables % : %.c $(CC) $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) -o $@ $< $(LIBS) # Rule for libtool controlled C objects %.lo : %.c $(LIBTOOL) --mode=compile --tag=CC $(CC) -c $(CPPFLAGS) $(CFLAGS) $< # Rule for dlopen'able C objects %.la : %.c $(LIBTOOL) --mode=compile --tag=CC $(CC) -c $(CPPFLAGS) $(CFLAGS) $< $(rep_DL_LD) $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) -o $@ $*.lo # Build dependancy files from C source files. .%.d : %.c $(SHELL) -ec '$(MAKEDEP) $(CPPFLAGS) $< \ | sed '\''s/$*\.o/& $*.lo .$*\.d/g'\'' > $@' librep-0.90.2/MAINTAINERS0000644000175200017520000000016311245011152013552 0ustar chrischrisJohn Harper E-mail: jsh@unfactored.org Userid: jsh Christopher Bratusek E-mail: zanghar@freenet.de Userid: chrisb librep-0.90.2/INSTALL0000644000175200017520000001705211245011152013113 0ustar chrischrisBasic Installation ================== These are generic installation instructions. The `configure' shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses those values to create a `Makefile' in each directory of the package. It may also create one or more `.h' files containing system-dependent definitions. Finally, it creates a shell script `config.status' that you can run in the future to recreate the current configuration, a file `config.cache' that saves the results of its tests to speed up reconfiguring, and a file `config.log' containing compiler output (useful mainly for debugging `configure'). If you need to do unusual things to compile the package, please try to figure out how `configure' could check whether to do them, and mail diffs or instructions to the address given in the `README' so they can be considered for the next release. If at some point `config.cache' contains results you don't want to keep, you may remove or edit it. The file `configure.in' is used to create `configure' by a program called `autoconf'. You only need `configure.in' if you want to change it or regenerate `configure' using a newer version of `autoconf'. The simplest way to compile this package is: 1. `cd' to the directory containing the package's source code and type `./configure' to configure the package for your system. If you're using `csh' on an old version of System V, you might need to type `sh ./configure' instead to prevent `csh' from trying to execute `configure' itself. Running `configure' takes a while. While running, it prints some messages telling which features it is checking for. 2. Type `make' to compile the package. 3. Optionally, type `make check' to run any self-tests that come with the package. 4. Type `make install' to install the programs and any data files and documentation. 5. You can remove the program binaries and object files from the source code directory by typing `make clean'. To also remove the files that `configure' created (so you can compile the package for a different kind of computer), type `make distclean'. There is also a `make maintainer-clean' target, but that is intended mainly for the package's developers. If you use it, you may have to get all sorts of other programs in order to regenerate files that came with the distribution. Compilers and Options ===================== Some systems require unusual options for compilation or linking that the `configure' script does not know about. You can give `configure' initial values for variables by setting them in the environment. Using a Bourne-compatible shell, you can do that on the command line like this: CC=c89 CFLAGS=-O2 LIBS=-lposix ./configure Or on systems that have the `env' program, you can do it like this: env CPPFLAGS=-I/usr/local/include LDFLAGS=-s ./configure Compiling For Multiple Architectures ==================================== You can compile the package for more than one kind of computer at the same time, by placing the object files for each architecture in their own directory. To do this, you must use a version of `make' that supports the `VPATH' variable, such as GNU `make'. `cd' to the directory where you want the object files and executables to go and run the `configure' script. `configure' automatically checks for the source code in the directory that `configure' is in and in `..'. If you have to use a `make' that does not supports the `VPATH' variable, you have to compile the package for one architecture at a time in the source code directory. After you have installed the package for one architecture, use `make distclean' before reconfiguring for another architecture. Installation Names ================== By default, `make install' will install the package's files in `/usr/local/bin', `/usr/local/man', etc. You can specify an installation prefix other than `/usr/local' by giving `configure' the option `--prefix=PATH'. You can specify separate installation prefixes for architecture-specific files and architecture-independent files. If you give `configure' the option `--exec-prefix=PATH', the package will use PATH as the prefix for installing programs and libraries. Documentation and other data files will still use the regular prefix. In addition, if you use an unusual directory layout you can give options like `--bindir=PATH' to specify different values for particular kinds of files. Run `configure --help' for a list of the directories you can set and what kinds of files go in them. If the package supports it, you can cause programs to be installed with an extra prefix or suffix on their names by giving `configure' the option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. Optional Features ================= Some packages pay attention to `--enable-FEATURE' options to `configure', where FEATURE indicates an optional part of the package. They may also pay attention to `--with-PACKAGE' options, where PACKAGE is something like `gnu-as' or `x' (for the X Window System). The `README' should mention any `--enable-' and `--with-' options that the package recognizes. For packages that use the X Window System, `configure' can usually find the X include and library files automatically, but if it doesn't, you can use the `configure' options `--x-includes=DIR' and `--x-libraries=DIR' to specify their locations. Specifying the System Type ========================== There may be some features `configure' can not figure out automatically, but needs to determine by the type of host the package will run on. Usually `configure' can figure that out, but if it prints a message saying it can not guess the host type, give it the `--host=TYPE' option. TYPE can either be a short name for the system type, such as `sun4', or a canonical name with three fields: CPU-COMPANY-SYSTEM See the file `config.sub' for the possible values of each field. If `config.sub' isn't included in this package, then this package doesn't need to know the host type. If you are building compiler tools for cross-compiling, you can also use the `--target=TYPE' option to select the type of system they will produce code for and the `--build=TYPE' option to select the type of system on which you are compiling the package. Sharing Defaults ================ If you want to set default values for `configure' scripts to share, you can create a site shell script called `config.site' that gives default values for variables like `CC', `cache_file', and `prefix'. `configure' looks for `PREFIX/share/config.site' if it exists, then `PREFIX/etc/config.site' if it exists. Or, you can set the `CONFIG_SITE' environment variable to the location of the site script. A warning: not all `configure' scripts look for a site script. Operation Controls ================== `configure' recognizes the following options to control how it operates. `--cache-file=FILE' Use and save the results of the tests in FILE instead of `./config.cache'. Set FILE to `/dev/null' to disable caching, for debugging `configure'. `--help' Print a summary of the options to `configure', and exit. `--quiet' `--silent' `-q' Do not print messages saying which checks are being made. `--srcdir=DIR' Look for the package's source code in directory DIR. Usually `configure' can determine that directory automatically. `--version' Print the version of Autoconf used to generate the `configure' script, and exit. `configure' also accepts some other, not widely useful, options. librep-0.90.2/HACKING0000644000175200017520000000033011245011152013040 0ustar chrischris Please send all patches to either the BugZilla http://bugzilla.gnome.org or the mailing list: . When possible, please make patches in unified diff format (i.e. 'iff -u' or use 'svn diff'). librep-0.90.2/ChangeLog0000644000175200017520000004770311245011152013642 0ustar chrischris2009-08-25 Christopher Bratusek * configure.in: post-release version bump to 0.90.2 * src/lisp.c: fixed an major defunct in prin1 + utf8 [Timo Korvola] * src/streams.c: wrong description of formats %s and %S 2009-08-22 Christopher Bratusek * src/rep.c: properly terminate rep interpreter [Jürgen Hötzel] * src/readline.c: save/load readline history in interactive mode [Jürgen Hötzel] * src/lisp.c * src/uft8.c: No C++ style comments in C code 2009-07-25 Christopher Bratusek * librep.pc.in: add -L$prefix to libs 2009-07-24 Christopher Bratusek * emulate-gnu-tar * lisp/rep/io/file-handlers/tar.jl: added support for tar.xz and tar.lzma * lisp/rep/io/file-handlers/tar.jl: improved regex for parsing tar output [Alexey I. Froloff] * src/ffi.c: improved ffi-binding [Alexey I. Froloff] * src/librep.sym: added some missing entries [Alexey I. Froloff] 2009-07-15 Christopher Bratusek * configure.in * Makedefs.in * src/Makefile.in: update checks for libffi 2009-07-11 Christopher Bratusek * src/unix_processes.c: fix a definition 2009-07-02 Christopher Bratusek * configure.in: obligatory post-release version bump * .git: created 0.90.0 tag and pushed 0.17.4 tag 2009-06-30 Christopher Bratusek * man/lang.texi: updated for rep.util.utf8 [Teika Kazura] * src/lispcmds.c: fixed a typo [Teika Kazura] * src/utf8.c: improved copyright notice, removed unused macros [Teika Kazura] 2009-06-19 Christopher Bratusek * src/unix_processes * src/sdbm.c * src/sdbm_pair.c: removed 3 unused variables 2009-05-30 Christopher Bratusek * src/utf8.c: added UTF-8 Support! [Wang Diancheng] 2009-05-06 Christopher Bratusek * Makefile.in: remove tar target [Ritz] * configure.in: 0.17.4 released, bump to 0.90.0 * lisp/scheme/ * lisp/scheme.jl * lisp/unscheme/ * lisp/unscheme.jl * lisp/rep/vm/compiler/scheme.jl * lisp/rep/vm/compiler/unscheme.jl: removed * lisp/rep/vm/compiler.jl * lisp/rep/user.jl * lisp/Makefile: updated 2009-05-05 Christopher Bratusek * man/lang.tex * man/librep.texi * man/news.texi: 'Numbers' section is revised, mainly on machine dependence. Minor improvements [Teika] * configure.in: small configures ending message update (from rep-gtk/sawfish) 2009-03-24 Christopher Bratusek * Makedefs.in: first define datarootdir then stuff that refers to it * man/news.texi: updated 2009-03-06 Christopher Bratusek * configure.in * Makedefs.in * intl/Makefile.in: don't ignore datarootdir setting 2009-03-05 Christopher Bratusek * configure.in: 0.17.3 released, bump to 0.17.4 2009-02-18 Christopher Bratusek * lisp/rep/io/file-handlers/tar.jl: BSD-Tar is not supported by librep, give users a usefull warning message [Mark Diekhans] 2009-02-03 Christopher Bratusek * install-sh: added for libtool < 2.2 * librep.spec.in: don't try to package librep.a and %{_infodir}/dir * autogen.sh: re-enable the use of autoheader * configure.in: fix templates (for autoheader) 2009-02-02 Christopher Bratusek * librep.pc.in: remove bogus entries * autogen.sh: don't use bash specific syntax [Mark Diekhans] * configure.in: improved ending message 2009-02-01 Christopher Bratusek * MAINTAINERS: updated my mail address * autogen.sh: work around an issue * librep.spec.in: - don't try to package non-existent rep.m4 - make sure emacs_lispdir is defined 2009-01-18 Christopher Bratusek * librep.spec.in: - update BuildRequires - merge changes from ritz's spec-file 2009-01-02 Christopher Bratusek * librep.spec.in: source-archive is .tar.bz2 2009-01-01 Christopher Bratusek * autogen.sh: reworked * m4: add m4 directory to shut up libtool 1.x * configure.in: begin rework * install-sh: don't ship this file 2008-12-30 Christopher Bratusek * librep.ebuild.in: don't leak copyright info and update keywords 2008-12-24 Christopher Bratusek * autogen.sh: fix libtool command for libtool >2.2 2008-12-20 Christopher Bratusek * configure.in * librep.ebuild.in: Added ebuild [Harald van Dijk] * librep.pc.in: Complete Libs: Section * Makefile.in: upon distclean also remove the ebuild and configure 2008-12-18 Christopher Bratusek * rep.m4 * librep.pc.in: drop rep.m4, instead improve the .pc file * librep.spec.in * Makefile.in: updated accordingly * configure.in: add -L/lib${libsuff} to READLINE_LIBS [T2 Patch] * src/main.c: mark check_configuration as not inlineable to fix build on ppc64 [Marcus Comstedt] * man/news.texi: Updated NEWS * src/fake-libexec: small fixup [SuSE] * src/rep-config.sh: no rpath [Fedora] 2008-11-22 Christopher Bratusek * MAINTAINERS: added me 2008-10-23 Christopher Bratusek * configure.in: 0.17.2 snapshot released, bump to 0.17.3 2008-10-18 Christopher Bratusek * src/numbers.c: fix an issue with FreeBSD [patch from FreeBSD] * src/numbers.c: improve a function [patch from FreeBSD] * src/librep.sym: rep_file_fdopen has not been listed * Makedefs.in * src/Makefile.in * intl/Makefile.in * rules.mk.sh: added --tag=CC to libtool in serveral places * Makedefs.in * src/Makefile.in: don't ignore $LDFLAGS upon build * src/sdbm.c: drop some useless code [NetBSD patch] * man/news.texi: updated 2008-10-01 Christopher Bratusek * BUGS: updated * HACKING: updated * README: updated * man/news.texi: updated 2008-09-02 Christopher Bratusek * configure.in: another fixup 2008-08-29 Christopher Bratusek * src/rep-subrs.h: replace the inclusion of config.h with a ifdef doing what we want * configure.in: fixup * Makefile.in: create $(DESTDIR)/$(libdir)/pkgconfig before installing the .pc file 2008-08-14 Christopher Bratusek * configure.in: AC_PROG_LIBTOOL not AM_PROG_LIBTOOL * autogen.sh: change accordingly * .cvsignore * */.cvsignore: add svn:ignore property and remove all .cvsignore files * configure.in: 0.17.1 released, bump to 0.17.2 2008-08-11 Christopher Bratusek * src/dlmalloc.c: replace // comments with /* */ * src/rep_subrs.h: add #include "../config.h" for #define inline 2008-08-08 Christopher Bratusek * src/rep_subrs.h: another fixup. lets us compile sawfish with paranoia cflags and seems not to break anything. * man/nes.texi: updated NEWS * src/unix_main.c: fixup 2008-08-06 Christopher Bratusek * Makedefs.in: add --no-split to makeinfo (FreeBSD patch) * configure.in: print usefull things at the end - add --enable-paranoia (compile with paranoia CFLAGS) 2008-08-05 Christopher Bratusek * BUGS * HACKING: updated information * configure.in: bump version to 0.17.1 * librep.spec.in: update the spec file * autogen.sh: add --force --copy to libtoolize flags * src/*: started code-cleanup * configure.in * Makefile.in * librep.pc.in: added a .pc file for librep * src/unix_files.c: Trim trailing '/' to mkdir(2) since some OSes fail the call otherwise (NetBSD patch) * src/rep-xgettext.jl: use correct shebang (ALT-Linux patch) * man/news.texi: add {define-special-variable} (Debian patch) * rules.mk.sh: add --tag CC to libtool (Debian patch) * src/main.c: replace a static void with a void (Debian patch) 2006-06-02 John Harper * rep.m4: fix for newer m4, from Michal Jaegermann 2006-01-31 John Harper * configure.in: fixed test for LC_MESSAGES to use new autoconf macro (gt_LC_MESSAGES not AM_LC_MESSAGES) 2003-11-24 John Harper * configure.in: version 0.17, bumped library revision * configure.in: $prefix can be set to "NONE" sometimes? 2003-09-03 John Harper * configure.in: fixes for compiling in a weird ${prefix}; Mac OS X fixes; other fixes * test, configure.in, Makefile.in, Makedefs.in: "DOC" file is now called "doc-strings" to avoid clashing with "doc" build directory in case folding filesystems 2003-07-26 John Harper * configure.in, config.h.in, Makedefs.in: updated for libffi 2003-02-25 John Harper * configure.in: version 0.16.2 2002-06-22 John Harper * configure.in: version 0.16.1 2002-06-20 John Harper * configure.in: version 0.16 2002-04-21 John Harper * configure.in: don't AC_SUBST(LIBOBJS), doesn't work on autoconf 2.53, patch from Murray Cumming 2002-04-13 John Harper * man/Makefile.in: use --info-dir when calling install-info 2002-02-20 John Harper * configure.in: don't ever compile our own dlmalloc, it breaks on too many platforms 2001-12-02 John Harper * configure.in: don't use dlmalloc on sparcs 2001-11-17 John Harper * Makedefs.in: don't use `libtool --mode=execute' in $(rep_prog), just call the script directly 2001-10-28 John Harper * configure.in: version 0.15.2 2001-10-03 John Harper * version 0.15.1 * build-info: don't try to find domainname, we don't need it 2001-10-01 John Harper * configure.in: version 0.15 * configure.in: check for __gmp_randinit () if gmp is found, and define HAVE_GMP_RANDINIT if so 2001-09-15 John Harper * config.h.in: removed spurious close-comment from after `#undef HAVE_MEMORY_H' 2001-09-14 John Harper * configure.in: bumped libcurrent and libage 2001-08-09 John Harper * rep-debugger.el: fixed for new debugger command line option names 2001-08-07 John Harper * configure.in, Makedefs.in, Makefile.in, librep.spec.in: install rep-debugger.el into the emacs site-lisp directory (in our $prefix) * rep-debugger.el: emacs code to make GUD mode work with rep's new source debugging support 2001-07-02 John Harper * configure.in: version 0.14, incremented library revision number 2001-06-20 John Harper * Makefile.in: fixed SUBDIRS commands to exit if an error occurs 2001-06-14 John Harper * configure.in, config.h.in: check for crypt () in default libs and in -lcrypt 2001-04-16 John Harper * configure.in, config.h.in: check for and define HAVE_SYS_DL_H if present (needed on UnixWare) 2001-04-09 John Harper * configure.in: changed version string to 0.14-pre now there's a 0.13.6 on a branch 2001-03-26 John Harper * Makefile.in, man/Makefile.in: added `check' targets 2001-03-22 John Harper * configure.in: version 0.13.5, bumped library revision number 2001-03-12 John Harper * emulate-gnu-tar, Makefile.in: new script, emulates the options of GNU tar that the tar file-handler uses, but using hopefully generic tar options and separate decompression programs. Used tar option combinations are `tvf -' and `xf - [FILE]' 2001-02-20 John Harper * configure.in: on Solaris use /usr/ccs/lib/cpp (patch from albert chin ) 2001-01-17 John Harper * librep.spec.in: unset LC_ALL, LINGUAS and LANG before building 2001-01-15 John Harper * configure.in: delete the rules.mk file each time AC_OUTPUT is run (since it can contain stale values, and the rule to rebuild it doesn't work for the top-level Makefile since it's included first) * rules.mk.sh: removed repdocfile definition, it's not used by anything and can confuse the librep build process 2001-01-04 John Harper * configure.in: version 0.13.4 2000-12-27 John Harper * rules.mk.sh: removed the `-export-symbols-regex' option, it's not possible to just export `rep_dl_foo' symbols.. 2000-12-06 John Harper * install-aliases (dosome): patch from Peter Teichman to avoid clobbering a variable that's needed in the next iteration of the loop 2000-12-03 John Harper * configure.in: version 0.13.3 2000-11-21 John Harper * rules.mk.sh: rename repexecdir variable as repcommonexecdir so it doesn't conflict with Makedefs.in (shouldn't affect other users of this file.. I hope) 2000-11-15 John Harper * Makedefs.in: include rules.mk and redefine $(rep_DL_LIBTOOL) to the uninstalled local libtool * rules.mk.sh: in $(rep_DL_LD) macro, specify -export-symbols-regex option to libtool to only retain symbols whose names begin with `rep_dl_' 2000-10-23 John Harper * configure.in: version 0.13.2 2000-10-18 John Harper * Makefile.in: fix repdoc dependences to refer to the actual file 2000-10-11 John Harper * install-aliases: add extra-paranoid quoting * configure.in: new option --enable-full-name-terminator (sets existing preprocessor symbol FULL_NAME_TERMINATOR) 2000-10-06 John Harper * install-aliases: try to rename libFOO.* as well as FOO.*. On some systems libtool creates module libraries with a `lib' prefix 2000-09-29 John Harper * librep.spec.in: override infodir in `make install' command 2000-09-28 John Harper * configure.in: version 0.13.1 2000-09-27 John Harper * configure.in, config.h.in: check for strncasecmp () 2000-09-20 John Harper * configure.in: version 0.13 2000-09-19 John Harper * build-info: use `$LOCALDOMAIN', then `dnsdomainname', before falling back to `domainname' 2000-09-10 Karl M. Hegbloom * man/Makefile.in (librep.pdf): New target * Makedefs.in (TEXI2PDF): New variable 2000-09-13 John Harper * configure.in: version 0.13pre2 2000-09-08 John Harper * configure.in: removed hack to look in etc for install-sh * man/repl.texi: new chapter `The REPL' 2000-09-05 John Harper * configure.in: adapted patch from Jacob for weird debian gmp header file location. Misc other changes to gmp checks 2000-09-04 John Harper * librep.spec.in: added `--with-extra-cflags=-fstrength-reduce' to configure. RH force -fno-strength-reduce on i386, this leads to too much register pressure in the vm, spilling one of the fixed regs.. * configure.in: version to 0.13pre1 2000-09-01 John Harper * librep.spec.in: added `Requires: gdbm >= 1.8' to avoid gdbm brain-damage * librep.spec.in: install rep_config.h in -devel pkg 2000-08-31 John Harper * configure.in: create rep_config.h instead of rep.h 2000-08-29 * librep.spec.in: librep-devel requires exactly @version@ of librep package 2000-08-17 John Harper * configure.in: add -Wpointer-arith when gcc, only add -Wno-implicit-int on solaris 2000-08-11 John Harper * configure.in: an additional option for configure, --with-readline-prefix, to specify an alternate path for the readline include/library files (from Albert Chin-A-Young ) 2000-08-03 John Harper * configure.in, config.h.in: check for strtoq () as well as strtoll () 2000-08-01 John Harper * intl/intl-compat.c, intl/Makefile.in: removed my edits, intl/ has no differences to standard gettext intl/ now * autogen.sh: new script * configure.in: removed ranlib check, remove aux-dir decl. Added check for if gettext is in libc * etc/regexp.patch, etc/gc-cons: deleted * etc/install-sh: moved to top-level directory * etc/ltmain.sh, etc/ltconfig, etc/config.sub, etc/config.guess: deleted, use libtoolize to create these 2000-07-29 John Harper * configure.in: signal an error if no gmp and --without-gmp wasn't given (the error message says to use --without-gmp if that's want is wanted) 2000-07-28 John Harper * Makedefs.in: in COMPILE_ENV changed REPEXECDIR to REP_DL_LOAD_PATH * configure.in: set GMP_LIBS to -lm if not using gmp 2000-07-24 John Harper * install-aliases: don't use -h or -H options to grep. Solaris grep chokes on -H and neither are needed anyway * librep.spec.in: added install-aliases 2000-07-23 John Harper * librep.spec.in: added rep_INSTALL_ALIASES * configure.in: version 0.13-pre, bumped libcurrent and libage * install-aliases: script to extract and create aliases from source files (C or Lisp). Installed into $(repcommonexecdir) 2000-07-20 John Harper * configure.in: version 0.12.4, bumped ${librevision} * Makedefs.in: set libtool mode explicitly * rules.mk.sh: set libtool mode explicitly; include -rpath option (from David Kaelbling ) 2000-07-15 John Harper * configure.in: added `--without-gmp' and `--disable-continuations' options * config.h.in: added HAVE_STRTOLL, WITH_GMP, WITH_CONTINUATIONS 2000-07-13 John Harper * configure.in: redirect stderr to /dev/null when trying to run `aclocal --print-ac-dir'. Apparently this avoids errors if aclocal isn't installed (patch from Albert Chin-A-Young ) 2000-07-12 John Harper * configure.in: version 0.12.3, bumped ${librevision} 2000-07-10 John Harper * configure.in: just use ${host_cpu} when checking for known stack growth directions * librep.spec.in: replaced `/usr/info' by `%{_infodir}' 2000-07-06 John Harper * Makefile.in, lisp/Makefile.in, man/Makefile.in, src/Makefile.in: updated to partially build in a separate directory. This still doesn't work for Lisp sources (adapted from Martin Pottendorfer ) 2000-06-29 John Harper * Makefile.in: added repexecdir to installdirs target (for DOC) 2000-06-22 John Harper * configure.in: version 0.12.2, incremented librevision 2000-06-18 John Harper * configure.in: version 0.12.1, incremented librevision * configure.in, config.h.in: check sizeof long and long long (if available), from George Lebl 2000-06-16 John Harper * configure.in: fixed typo when checking for shl_load in libdld * configure.in: version 0.12 * configure.in: check libdld for shl_load 2000-06-09 John Harper * Makefile.in: added distclean target as alias for realclean * configure.in: changed --with-gmp and --with-gdbm to be more conventional --with-gmp-prefix and --with-gdbm-prefix * configure.in: when extracting dependences from C files using GCC, use `-MM' not `-MM -MG' (from Brad Thompson ) 2000-06-07 John Harper * configure.in, Makefile.in: moved DOC file to ${repexecdir} since GDBM databases are endian-specific [ this is sub-optimal, since the lisp files are shared, but it's okay for now .. ] 2000-05-31 Karl M. Hegbloom * Makefile.in (TAGS): Use --regex to grab DEFSTRING, DEFSYM, DEFUN, and DEFUN_INT information also. (TAGS tags): add lowercase target name for lazy typists. librep-0.90.2/COPYING0000644000175200017520000004310511245011152013113 0ustar chrischris GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. librep-0.90.2/BUGS0000644000175200017520000000015411245011152012540 0ustar chrischris Please report bugs to the BugZilla http://bugzilla.gnome.org or the mailing list librep-0.90.2/AUTHORS0000644000175200017520000000004111245011152013120 0ustar chrischrisJohn Harper librep-0.90.2/.gdbinit0000644000175200017520000000040311245011152013473 0ustar chrischris# $Id$ # prints $arg0 to standard output define v call rep_print_val(Fstdout_file(), $arg0) call rep_stream_putc(Fstdout_file(), '\n') end # prints the lisp backtrace define lbt call Fbacktrace(Fstdout_file()) call rep_stream_putc(Fstdout_file(), '\n') end librep-0.90.2/m4/lt~obsolete.m40000644000175200017520000001311311245011162015211 0ustar chrischris# lt~obsolete.m4 -- aclocal satisfying obsolete definitions. -*-Autoconf-*- # # Copyright (C) 2004, 2005, 2007 Free Software Foundation, Inc. # Written by Scott James Remnant, 2004. # # This file is free software; the Free Software Foundation gives # unlimited permission to copy and/or distribute it, with or without # modifications, as long as this notice is preserved. # serial 4 lt~obsolete.m4 # These exist entirely to fool aclocal when bootstrapping libtool. # # In the past libtool.m4 has provided macros via AC_DEFUN (or AU_DEFUN) # which have later been changed to m4_define as they aren't part of the # exported API, or moved to Autoconf or Automake where they belong. # # The trouble is, aclocal is a bit thick. It'll see the old AC_DEFUN # in /usr/share/aclocal/libtool.m4 and remember it, then when it sees us # using a macro with the same name in our local m4/libtool.m4 it'll # pull the old libtool.m4 in (it doesn't see our shiny new m4_define # and doesn't know about Autoconf macros at all.) # # So we provide this file, which has a silly filename so it's always # included after everything else. This provides aclocal with the # AC_DEFUNs it wants, but when m4 processes it, it doesn't do anything # because those macros already exist, or will be overwritten later. # We use AC_DEFUN over AU_DEFUN for compatibility with aclocal-1.6. # # Anytime we withdraw an AC_DEFUN or AU_DEFUN, remember to add it here. # Yes, that means every name once taken will need to remain here until # we give up compatibility with versions before 1.7, at which point # we need to keep only those names which we still refer to. # This is to help aclocal find these macros, as it can't see m4_define. AC_DEFUN([LTOBSOLETE_VERSION], [m4_if([1])]) m4_ifndef([AC_LIBTOOL_LINKER_OPTION], [AC_DEFUN([AC_LIBTOOL_LINKER_OPTION])]) m4_ifndef([AC_PROG_EGREP], [AC_DEFUN([AC_PROG_EGREP])]) m4_ifndef([_LT_AC_PROG_ECHO_BACKSLASH], [AC_DEFUN([_LT_AC_PROG_ECHO_BACKSLASH])]) m4_ifndef([_LT_AC_SHELL_INIT], [AC_DEFUN([_LT_AC_SHELL_INIT])]) m4_ifndef([_LT_AC_SYS_LIBPATH_AIX], [AC_DEFUN([_LT_AC_SYS_LIBPATH_AIX])]) m4_ifndef([_LT_PROG_LTMAIN], [AC_DEFUN([_LT_PROG_LTMAIN])]) m4_ifndef([_LT_AC_TAGVAR], [AC_DEFUN([_LT_AC_TAGVAR])]) m4_ifndef([AC_LTDL_ENABLE_INSTALL], [AC_DEFUN([AC_LTDL_ENABLE_INSTALL])]) m4_ifndef([AC_LTDL_PREOPEN], [AC_DEFUN([AC_LTDL_PREOPEN])]) m4_ifndef([_LT_AC_SYS_COMPILER], [AC_DEFUN([_LT_AC_SYS_COMPILER])]) m4_ifndef([_LT_AC_LOCK], [AC_DEFUN([_LT_AC_LOCK])]) m4_ifndef([AC_LIBTOOL_SYS_OLD_ARCHIVE], [AC_DEFUN([AC_LIBTOOL_SYS_OLD_ARCHIVE])]) m4_ifndef([_LT_AC_TRY_DLOPEN_SELF], [AC_DEFUN([_LT_AC_TRY_DLOPEN_SELF])]) m4_ifndef([AC_LIBTOOL_PROG_CC_C_O], [AC_DEFUN([AC_LIBTOOL_PROG_CC_C_O])]) m4_ifndef([AC_LIBTOOL_SYS_HARD_LINK_LOCKS], [AC_DEFUN([AC_LIBTOOL_SYS_HARD_LINK_LOCKS])]) m4_ifndef([AC_LIBTOOL_OBJDIR], [AC_DEFUN([AC_LIBTOOL_OBJDIR])]) m4_ifndef([AC_LTDL_OBJDIR], [AC_DEFUN([AC_LTDL_OBJDIR])]) m4_ifndef([AC_LIBTOOL_PROG_LD_HARDCODE_LIBPATH], [AC_DEFUN([AC_LIBTOOL_PROG_LD_HARDCODE_LIBPATH])]) m4_ifndef([AC_LIBTOOL_SYS_LIB_STRIP], [AC_DEFUN([AC_LIBTOOL_SYS_LIB_STRIP])]) m4_ifndef([AC_PATH_MAGIC], [AC_DEFUN([AC_PATH_MAGIC])]) m4_ifndef([AC_PROG_LD_GNU], [AC_DEFUN([AC_PROG_LD_GNU])]) m4_ifndef([AC_PROG_LD_RELOAD_FLAG], [AC_DEFUN([AC_PROG_LD_RELOAD_FLAG])]) m4_ifndef([AC_DEPLIBS_CHECK_METHOD], [AC_DEFUN([AC_DEPLIBS_CHECK_METHOD])]) m4_ifndef([AC_LIBTOOL_PROG_COMPILER_NO_RTTI], [AC_DEFUN([AC_LIBTOOL_PROG_COMPILER_NO_RTTI])]) m4_ifndef([AC_LIBTOOL_SYS_GLOBAL_SYMBOL_PIPE], [AC_DEFUN([AC_LIBTOOL_SYS_GLOBAL_SYMBOL_PIPE])]) m4_ifndef([AC_LIBTOOL_PROG_COMPILER_PIC], [AC_DEFUN([AC_LIBTOOL_PROG_COMPILER_PIC])]) m4_ifndef([AC_LIBTOOL_PROG_LD_SHLIBS], [AC_DEFUN([AC_LIBTOOL_PROG_LD_SHLIBS])]) m4_ifndef([AC_LIBTOOL_POSTDEP_PREDEP], [AC_DEFUN([AC_LIBTOOL_POSTDEP_PREDEP])]) m4_ifndef([LT_AC_PROG_EGREP], [AC_DEFUN([LT_AC_PROG_EGREP])]) m4_ifndef([LT_AC_PROG_SED], [AC_DEFUN([LT_AC_PROG_SED])]) m4_ifndef([_LT_CC_BASENAME], [AC_DEFUN([_LT_CC_BASENAME])]) m4_ifndef([_LT_COMPILER_BOILERPLATE], [AC_DEFUN([_LT_COMPILER_BOILERPLATE])]) m4_ifndef([_LT_LINKER_BOILERPLATE], [AC_DEFUN([_LT_LINKER_BOILERPLATE])]) m4_ifndef([_AC_PROG_LIBTOOL], [AC_DEFUN([_AC_PROG_LIBTOOL])]) m4_ifndef([AC_LIBTOOL_SETUP], [AC_DEFUN([AC_LIBTOOL_SETUP])]) m4_ifndef([_LT_AC_CHECK_DLFCN], [AC_DEFUN([_LT_AC_CHECK_DLFCN])]) m4_ifndef([AC_LIBTOOL_SYS_DYNAMIC_LINKER], [AC_DEFUN([AC_LIBTOOL_SYS_DYNAMIC_LINKER])]) m4_ifndef([_LT_AC_TAGCONFIG], [AC_DEFUN([_LT_AC_TAGCONFIG])]) m4_ifndef([AC_DISABLE_FAST_INSTALL], [AC_DEFUN([AC_DISABLE_FAST_INSTALL])]) m4_ifndef([_LT_AC_LANG_CXX], [AC_DEFUN([_LT_AC_LANG_CXX])]) m4_ifndef([_LT_AC_LANG_F77], [AC_DEFUN([_LT_AC_LANG_F77])]) m4_ifndef([_LT_AC_LANG_GCJ], [AC_DEFUN([_LT_AC_LANG_GCJ])]) m4_ifndef([AC_LIBTOOL_RC], [AC_DEFUN([AC_LIBTOOL_RC])]) m4_ifndef([AC_LIBTOOL_LANG_C_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_C_CONFIG])]) m4_ifndef([_LT_AC_LANG_C_CONFIG], [AC_DEFUN([_LT_AC_LANG_C_CONFIG])]) m4_ifndef([AC_LIBTOOL_LANG_CXX_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_CXX_CONFIG])]) m4_ifndef([_LT_AC_LANG_CXX_CONFIG], [AC_DEFUN([_LT_AC_LANG_CXX_CONFIG])]) m4_ifndef([AC_LIBTOOL_LANG_F77_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_F77_CONFIG])]) m4_ifndef([_LT_AC_LANG_F77_CONFIG], [AC_DEFUN([_LT_AC_LANG_F77_CONFIG])]) m4_ifndef([AC_LIBTOOL_LANG_GCJ_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_GCJ_CONFIG])]) m4_ifndef([_LT_AC_LANG_GCJ_CONFIG], [AC_DEFUN([_LT_AC_LANG_GCJ_CONFIG])]) m4_ifndef([AC_LIBTOOL_LANG_RC_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_RC_CONFIG])]) m4_ifndef([_LT_AC_LANG_RC_CONFIG], [AC_DEFUN([_LT_AC_LANG_RC_CONFIG])]) m4_ifndef([AC_LIBTOOL_CONFIG], [AC_DEFUN([AC_LIBTOOL_CONFIG])]) m4_ifndef([_LT_AC_FILE_LTDLL_C], [AC_DEFUN([_LT_AC_FILE_LTDLL_C])]) librep-0.90.2/m4/ltversion.m40000644000175200017520000000127511245011162014672 0ustar chrischris# ltversion.m4 -- version numbers -*- Autoconf -*- # # Copyright (C) 2004 Free Software Foundation, Inc. # Written by Scott James Remnant, 2004 # # This file is free software; the Free Software Foundation gives # unlimited permission to copy and/or distribute it, with or without # modifications, as long as this notice is preserved. # Generated from ltversion.in. # serial 3012 ltversion.m4 # This file is part of GNU Libtool m4_define([LT_PACKAGE_VERSION], [2.2.6]) m4_define([LT_PACKAGE_REVISION], [1.3012]) AC_DEFUN([LTVERSION_VERSION], [macro_version='2.2.6' macro_revision='1.3012' _LT_DECL(, macro_version, 0, [Which release of libtool.m4 was used?]) _LT_DECL(, macro_revision, 0) ]) librep-0.90.2/m4/ltsugar.m40000644000175200017520000001042411245011162014322 0ustar chrischris# ltsugar.m4 -- libtool m4 base layer. -*-Autoconf-*- # # Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc. # Written by Gary V. Vaughan, 2004 # # This file is free software; the Free Software Foundation gives # unlimited permission to copy and/or distribute it, with or without # modifications, as long as this notice is preserved. # serial 6 ltsugar.m4 # This is to help aclocal find these macros, as it can't see m4_define. AC_DEFUN([LTSUGAR_VERSION], [m4_if([0.1])]) # lt_join(SEP, ARG1, [ARG2...]) # ----------------------------- # Produce ARG1SEPARG2...SEPARGn, omitting [] arguments and their # associated separator. # Needed until we can rely on m4_join from Autoconf 2.62, since all earlier # versions in m4sugar had bugs. m4_define([lt_join], [m4_if([$#], [1], [], [$#], [2], [[$2]], [m4_if([$2], [], [], [[$2]_])$0([$1], m4_shift(m4_shift($@)))])]) m4_define([_lt_join], [m4_if([$#$2], [2], [], [m4_if([$2], [], [], [[$1$2]])$0([$1], m4_shift(m4_shift($@)))])]) # lt_car(LIST) # lt_cdr(LIST) # ------------ # Manipulate m4 lists. # These macros are necessary as long as will still need to support # Autoconf-2.59 which quotes differently. m4_define([lt_car], [[$1]]) m4_define([lt_cdr], [m4_if([$#], 0, [m4_fatal([$0: cannot be called without arguments])], [$#], 1, [], [m4_dquote(m4_shift($@))])]) m4_define([lt_unquote], $1) # lt_append(MACRO-NAME, STRING, [SEPARATOR]) # ------------------------------------------ # Redefine MACRO-NAME to hold its former content plus `SEPARATOR'`STRING'. # Note that neither SEPARATOR nor STRING are expanded; they are appended # to MACRO-NAME as is (leaving the expansion for when MACRO-NAME is invoked). # No SEPARATOR is output if MACRO-NAME was previously undefined (different # than defined and empty). # # This macro is needed until we can rely on Autoconf 2.62, since earlier # versions of m4sugar mistakenly expanded SEPARATOR but not STRING. m4_define([lt_append], [m4_define([$1], m4_ifdef([$1], [m4_defn([$1])[$3]])[$2])]) # lt_combine(SEP, PREFIX-LIST, INFIX, SUFFIX1, [SUFFIX2...]) # ---------------------------------------------------------- # Produce a SEP delimited list of all paired combinations of elements of # PREFIX-LIST with SUFFIX1 through SUFFIXn. Each element of the list # has the form PREFIXmINFIXSUFFIXn. # Needed until we can rely on m4_combine added in Autoconf 2.62. m4_define([lt_combine], [m4_if(m4_eval([$# > 3]), [1], [m4_pushdef([_Lt_sep], [m4_define([_Lt_sep], m4_defn([lt_car]))])]]dnl [[m4_foreach([_Lt_prefix], [$2], [m4_foreach([_Lt_suffix], ]m4_dquote(m4_dquote(m4_shift(m4_shift(m4_shift($@)))))[, [_Lt_sep([$1])[]m4_defn([_Lt_prefix])[$3]m4_defn([_Lt_suffix])])])])]) # lt_if_append_uniq(MACRO-NAME, VARNAME, [SEPARATOR], [UNIQ], [NOT-UNIQ]) # ----------------------------------------------------------------------- # Iff MACRO-NAME does not yet contain VARNAME, then append it (delimited # by SEPARATOR if supplied) and expand UNIQ, else NOT-UNIQ. m4_define([lt_if_append_uniq], [m4_ifdef([$1], [m4_if(m4_index([$3]m4_defn([$1])[$3], [$3$2$3]), [-1], [lt_append([$1], [$2], [$3])$4], [$5])], [lt_append([$1], [$2], [$3])$4])]) # lt_dict_add(DICT, KEY, VALUE) # ----------------------------- m4_define([lt_dict_add], [m4_define([$1($2)], [$3])]) # lt_dict_add_subkey(DICT, KEY, SUBKEY, VALUE) # -------------------------------------------- m4_define([lt_dict_add_subkey], [m4_define([$1($2:$3)], [$4])]) # lt_dict_fetch(DICT, KEY, [SUBKEY]) # ---------------------------------- m4_define([lt_dict_fetch], [m4_ifval([$3], m4_ifdef([$1($2:$3)], [m4_defn([$1($2:$3)])]), m4_ifdef([$1($2)], [m4_defn([$1($2)])]))]) # lt_if_dict_fetch(DICT, KEY, [SUBKEY], VALUE, IF-TRUE, [IF-FALSE]) # ----------------------------------------------------------------- m4_define([lt_if_dict_fetch], [m4_if(lt_dict_fetch([$1], [$2], [$3]), [$4], [$5], [$6])]) # lt_dict_filter(DICT, [SUBKEY], VALUE, [SEPARATOR], KEY, [...]) # -------------------------------------------------------------- m4_define([lt_dict_filter], [m4_if([$5], [], [], [lt_join(m4_quote(m4_default([$4], [[, ]])), lt_unquote(m4_split(m4_normalize(m4_foreach(_Lt_key, lt_car([m4_shiftn(4, $@)]), [lt_if_dict_fetch([$1], _Lt_key, [$2], [$3], [_Lt_key ])])))))])[]dnl ]) librep-0.90.2/m4/ltoptions.m40000644000175200017520000002724211245011162014702 0ustar chrischris# Helper functions for option handling. -*- Autoconf -*- # # Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc. # Written by Gary V. Vaughan, 2004 # # This file is free software; the Free Software Foundation gives # unlimited permission to copy and/or distribute it, with or without # modifications, as long as this notice is preserved. # serial 6 ltoptions.m4 # This is to help aclocal find these macros, as it can't see m4_define. AC_DEFUN([LTOPTIONS_VERSION], [m4_if([1])]) # _LT_MANGLE_OPTION(MACRO-NAME, OPTION-NAME) # ------------------------------------------ m4_define([_LT_MANGLE_OPTION], [[_LT_OPTION_]m4_bpatsubst($1__$2, [[^a-zA-Z0-9_]], [_])]) # _LT_SET_OPTION(MACRO-NAME, OPTION-NAME) # --------------------------------------- # Set option OPTION-NAME for macro MACRO-NAME, and if there is a # matching handler defined, dispatch to it. Other OPTION-NAMEs are # saved as a flag. m4_define([_LT_SET_OPTION], [m4_define(_LT_MANGLE_OPTION([$1], [$2]))dnl m4_ifdef(_LT_MANGLE_DEFUN([$1], [$2]), _LT_MANGLE_DEFUN([$1], [$2]), [m4_warning([Unknown $1 option `$2'])])[]dnl ]) # _LT_IF_OPTION(MACRO-NAME, OPTION-NAME, IF-SET, [IF-NOT-SET]) # ------------------------------------------------------------ # Execute IF-SET if OPTION is set, IF-NOT-SET otherwise. m4_define([_LT_IF_OPTION], [m4_ifdef(_LT_MANGLE_OPTION([$1], [$2]), [$3], [$4])]) # _LT_UNLESS_OPTIONS(MACRO-NAME, OPTION-LIST, IF-NOT-SET) # ------------------------------------------------------- # Execute IF-NOT-SET unless all options in OPTION-LIST for MACRO-NAME # are set. m4_define([_LT_UNLESS_OPTIONS], [m4_foreach([_LT_Option], m4_split(m4_normalize([$2])), [m4_ifdef(_LT_MANGLE_OPTION([$1], _LT_Option), [m4_define([$0_found])])])[]dnl m4_ifdef([$0_found], [m4_undefine([$0_found])], [$3 ])[]dnl ]) # _LT_SET_OPTIONS(MACRO-NAME, OPTION-LIST) # ---------------------------------------- # OPTION-LIST is a space-separated list of Libtool options associated # with MACRO-NAME. If any OPTION has a matching handler declared with # LT_OPTION_DEFINE, dispatch to that macro; otherwise complain about # the unknown option and exit. m4_defun([_LT_SET_OPTIONS], [# Set options m4_foreach([_LT_Option], m4_split(m4_normalize([$2])), [_LT_SET_OPTION([$1], _LT_Option)]) m4_if([$1],[LT_INIT],[ dnl dnl Simply set some default values (i.e off) if boolean options were not dnl specified: _LT_UNLESS_OPTIONS([LT_INIT], [dlopen], [enable_dlopen=no ]) _LT_UNLESS_OPTIONS([LT_INIT], [win32-dll], [enable_win32_dll=no ]) dnl dnl If no reference was made to various pairs of opposing options, then dnl we run the default mode handler for the pair. For example, if neither dnl `shared' nor `disable-shared' was passed, we enable building of shared dnl archives by default: _LT_UNLESS_OPTIONS([LT_INIT], [shared disable-shared], [_LT_ENABLE_SHARED]) _LT_UNLESS_OPTIONS([LT_INIT], [static disable-static], [_LT_ENABLE_STATIC]) _LT_UNLESS_OPTIONS([LT_INIT], [pic-only no-pic], [_LT_WITH_PIC]) _LT_UNLESS_OPTIONS([LT_INIT], [fast-install disable-fast-install], [_LT_ENABLE_FAST_INSTALL]) ]) ])# _LT_SET_OPTIONS ## --------------------------------- ## ## Macros to handle LT_INIT options. ## ## --------------------------------- ## # _LT_MANGLE_DEFUN(MACRO-NAME, OPTION-NAME) # ----------------------------------------- m4_define([_LT_MANGLE_DEFUN], [[_LT_OPTION_DEFUN_]m4_bpatsubst(m4_toupper([$1__$2]), [[^A-Z0-9_]], [_])]) # LT_OPTION_DEFINE(MACRO-NAME, OPTION-NAME, CODE) # ----------------------------------------------- m4_define([LT_OPTION_DEFINE], [m4_define(_LT_MANGLE_DEFUN([$1], [$2]), [$3])[]dnl ])# LT_OPTION_DEFINE # dlopen # ------ LT_OPTION_DEFINE([LT_INIT], [dlopen], [enable_dlopen=yes ]) AU_DEFUN([AC_LIBTOOL_DLOPEN], [_LT_SET_OPTION([LT_INIT], [dlopen]) AC_DIAGNOSE([obsolete], [$0: Remove this warning and the call to _LT_SET_OPTION when you put the `dlopen' option into LT_INIT's first parameter.]) ]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_LIBTOOL_DLOPEN], []) # win32-dll # --------- # Declare package support for building win32 dll's. LT_OPTION_DEFINE([LT_INIT], [win32-dll], [enable_win32_dll=yes case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-cegcc*) AC_CHECK_TOOL(AS, as, false) AC_CHECK_TOOL(DLLTOOL, dlltool, false) AC_CHECK_TOOL(OBJDUMP, objdump, false) ;; esac test -z "$AS" && AS=as _LT_DECL([], [AS], [0], [Assembler program])dnl test -z "$DLLTOOL" && DLLTOOL=dlltool _LT_DECL([], [DLLTOOL], [0], [DLL creation program])dnl test -z "$OBJDUMP" && OBJDUMP=objdump _LT_DECL([], [OBJDUMP], [0], [Object dumper program])dnl ])# win32-dll AU_DEFUN([AC_LIBTOOL_WIN32_DLL], [AC_REQUIRE([AC_CANONICAL_HOST])dnl _LT_SET_OPTION([LT_INIT], [win32-dll]) AC_DIAGNOSE([obsolete], [$0: Remove this warning and the call to _LT_SET_OPTION when you put the `win32-dll' option into LT_INIT's first parameter.]) ]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_LIBTOOL_WIN32_DLL], []) # _LT_ENABLE_SHARED([DEFAULT]) # ---------------------------- # implement the --enable-shared flag, and supports the `shared' and # `disable-shared' LT_INIT options. # DEFAULT is either `yes' or `no'. If omitted, it defaults to `yes'. m4_define([_LT_ENABLE_SHARED], [m4_define([_LT_ENABLE_SHARED_DEFAULT], [m4_if($1, no, no, yes)])dnl AC_ARG_ENABLE([shared], [AS_HELP_STRING([--enable-shared@<:@=PKGS@:>@], [build shared libraries @<:@default=]_LT_ENABLE_SHARED_DEFAULT[@:>@])], [p=${PACKAGE-default} case $enableval in yes) enable_shared=yes ;; no) enable_shared=no ;; *) enable_shared=no # Look at the argument we got. We use all the common list separators. lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR," for pkg in $enableval; do IFS="$lt_save_ifs" if test "X$pkg" = "X$p"; then enable_shared=yes fi done IFS="$lt_save_ifs" ;; esac], [enable_shared=]_LT_ENABLE_SHARED_DEFAULT) _LT_DECL([build_libtool_libs], [enable_shared], [0], [Whether or not to build shared libraries]) ])# _LT_ENABLE_SHARED LT_OPTION_DEFINE([LT_INIT], [shared], [_LT_ENABLE_SHARED([yes])]) LT_OPTION_DEFINE([LT_INIT], [disable-shared], [_LT_ENABLE_SHARED([no])]) # Old names: AC_DEFUN([AC_ENABLE_SHARED], [_LT_SET_OPTION([LT_INIT], m4_if([$1], [no], [disable-])[shared]) ]) AC_DEFUN([AC_DISABLE_SHARED], [_LT_SET_OPTION([LT_INIT], [disable-shared]) ]) AU_DEFUN([AM_ENABLE_SHARED], [AC_ENABLE_SHARED($@)]) AU_DEFUN([AM_DISABLE_SHARED], [AC_DISABLE_SHARED($@)]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AM_ENABLE_SHARED], []) dnl AC_DEFUN([AM_DISABLE_SHARED], []) # _LT_ENABLE_STATIC([DEFAULT]) # ---------------------------- # implement the --enable-static flag, and support the `static' and # `disable-static' LT_INIT options. # DEFAULT is either `yes' or `no'. If omitted, it defaults to `yes'. m4_define([_LT_ENABLE_STATIC], [m4_define([_LT_ENABLE_STATIC_DEFAULT], [m4_if($1, no, no, yes)])dnl AC_ARG_ENABLE([static], [AS_HELP_STRING([--enable-static@<:@=PKGS@:>@], [build static libraries @<:@default=]_LT_ENABLE_STATIC_DEFAULT[@:>@])], [p=${PACKAGE-default} case $enableval in yes) enable_static=yes ;; no) enable_static=no ;; *) enable_static=no # Look at the argument we got. We use all the common list separators. lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR," for pkg in $enableval; do IFS="$lt_save_ifs" if test "X$pkg" = "X$p"; then enable_static=yes fi done IFS="$lt_save_ifs" ;; esac], [enable_static=]_LT_ENABLE_STATIC_DEFAULT) _LT_DECL([build_old_libs], [enable_static], [0], [Whether or not to build static libraries]) ])# _LT_ENABLE_STATIC LT_OPTION_DEFINE([LT_INIT], [static], [_LT_ENABLE_STATIC([yes])]) LT_OPTION_DEFINE([LT_INIT], [disable-static], [_LT_ENABLE_STATIC([no])]) # Old names: AC_DEFUN([AC_ENABLE_STATIC], [_LT_SET_OPTION([LT_INIT], m4_if([$1], [no], [disable-])[static]) ]) AC_DEFUN([AC_DISABLE_STATIC], [_LT_SET_OPTION([LT_INIT], [disable-static]) ]) AU_DEFUN([AM_ENABLE_STATIC], [AC_ENABLE_STATIC($@)]) AU_DEFUN([AM_DISABLE_STATIC], [AC_DISABLE_STATIC($@)]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AM_ENABLE_STATIC], []) dnl AC_DEFUN([AM_DISABLE_STATIC], []) # _LT_ENABLE_FAST_INSTALL([DEFAULT]) # ---------------------------------- # implement the --enable-fast-install flag, and support the `fast-install' # and `disable-fast-install' LT_INIT options. # DEFAULT is either `yes' or `no'. If omitted, it defaults to `yes'. m4_define([_LT_ENABLE_FAST_INSTALL], [m4_define([_LT_ENABLE_FAST_INSTALL_DEFAULT], [m4_if($1, no, no, yes)])dnl AC_ARG_ENABLE([fast-install], [AS_HELP_STRING([--enable-fast-install@<:@=PKGS@:>@], [optimize for fast installation @<:@default=]_LT_ENABLE_FAST_INSTALL_DEFAULT[@:>@])], [p=${PACKAGE-default} case $enableval in yes) enable_fast_install=yes ;; no) enable_fast_install=no ;; *) enable_fast_install=no # Look at the argument we got. We use all the common list separators. lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR," for pkg in $enableval; do IFS="$lt_save_ifs" if test "X$pkg" = "X$p"; then enable_fast_install=yes fi done IFS="$lt_save_ifs" ;; esac], [enable_fast_install=]_LT_ENABLE_FAST_INSTALL_DEFAULT) _LT_DECL([fast_install], [enable_fast_install], [0], [Whether or not to optimize for fast installation])dnl ])# _LT_ENABLE_FAST_INSTALL LT_OPTION_DEFINE([LT_INIT], [fast-install], [_LT_ENABLE_FAST_INSTALL([yes])]) LT_OPTION_DEFINE([LT_INIT], [disable-fast-install], [_LT_ENABLE_FAST_INSTALL([no])]) # Old names: AU_DEFUN([AC_ENABLE_FAST_INSTALL], [_LT_SET_OPTION([LT_INIT], m4_if([$1], [no], [disable-])[fast-install]) AC_DIAGNOSE([obsolete], [$0: Remove this warning and the call to _LT_SET_OPTION when you put the `fast-install' option into LT_INIT's first parameter.]) ]) AU_DEFUN([AC_DISABLE_FAST_INSTALL], [_LT_SET_OPTION([LT_INIT], [disable-fast-install]) AC_DIAGNOSE([obsolete], [$0: Remove this warning and the call to _LT_SET_OPTION when you put the `disable-fast-install' option into LT_INIT's first parameter.]) ]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_ENABLE_FAST_INSTALL], []) dnl AC_DEFUN([AM_DISABLE_FAST_INSTALL], []) # _LT_WITH_PIC([MODE]) # -------------------- # implement the --with-pic flag, and support the `pic-only' and `no-pic' # LT_INIT options. # MODE is either `yes' or `no'. If omitted, it defaults to `both'. m4_define([_LT_WITH_PIC], [AC_ARG_WITH([pic], [AS_HELP_STRING([--with-pic], [try to use only PIC/non-PIC objects @<:@default=use both@:>@])], [pic_mode="$withval"], [pic_mode=default]) test -z "$pic_mode" && pic_mode=m4_default([$1], [default]) _LT_DECL([], [pic_mode], [0], [What type of objects to build])dnl ])# _LT_WITH_PIC LT_OPTION_DEFINE([LT_INIT], [pic-only], [_LT_WITH_PIC([yes])]) LT_OPTION_DEFINE([LT_INIT], [no-pic], [_LT_WITH_PIC([no])]) # Old name: AU_DEFUN([AC_LIBTOOL_PICMODE], [_LT_SET_OPTION([LT_INIT], [pic-only]) AC_DIAGNOSE([obsolete], [$0: Remove this warning and the call to _LT_SET_OPTION when you put the `pic-only' option into LT_INIT's first parameter.]) ]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_LIBTOOL_PICMODE], []) ## ----------------- ## ## LTDL_INIT Options ## ## ----------------- ## m4_define([_LTDL_MODE], []) LT_OPTION_DEFINE([LTDL_INIT], [nonrecursive], [m4_define([_LTDL_MODE], [nonrecursive])]) LT_OPTION_DEFINE([LTDL_INIT], [recursive], [m4_define([_LTDL_MODE], [recursive])]) LT_OPTION_DEFINE([LTDL_INIT], [subproject], [m4_define([_LTDL_MODE], [subproject])]) m4_define([_LTDL_TYPE], []) LT_OPTION_DEFINE([LTDL_INIT], [installable], [m4_define([_LTDL_TYPE], [installable])]) LT_OPTION_DEFINE([LTDL_INIT], [convenience], [m4_define([_LTDL_TYPE], [convenience])]) librep-0.90.2/m4/libtool.m40000644000175200017520000077437411245011162014332 0ustar chrischris# libtool.m4 - Configure libtool for the host system. -*-Autoconf-*- # # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2005, # 2006, 2007, 2008 Free Software Foundation, Inc. # Written by Gordon Matzigkeit, 1996 # # This file is free software; the Free Software Foundation gives # unlimited permission to copy and/or distribute it, with or without # modifications, as long as this notice is preserved. m4_define([_LT_COPYING], [dnl # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2005, # 2006, 2007, 2008 Free Software Foundation, Inc. # Written by Gordon Matzigkeit, 1996 # # This file is part of GNU Libtool. # # GNU Libtool is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License as # published by the Free Software Foundation; either version 2 of # the License, or (at your option) any later version. # # As a special exception to the GNU General Public License, # if you distribute this file as part of a program or library that # is built using GNU Libtool, you may include this file under the # same distribution terms that you use for the rest of that program. # # GNU Libtool is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with GNU Libtool; see the file COPYING. If not, a copy # can be downloaded from http://www.gnu.org/licenses/gpl.html, or # obtained by writing to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. ]) # serial 56 LT_INIT # LT_PREREQ(VERSION) # ------------------ # Complain and exit if this libtool version is less that VERSION. m4_defun([LT_PREREQ], [m4_if(m4_version_compare(m4_defn([LT_PACKAGE_VERSION]), [$1]), -1, [m4_default([$3], [m4_fatal([Libtool version $1 or higher is required], 63)])], [$2])]) # _LT_CHECK_BUILDDIR # ------------------ # Complain if the absolute build directory name contains unusual characters m4_defun([_LT_CHECK_BUILDDIR], [case `pwd` in *\ * | *\ *) AC_MSG_WARN([Libtool does not cope well with whitespace in `pwd`]) ;; esac ]) # LT_INIT([OPTIONS]) # ------------------ AC_DEFUN([LT_INIT], [AC_PREREQ([2.58])dnl We use AC_INCLUDES_DEFAULT AC_BEFORE([$0], [LT_LANG])dnl AC_BEFORE([$0], [LT_OUTPUT])dnl AC_BEFORE([$0], [LTDL_INIT])dnl m4_require([_LT_CHECK_BUILDDIR])dnl dnl Autoconf doesn't catch unexpanded LT_ macros by default: m4_pattern_forbid([^_?LT_[A-Z_]+$])dnl m4_pattern_allow([^(_LT_EOF|LT_DLGLOBAL|LT_DLLAZY_OR_NOW|LT_MULTI_MODULE)$])dnl dnl aclocal doesn't pull ltoptions.m4, ltsugar.m4, or ltversion.m4 dnl unless we require an AC_DEFUNed macro: AC_REQUIRE([LTOPTIONS_VERSION])dnl AC_REQUIRE([LTSUGAR_VERSION])dnl AC_REQUIRE([LTVERSION_VERSION])dnl AC_REQUIRE([LTOBSOLETE_VERSION])dnl m4_require([_LT_PROG_LTMAIN])dnl dnl Parse OPTIONS _LT_SET_OPTIONS([$0], [$1]) # This can be used to rebuild libtool when needed LIBTOOL_DEPS="$ltmain" # Always use our own libtool. LIBTOOL='$(SHELL) $(top_builddir)/libtool' AC_SUBST(LIBTOOL)dnl _LT_SETUP # Only expand once: m4_define([LT_INIT]) ])# LT_INIT # Old names: AU_ALIAS([AC_PROG_LIBTOOL], [LT_INIT]) AU_ALIAS([AM_PROG_LIBTOOL], [LT_INIT]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_PROG_LIBTOOL], []) dnl AC_DEFUN([AM_PROG_LIBTOOL], []) # _LT_CC_BASENAME(CC) # ------------------- # Calculate cc_basename. Skip known compiler wrappers and cross-prefix. m4_defun([_LT_CC_BASENAME], [for cc_temp in $1""; do case $cc_temp in compile | *[[\\/]]compile | ccache | *[[\\/]]ccache ) ;; distcc | *[[\\/]]distcc | purify | *[[\\/]]purify ) ;; \-*) ;; *) break;; esac done cc_basename=`$ECHO "X$cc_temp" | $Xsed -e 's%.*/%%' -e "s%^$host_alias-%%"` ]) # _LT_FILEUTILS_DEFAULTS # ---------------------- # It is okay to use these file commands and assume they have been set # sensibly after `m4_require([_LT_FILEUTILS_DEFAULTS])'. m4_defun([_LT_FILEUTILS_DEFAULTS], [: ${CP="cp -f"} : ${MV="mv -f"} : ${RM="rm -f"} ])# _LT_FILEUTILS_DEFAULTS # _LT_SETUP # --------- m4_defun([_LT_SETUP], [AC_REQUIRE([AC_CANONICAL_HOST])dnl AC_REQUIRE([AC_CANONICAL_BUILD])dnl _LT_DECL([], [host_alias], [0], [The host system])dnl _LT_DECL([], [host], [0])dnl _LT_DECL([], [host_os], [0])dnl dnl _LT_DECL([], [build_alias], [0], [The build system])dnl _LT_DECL([], [build], [0])dnl _LT_DECL([], [build_os], [0])dnl dnl AC_REQUIRE([AC_PROG_CC])dnl AC_REQUIRE([LT_PATH_LD])dnl AC_REQUIRE([LT_PATH_NM])dnl dnl AC_REQUIRE([AC_PROG_LN_S])dnl test -z "$LN_S" && LN_S="ln -s" _LT_DECL([], [LN_S], [1], [Whether we need soft or hard links])dnl dnl AC_REQUIRE([LT_CMD_MAX_LEN])dnl _LT_DECL([objext], [ac_objext], [0], [Object file suffix (normally "o")])dnl _LT_DECL([], [exeext], [0], [Executable file suffix (normally "")])dnl dnl m4_require([_LT_FILEUTILS_DEFAULTS])dnl m4_require([_LT_CHECK_SHELL_FEATURES])dnl m4_require([_LT_CMD_RELOAD])dnl m4_require([_LT_CHECK_MAGIC_METHOD])dnl m4_require([_LT_CMD_OLD_ARCHIVE])dnl m4_require([_LT_CMD_GLOBAL_SYMBOLS])dnl _LT_CONFIG_LIBTOOL_INIT([ # See if we are running on zsh, and set the options which allow our # commands through without removal of \ escapes INIT. if test -n "\${ZSH_VERSION+set}" ; then setopt NO_GLOB_SUBST fi ]) if test -n "${ZSH_VERSION+set}" ; then setopt NO_GLOB_SUBST fi _LT_CHECK_OBJDIR m4_require([_LT_TAG_COMPILER])dnl _LT_PROG_ECHO_BACKSLASH case $host_os in aix3*) # AIX sometimes has problems with the GCC collect2 program. For some # reason, if we set the COLLECT_NAMES environment variable, the problems # vanish in a puff of smoke. if test "X${COLLECT_NAMES+set}" != Xset; then COLLECT_NAMES= export COLLECT_NAMES fi ;; esac # Sed substitution that helps us do robust quoting. It backslashifies # metacharacters that are still active within double-quoted strings. sed_quote_subst='s/\([["`$\\]]\)/\\\1/g' # Same as above, but do not quote variable references. double_quote_subst='s/\([["`\\]]\)/\\\1/g' # Sed substitution to delay expansion of an escaped shell variable in a # double_quote_subst'ed string. delay_variable_subst='s/\\\\\\\\\\\$/\\\\\\$/g' # Sed substitution to delay expansion of an escaped single quote. delay_single_quote_subst='s/'\''/'\'\\\\\\\'\''/g' # Sed substitution to avoid accidental globbing in evaled expressions no_glob_subst='s/\*/\\\*/g' # Global variables: ofile=libtool can_build_shared=yes # All known linkers require a `.a' archive for static linking (except MSVC, # which needs '.lib'). libext=a with_gnu_ld="$lt_cv_prog_gnu_ld" old_CC="$CC" old_CFLAGS="$CFLAGS" # Set sane defaults for various variables test -z "$CC" && CC=cc test -z "$LTCC" && LTCC=$CC test -z "$LTCFLAGS" && LTCFLAGS=$CFLAGS test -z "$LD" && LD=ld test -z "$ac_objext" && ac_objext=o _LT_CC_BASENAME([$compiler]) # Only perform the check for file, if the check method requires it test -z "$MAGIC_CMD" && MAGIC_CMD=file case $deplibs_check_method in file_magic*) if test "$file_magic_cmd" = '$MAGIC_CMD'; then _LT_PATH_MAGIC fi ;; esac # Use C for the default configuration in the libtool script LT_SUPPORTED_TAG([CC]) _LT_LANG_C_CONFIG _LT_LANG_DEFAULT_CONFIG _LT_CONFIG_COMMANDS ])# _LT_SETUP # _LT_PROG_LTMAIN # --------------- # Note that this code is called both from `configure', and `config.status' # now that we use AC_CONFIG_COMMANDS to generate libtool. Notably, # `config.status' has no value for ac_aux_dir unless we are using Automake, # so we pass a copy along to make sure it has a sensible value anyway. m4_defun([_LT_PROG_LTMAIN], [m4_ifdef([AC_REQUIRE_AUX_FILE], [AC_REQUIRE_AUX_FILE([ltmain.sh])])dnl _LT_CONFIG_LIBTOOL_INIT([ac_aux_dir='$ac_aux_dir']) ltmain="$ac_aux_dir/ltmain.sh" ])# _LT_PROG_LTMAIN ## ------------------------------------- ## ## Accumulate code for creating libtool. ## ## ------------------------------------- ## # So that we can recreate a full libtool script including additional # tags, we accumulate the chunks of code to send to AC_CONFIG_COMMANDS # in macros and then make a single call at the end using the `libtool' # label. # _LT_CONFIG_LIBTOOL_INIT([INIT-COMMANDS]) # ---------------------------------------- # Register INIT-COMMANDS to be passed to AC_CONFIG_COMMANDS later. m4_define([_LT_CONFIG_LIBTOOL_INIT], [m4_ifval([$1], [m4_append([_LT_OUTPUT_LIBTOOL_INIT], [$1 ])])]) # Initialize. m4_define([_LT_OUTPUT_LIBTOOL_INIT]) # _LT_CONFIG_LIBTOOL([COMMANDS]) # ------------------------------ # Register COMMANDS to be passed to AC_CONFIG_COMMANDS later. m4_define([_LT_CONFIG_LIBTOOL], [m4_ifval([$1], [m4_append([_LT_OUTPUT_LIBTOOL_COMMANDS], [$1 ])])]) # Initialize. m4_define([_LT_OUTPUT_LIBTOOL_COMMANDS]) # _LT_CONFIG_SAVE_COMMANDS([COMMANDS], [INIT_COMMANDS]) # ----------------------------------------------------- m4_defun([_LT_CONFIG_SAVE_COMMANDS], [_LT_CONFIG_LIBTOOL([$1]) _LT_CONFIG_LIBTOOL_INIT([$2]) ]) # _LT_FORMAT_COMMENT([COMMENT]) # ----------------------------- # Add leading comment marks to the start of each line, and a trailing # full-stop to the whole comment if one is not present already. m4_define([_LT_FORMAT_COMMENT], [m4_ifval([$1], [ m4_bpatsubst([m4_bpatsubst([$1], [^ *], [# ])], [['`$\]], [\\\&])]m4_bmatch([$1], [[!?.]$], [], [.]) )]) ## ------------------------ ## ## FIXME: Eliminate VARNAME ## ## ------------------------ ## # _LT_DECL([CONFIGNAME], VARNAME, VALUE, [DESCRIPTION], [IS-TAGGED?]) # ------------------------------------------------------------------- # CONFIGNAME is the name given to the value in the libtool script. # VARNAME is the (base) name used in the configure script. # VALUE may be 0, 1 or 2 for a computed quote escaped value based on # VARNAME. Any other value will be used directly. m4_define([_LT_DECL], [lt_if_append_uniq([lt_decl_varnames], [$2], [, ], [lt_dict_add_subkey([lt_decl_dict], [$2], [libtool_name], [m4_ifval([$1], [$1], [$2])]) lt_dict_add_subkey([lt_decl_dict], [$2], [value], [$3]) m4_ifval([$4], [lt_dict_add_subkey([lt_decl_dict], [$2], [description], [$4])]) lt_dict_add_subkey([lt_decl_dict], [$2], [tagged?], [m4_ifval([$5], [yes], [no])])]) ]) # _LT_TAGDECL([CONFIGNAME], VARNAME, VALUE, [DESCRIPTION]) # -------------------------------------------------------- m4_define([_LT_TAGDECL], [_LT_DECL([$1], [$2], [$3], [$4], [yes])]) # lt_decl_tag_varnames([SEPARATOR], [VARNAME1...]) # ------------------------------------------------ m4_define([lt_decl_tag_varnames], [_lt_decl_filter([tagged?], [yes], $@)]) # _lt_decl_filter(SUBKEY, VALUE, [SEPARATOR], [VARNAME1..]) # --------------------------------------------------------- m4_define([_lt_decl_filter], [m4_case([$#], [0], [m4_fatal([$0: too few arguments: $#])], [1], [m4_fatal([$0: too few arguments: $#: $1])], [2], [lt_dict_filter([lt_decl_dict], [$1], [$2], [], lt_decl_varnames)], [3], [lt_dict_filter([lt_decl_dict], [$1], [$2], [$3], lt_decl_varnames)], [lt_dict_filter([lt_decl_dict], $@)])[]dnl ]) # lt_decl_quote_varnames([SEPARATOR], [VARNAME1...]) # -------------------------------------------------- m4_define([lt_decl_quote_varnames], [_lt_decl_filter([value], [1], $@)]) # lt_decl_dquote_varnames([SEPARATOR], [VARNAME1...]) # --------------------------------------------------- m4_define([lt_decl_dquote_varnames], [_lt_decl_filter([value], [2], $@)]) # lt_decl_varnames_tagged([SEPARATOR], [VARNAME1...]) # --------------------------------------------------- m4_define([lt_decl_varnames_tagged], [m4_assert([$# <= 2])dnl _$0(m4_quote(m4_default([$1], [[, ]])), m4_ifval([$2], [[$2]], [m4_dquote(lt_decl_tag_varnames)]), m4_split(m4_normalize(m4_quote(_LT_TAGS)), [ ]))]) m4_define([_lt_decl_varnames_tagged], [m4_ifval([$3], [lt_combine([$1], [$2], [_], $3)])]) # lt_decl_all_varnames([SEPARATOR], [VARNAME1...]) # ------------------------------------------------ m4_define([lt_decl_all_varnames], [_$0(m4_quote(m4_default([$1], [[, ]])), m4_if([$2], [], m4_quote(lt_decl_varnames), m4_quote(m4_shift($@))))[]dnl ]) m4_define([_lt_decl_all_varnames], [lt_join($@, lt_decl_varnames_tagged([$1], lt_decl_tag_varnames([[, ]], m4_shift($@))))dnl ]) # _LT_CONFIG_STATUS_DECLARE([VARNAME]) # ------------------------------------ # Quote a variable value, and forward it to `config.status' so that its # declaration there will have the same value as in `configure'. VARNAME # must have a single quote delimited value for this to work. m4_define([_LT_CONFIG_STATUS_DECLARE], [$1='`$ECHO "X$][$1" | $Xsed -e "$delay_single_quote_subst"`']) # _LT_CONFIG_STATUS_DECLARATIONS # ------------------------------ # We delimit libtool config variables with single quotes, so when # we write them to config.status, we have to be sure to quote all # embedded single quotes properly. In configure, this macro expands # each variable declared with _LT_DECL (and _LT_TAGDECL) into: # # ='`$ECHO "X$" | $Xsed -e "$delay_single_quote_subst"`' m4_defun([_LT_CONFIG_STATUS_DECLARATIONS], [m4_foreach([_lt_var], m4_quote(lt_decl_all_varnames), [m4_n([_LT_CONFIG_STATUS_DECLARE(_lt_var)])])]) # _LT_LIBTOOL_TAGS # ---------------- # Output comment and list of tags supported by the script m4_defun([_LT_LIBTOOL_TAGS], [_LT_FORMAT_COMMENT([The names of the tagged configurations supported by this script])dnl available_tags="_LT_TAGS"dnl ]) # _LT_LIBTOOL_DECLARE(VARNAME, [TAG]) # ----------------------------------- # Extract the dictionary values for VARNAME (optionally with TAG) and # expand to a commented shell variable setting: # # # Some comment about what VAR is for. # visible_name=$lt_internal_name m4_define([_LT_LIBTOOL_DECLARE], [_LT_FORMAT_COMMENT(m4_quote(lt_dict_fetch([lt_decl_dict], [$1], [description])))[]dnl m4_pushdef([_libtool_name], m4_quote(lt_dict_fetch([lt_decl_dict], [$1], [libtool_name])))[]dnl m4_case(m4_quote(lt_dict_fetch([lt_decl_dict], [$1], [value])), [0], [_libtool_name=[$]$1], [1], [_libtool_name=$lt_[]$1], [2], [_libtool_name=$lt_[]$1], [_libtool_name=lt_dict_fetch([lt_decl_dict], [$1], [value])])[]dnl m4_ifval([$2], [_$2])[]m4_popdef([_libtool_name])[]dnl ]) # _LT_LIBTOOL_CONFIG_VARS # ----------------------- # Produce commented declarations of non-tagged libtool config variables # suitable for insertion in the LIBTOOL CONFIG section of the `libtool' # script. Tagged libtool config variables (even for the LIBTOOL CONFIG # section) are produced by _LT_LIBTOOL_TAG_VARS. m4_defun([_LT_LIBTOOL_CONFIG_VARS], [m4_foreach([_lt_var], m4_quote(_lt_decl_filter([tagged?], [no], [], lt_decl_varnames)), [m4_n([_LT_LIBTOOL_DECLARE(_lt_var)])])]) # _LT_LIBTOOL_TAG_VARS(TAG) # ------------------------- m4_define([_LT_LIBTOOL_TAG_VARS], [m4_foreach([_lt_var], m4_quote(lt_decl_tag_varnames), [m4_n([_LT_LIBTOOL_DECLARE(_lt_var, [$1])])])]) # _LT_TAGVAR(VARNAME, [TAGNAME]) # ------------------------------ m4_define([_LT_TAGVAR], [m4_ifval([$2], [$1_$2], [$1])]) # _LT_CONFIG_COMMANDS # ------------------- # Send accumulated output to $CONFIG_STATUS. Thanks to the lists of # variables for single and double quote escaping we saved from calls # to _LT_DECL, we can put quote escaped variables declarations # into `config.status', and then the shell code to quote escape them in # for loops in `config.status'. Finally, any additional code accumulated # from calls to _LT_CONFIG_LIBTOOL_INIT is expanded. m4_defun([_LT_CONFIG_COMMANDS], [AC_PROVIDE_IFELSE([LT_OUTPUT], dnl If the libtool generation code has been placed in $CONFIG_LT, dnl instead of duplicating it all over again into config.status, dnl then we will have config.status run $CONFIG_LT later, so it dnl needs to know what name is stored there: [AC_CONFIG_COMMANDS([libtool], [$SHELL $CONFIG_LT || AS_EXIT(1)], [CONFIG_LT='$CONFIG_LT'])], dnl If the libtool generation code is destined for config.status, dnl expand the accumulated commands and init code now: [AC_CONFIG_COMMANDS([libtool], [_LT_OUTPUT_LIBTOOL_COMMANDS], [_LT_OUTPUT_LIBTOOL_COMMANDS_INIT])]) ])#_LT_CONFIG_COMMANDS # Initialize. m4_define([_LT_OUTPUT_LIBTOOL_COMMANDS_INIT], [ # The HP-UX ksh and POSIX shell print the target directory to stdout # if CDPATH is set. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH sed_quote_subst='$sed_quote_subst' double_quote_subst='$double_quote_subst' delay_variable_subst='$delay_variable_subst' _LT_CONFIG_STATUS_DECLARATIONS LTCC='$LTCC' LTCFLAGS='$LTCFLAGS' compiler='$compiler_DEFAULT' # Quote evaled strings. for var in lt_decl_all_varnames([[ \ ]], lt_decl_quote_varnames); do case \`eval \\\\\$ECHO "X\\\\\$\$var"\` in *[[\\\\\\\`\\"\\\$]]*) eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"X\\\$\$var\\" | \\\$Xsed -e \\"\\\$sed_quote_subst\\"\\\`\\\\\\"" ;; *) eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" ;; esac done # Double-quote double-evaled strings. for var in lt_decl_all_varnames([[ \ ]], lt_decl_dquote_varnames); do case \`eval \\\\\$ECHO "X\\\\\$\$var"\` in *[[\\\\\\\`\\"\\\$]]*) eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"X\\\$\$var\\" | \\\$Xsed -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\"" ;; *) eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" ;; esac done # Fix-up fallback echo if it was mangled by the above quoting rules. case \$lt_ECHO in *'\\\[$]0 --fallback-echo"')dnl " lt_ECHO=\`\$ECHO "X\$lt_ECHO" | \$Xsed -e 's/\\\\\\\\\\\\\\\[$]0 --fallback-echo"\[$]/\[$]0 --fallback-echo"/'\` ;; esac _LT_OUTPUT_LIBTOOL_INIT ]) # LT_OUTPUT # --------- # This macro allows early generation of the libtool script (before # AC_OUTPUT is called), incase it is used in configure for compilation # tests. AC_DEFUN([LT_OUTPUT], [: ${CONFIG_LT=./config.lt} AC_MSG_NOTICE([creating $CONFIG_LT]) cat >"$CONFIG_LT" <<_LTEOF #! $SHELL # Generated by $as_me. # Run this file to recreate a libtool stub with the current configuration. lt_cl_silent=false SHELL=\${CONFIG_SHELL-$SHELL} _LTEOF cat >>"$CONFIG_LT" <<\_LTEOF AS_SHELL_SANITIZE _AS_PREPARE exec AS_MESSAGE_FD>&1 exec AS_MESSAGE_LOG_FD>>config.log { echo AS_BOX([Running $as_me.]) } >&AS_MESSAGE_LOG_FD lt_cl_help="\ \`$as_me' creates a local libtool stub from the current configuration, for use in further configure time tests before the real libtool is generated. Usage: $[0] [[OPTIONS]] -h, --help print this help, then exit -V, --version print version number, then exit -q, --quiet do not print progress messages -d, --debug don't remove temporary files Report bugs to ." lt_cl_version="\ m4_ifset([AC_PACKAGE_NAME], [AC_PACKAGE_NAME ])config.lt[]dnl m4_ifset([AC_PACKAGE_VERSION], [ AC_PACKAGE_VERSION]) configured by $[0], generated by m4_PACKAGE_STRING. Copyright (C) 2008 Free Software Foundation, Inc. This config.lt script is free software; the Free Software Foundation gives unlimited permision to copy, distribute and modify it." while test $[#] != 0 do case $[1] in --version | --v* | -V ) echo "$lt_cl_version"; exit 0 ;; --help | --h* | -h ) echo "$lt_cl_help"; exit 0 ;; --debug | --d* | -d ) debug=: ;; --quiet | --q* | --silent | --s* | -q ) lt_cl_silent=: ;; -*) AC_MSG_ERROR([unrecognized option: $[1] Try \`$[0] --help' for more information.]) ;; *) AC_MSG_ERROR([unrecognized argument: $[1] Try \`$[0] --help' for more information.]) ;; esac shift done if $lt_cl_silent; then exec AS_MESSAGE_FD>/dev/null fi _LTEOF cat >>"$CONFIG_LT" <<_LTEOF _LT_OUTPUT_LIBTOOL_COMMANDS_INIT _LTEOF cat >>"$CONFIG_LT" <<\_LTEOF AC_MSG_NOTICE([creating $ofile]) _LT_OUTPUT_LIBTOOL_COMMANDS AS_EXIT(0) _LTEOF chmod +x "$CONFIG_LT" # configure is writing to config.log, but config.lt does its own redirection, # appending to config.log, which fails on DOS, as config.log is still kept # open by configure. Here we exec the FD to /dev/null, effectively closing # config.log, so it can be properly (re)opened and appended to by config.lt. if test "$no_create" != yes; then lt_cl_success=: test "$silent" = yes && lt_config_lt_args="$lt_config_lt_args --quiet" exec AS_MESSAGE_LOG_FD>/dev/null $SHELL "$CONFIG_LT" $lt_config_lt_args || lt_cl_success=false exec AS_MESSAGE_LOG_FD>>config.log $lt_cl_success || AS_EXIT(1) fi ])# LT_OUTPUT # _LT_CONFIG(TAG) # --------------- # If TAG is the built-in tag, create an initial libtool script with a # default configuration from the untagged config vars. Otherwise add code # to config.status for appending the configuration named by TAG from the # matching tagged config vars. m4_defun([_LT_CONFIG], [m4_require([_LT_FILEUTILS_DEFAULTS])dnl _LT_CONFIG_SAVE_COMMANDS([ m4_define([_LT_TAG], m4_if([$1], [], [C], [$1]))dnl m4_if(_LT_TAG, [C], [ # See if we are running on zsh, and set the options which allow our # commands through without removal of \ escapes. if test -n "${ZSH_VERSION+set}" ; then setopt NO_GLOB_SUBST fi cfgfile="${ofile}T" trap "$RM \"$cfgfile\"; exit 1" 1 2 15 $RM "$cfgfile" cat <<_LT_EOF >> "$cfgfile" #! $SHELL # `$ECHO "$ofile" | sed 's%^.*/%%'` - Provide generalized library-building support services. # Generated automatically by $as_me ($PACKAGE$TIMESTAMP) $VERSION # Libtool was configured on host `(hostname || uname -n) 2>/dev/null | sed 1q`: # NOTE: Changes made to this file will be lost: look at ltmain.sh. # _LT_COPYING _LT_LIBTOOL_TAGS # ### BEGIN LIBTOOL CONFIG _LT_LIBTOOL_CONFIG_VARS _LT_LIBTOOL_TAG_VARS # ### END LIBTOOL CONFIG _LT_EOF case $host_os in aix3*) cat <<\_LT_EOF >> "$cfgfile" # AIX sometimes has problems with the GCC collect2 program. For some # reason, if we set the COLLECT_NAMES environment variable, the problems # vanish in a puff of smoke. if test "X${COLLECT_NAMES+set}" != Xset; then COLLECT_NAMES= export COLLECT_NAMES fi _LT_EOF ;; esac _LT_PROG_LTMAIN # We use sed instead of cat because bash on DJGPP gets confused if # if finds mixed CR/LF and LF-only lines. Since sed operates in # text mode, it properly converts lines to CR/LF. This bash problem # is reportedly fixed, but why not run on old versions too? sed '/^# Generated shell functions inserted here/q' "$ltmain" >> "$cfgfile" \ || (rm -f "$cfgfile"; exit 1) _LT_PROG_XSI_SHELLFNS sed -n '/^# Generated shell functions inserted here/,$p' "$ltmain" >> "$cfgfile" \ || (rm -f "$cfgfile"; exit 1) mv -f "$cfgfile" "$ofile" || (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile") chmod +x "$ofile" ], [cat <<_LT_EOF >> "$ofile" dnl Unfortunately we have to use $1 here, since _LT_TAG is not expanded dnl in a comment (ie after a #). # ### BEGIN LIBTOOL TAG CONFIG: $1 _LT_LIBTOOL_TAG_VARS(_LT_TAG) # ### END LIBTOOL TAG CONFIG: $1 _LT_EOF ])dnl /m4_if ], [m4_if([$1], [], [ PACKAGE='$PACKAGE' VERSION='$VERSION' TIMESTAMP='$TIMESTAMP' RM='$RM' ofile='$ofile'], []) ])dnl /_LT_CONFIG_SAVE_COMMANDS ])# _LT_CONFIG # LT_SUPPORTED_TAG(TAG) # --------------------- # Trace this macro to discover what tags are supported by the libtool # --tag option, using: # autoconf --trace 'LT_SUPPORTED_TAG:$1' AC_DEFUN([LT_SUPPORTED_TAG], []) # C support is built-in for now m4_define([_LT_LANG_C_enabled], []) m4_define([_LT_TAGS], []) # LT_LANG(LANG) # ------------- # Enable libtool support for the given language if not already enabled. AC_DEFUN([LT_LANG], [AC_BEFORE([$0], [LT_OUTPUT])dnl m4_case([$1], [C], [_LT_LANG(C)], [C++], [_LT_LANG(CXX)], [Java], [_LT_LANG(GCJ)], [Fortran 77], [_LT_LANG(F77)], [Fortran], [_LT_LANG(FC)], [Windows Resource], [_LT_LANG(RC)], [m4_ifdef([_LT_LANG_]$1[_CONFIG], [_LT_LANG($1)], [m4_fatal([$0: unsupported language: "$1"])])])dnl ])# LT_LANG # _LT_LANG(LANGNAME) # ------------------ m4_defun([_LT_LANG], [m4_ifdef([_LT_LANG_]$1[_enabled], [], [LT_SUPPORTED_TAG([$1])dnl m4_append([_LT_TAGS], [$1 ])dnl m4_define([_LT_LANG_]$1[_enabled], [])dnl _LT_LANG_$1_CONFIG($1)])dnl ])# _LT_LANG # _LT_LANG_DEFAULT_CONFIG # ----------------------- m4_defun([_LT_LANG_DEFAULT_CONFIG], [AC_PROVIDE_IFELSE([AC_PROG_CXX], [LT_LANG(CXX)], [m4_define([AC_PROG_CXX], defn([AC_PROG_CXX])[LT_LANG(CXX)])]) AC_PROVIDE_IFELSE([AC_PROG_F77], [LT_LANG(F77)], [m4_define([AC_PROG_F77], defn([AC_PROG_F77])[LT_LANG(F77)])]) AC_PROVIDE_IFELSE([AC_PROG_FC], [LT_LANG(FC)], [m4_define([AC_PROG_FC], defn([AC_PROG_FC])[LT_LANG(FC)])]) dnl The call to [A][M_PROG_GCJ] is quoted like that to stop aclocal dnl pulling things in needlessly. AC_PROVIDE_IFELSE([AC_PROG_GCJ], [LT_LANG(GCJ)], [AC_PROVIDE_IFELSE([A][M_PROG_GCJ], [LT_LANG(GCJ)], [AC_PROVIDE_IFELSE([LT_PROG_GCJ], [LT_LANG(GCJ)], [m4_ifdef([AC_PROG_GCJ], [m4_define([AC_PROG_GCJ], defn([AC_PROG_GCJ])[LT_LANG(GCJ)])]) m4_ifdef([A][M_PROG_GCJ], [m4_define([A][M_PROG_GCJ], defn([A][M_PROG_GCJ])[LT_LANG(GCJ)])]) m4_ifdef([LT_PROG_GCJ], [m4_define([LT_PROG_GCJ], defn([LT_PROG_GCJ])[LT_LANG(GCJ)])])])])]) AC_PROVIDE_IFELSE([LT_PROG_RC], [LT_LANG(RC)], [m4_define([LT_PROG_RC], defn([LT_PROG_RC])[LT_LANG(RC)])]) ])# _LT_LANG_DEFAULT_CONFIG # Obsolete macros: AU_DEFUN([AC_LIBTOOL_CXX], [LT_LANG(C++)]) AU_DEFUN([AC_LIBTOOL_F77], [LT_LANG(Fortran 77)]) AU_DEFUN([AC_LIBTOOL_FC], [LT_LANG(Fortran)]) AU_DEFUN([AC_LIBTOOL_GCJ], [LT_LANG(Java)]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_LIBTOOL_CXX], []) dnl AC_DEFUN([AC_LIBTOOL_F77], []) dnl AC_DEFUN([AC_LIBTOOL_FC], []) dnl AC_DEFUN([AC_LIBTOOL_GCJ], []) # _LT_TAG_COMPILER # ---------------- m4_defun([_LT_TAG_COMPILER], [AC_REQUIRE([AC_PROG_CC])dnl _LT_DECL([LTCC], [CC], [1], [A C compiler])dnl _LT_DECL([LTCFLAGS], [CFLAGS], [1], [LTCC compiler flags])dnl _LT_TAGDECL([CC], [compiler], [1], [A language specific compiler])dnl _LT_TAGDECL([with_gcc], [GCC], [0], [Is the compiler the GNU compiler?])dnl # If no C compiler was specified, use CC. LTCC=${LTCC-"$CC"} # If no C compiler flags were specified, use CFLAGS. LTCFLAGS=${LTCFLAGS-"$CFLAGS"} # Allow CC to be a program name with arguments. compiler=$CC ])# _LT_TAG_COMPILER # _LT_COMPILER_BOILERPLATE # ------------------------ # Check for compiler boilerplate output or warnings with # the simple compiler test code. m4_defun([_LT_COMPILER_BOILERPLATE], [m4_require([_LT_DECL_SED])dnl ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" >conftest.$ac_ext eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err _lt_compiler_boilerplate=`cat conftest.err` $RM conftest* ])# _LT_COMPILER_BOILERPLATE # _LT_LINKER_BOILERPLATE # ---------------------- # Check for linker boilerplate output or warnings with # the simple link test code. m4_defun([_LT_LINKER_BOILERPLATE], [m4_require([_LT_DECL_SED])dnl ac_outfile=conftest.$ac_objext echo "$lt_simple_link_test_code" >conftest.$ac_ext eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err _lt_linker_boilerplate=`cat conftest.err` $RM -r conftest* ])# _LT_LINKER_BOILERPLATE # _LT_REQUIRED_DARWIN_CHECKS # ------------------------- m4_defun_once([_LT_REQUIRED_DARWIN_CHECKS],[ case $host_os in rhapsody* | darwin*) AC_CHECK_TOOL([DSYMUTIL], [dsymutil], [:]) AC_CHECK_TOOL([NMEDIT], [nmedit], [:]) AC_CHECK_TOOL([LIPO], [lipo], [:]) AC_CHECK_TOOL([OTOOL], [otool], [:]) AC_CHECK_TOOL([OTOOL64], [otool64], [:]) _LT_DECL([], [DSYMUTIL], [1], [Tool to manipulate archived DWARF debug symbol files on Mac OS X]) _LT_DECL([], [NMEDIT], [1], [Tool to change global to local symbols on Mac OS X]) _LT_DECL([], [LIPO], [1], [Tool to manipulate fat objects and archives on Mac OS X]) _LT_DECL([], [OTOOL], [1], [ldd/readelf like tool for Mach-O binaries on Mac OS X]) _LT_DECL([], [OTOOL64], [1], [ldd/readelf like tool for 64 bit Mach-O binaries on Mac OS X 10.4]) AC_CACHE_CHECK([for -single_module linker flag],[lt_cv_apple_cc_single_mod], [lt_cv_apple_cc_single_mod=no if test -z "${LT_MULTI_MODULE}"; then # By default we will add the -single_module flag. You can override # by either setting the environment variable LT_MULTI_MODULE # non-empty at configure time, or by adding -multi_module to the # link flags. rm -rf libconftest.dylib* echo "int foo(void){return 1;}" > conftest.c echo "$LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ -dynamiclib -Wl,-single_module conftest.c" >&AS_MESSAGE_LOG_FD $LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ -dynamiclib -Wl,-single_module conftest.c 2>conftest.err _lt_result=$? if test -f libconftest.dylib && test ! -s conftest.err && test $_lt_result = 0; then lt_cv_apple_cc_single_mod=yes else cat conftest.err >&AS_MESSAGE_LOG_FD fi rm -rf libconftest.dylib* rm -f conftest.* fi]) AC_CACHE_CHECK([for -exported_symbols_list linker flag], [lt_cv_ld_exported_symbols_list], [lt_cv_ld_exported_symbols_list=no save_LDFLAGS=$LDFLAGS echo "_main" > conftest.sym LDFLAGS="$LDFLAGS -Wl,-exported_symbols_list,conftest.sym" AC_LINK_IFELSE([AC_LANG_PROGRAM([],[])], [lt_cv_ld_exported_symbols_list=yes], [lt_cv_ld_exported_symbols_list=no]) LDFLAGS="$save_LDFLAGS" ]) case $host_os in rhapsody* | darwin1.[[012]]) _lt_dar_allow_undefined='${wl}-undefined ${wl}suppress' ;; darwin1.*) _lt_dar_allow_undefined='${wl}-flat_namespace ${wl}-undefined ${wl}suppress' ;; darwin*) # darwin 5.x on # if running on 10.5 or later, the deployment target defaults # to the OS version, if on x86, and 10.4, the deployment # target defaults to 10.4. Don't you love it? case ${MACOSX_DEPLOYMENT_TARGET-10.0},$host in 10.0,*86*-darwin8*|10.0,*-darwin[[91]]*) _lt_dar_allow_undefined='${wl}-undefined ${wl}dynamic_lookup' ;; 10.[[012]]*) _lt_dar_allow_undefined='${wl}-flat_namespace ${wl}-undefined ${wl}suppress' ;; 10.*) _lt_dar_allow_undefined='${wl}-undefined ${wl}dynamic_lookup' ;; esac ;; esac if test "$lt_cv_apple_cc_single_mod" = "yes"; then _lt_dar_single_mod='$single_module' fi if test "$lt_cv_ld_exported_symbols_list" = "yes"; then _lt_dar_export_syms=' ${wl}-exported_symbols_list,$output_objdir/${libname}-symbols.expsym' else _lt_dar_export_syms='~$NMEDIT -s $output_objdir/${libname}-symbols.expsym ${lib}' fi if test "$DSYMUTIL" != ":"; then _lt_dsymutil='~$DSYMUTIL $lib || :' else _lt_dsymutil= fi ;; esac ]) # _LT_DARWIN_LINKER_FEATURES # -------------------------- # Checks for linker and compiler features on darwin m4_defun([_LT_DARWIN_LINKER_FEATURES], [ m4_require([_LT_REQUIRED_DARWIN_CHECKS]) _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(hardcode_direct, $1)=no _LT_TAGVAR(hardcode_automatic, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=unsupported _LT_TAGVAR(whole_archive_flag_spec, $1)='' _LT_TAGVAR(link_all_deplibs, $1)=yes _LT_TAGVAR(allow_undefined_flag, $1)="$_lt_dar_allow_undefined" case $cc_basename in ifort*) _lt_dar_can_shared=yes ;; *) _lt_dar_can_shared=$GCC ;; esac if test "$_lt_dar_can_shared" = "yes"; then output_verbose_link_cmd=echo _LT_TAGVAR(archive_cmds, $1)="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod${_lt_dsymutil}" _LT_TAGVAR(module_cmds, $1)="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dsymutil}" _LT_TAGVAR(archive_expsym_cmds, $1)="sed 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring ${_lt_dar_single_mod}${_lt_dar_export_syms}${_lt_dsymutil}" _LT_TAGVAR(module_expsym_cmds, $1)="sed -e 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dar_export_syms}${_lt_dsymutil}" m4_if([$1], [CXX], [ if test "$lt_cv_apple_cc_single_mod" != "yes"; then _LT_TAGVAR(archive_cmds, $1)="\$CC -r -keep_private_externs -nostdlib -o \${lib}-master.o \$libobjs~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \${lib}-master.o \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring${_lt_dsymutil}" _LT_TAGVAR(archive_expsym_cmds, $1)="sed 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC -r -keep_private_externs -nostdlib -o \${lib}-master.o \$libobjs~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \${lib}-master.o \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring${_lt_dar_export_syms}${_lt_dsymutil}" fi ],[]) else _LT_TAGVAR(ld_shlibs, $1)=no fi ]) # _LT_SYS_MODULE_PATH_AIX # ----------------------- # Links a minimal program and checks the executable # for the system default hardcoded library path. In most cases, # this is /usr/lib:/lib, but when the MPI compilers are used # the location of the communication and MPI libs are included too. # If we don't find anything, use the default library path according # to the aix ld manual. m4_defun([_LT_SYS_MODULE_PATH_AIX], [m4_require([_LT_DECL_SED])dnl AC_LINK_IFELSE(AC_LANG_PROGRAM,[ lt_aix_libpath_sed=' /Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/ p } }' aix_libpath=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` # Check for a 64-bit object if we didn't find anything. if test -z "$aix_libpath"; then aix_libpath=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` fi],[]) if test -z "$aix_libpath"; then aix_libpath="/usr/lib:/lib"; fi ])# _LT_SYS_MODULE_PATH_AIX # _LT_SHELL_INIT(ARG) # ------------------- m4_define([_LT_SHELL_INIT], [ifdef([AC_DIVERSION_NOTICE], [AC_DIVERT_PUSH(AC_DIVERSION_NOTICE)], [AC_DIVERT_PUSH(NOTICE)]) $1 AC_DIVERT_POP ])# _LT_SHELL_INIT # _LT_PROG_ECHO_BACKSLASH # ----------------------- # Add some code to the start of the generated configure script which # will find an echo command which doesn't interpret backslashes. m4_defun([_LT_PROG_ECHO_BACKSLASH], [_LT_SHELL_INIT([ # Check that we are running under the correct shell. SHELL=${CONFIG_SHELL-/bin/sh} case X$lt_ECHO in X*--fallback-echo) # Remove one level of quotation (which was required for Make). ECHO=`echo "$lt_ECHO" | sed 's,\\\\\[$]\\[$]0,'[$]0','` ;; esac ECHO=${lt_ECHO-echo} if test "X[$]1" = X--no-reexec; then # Discard the --no-reexec flag, and continue. shift elif test "X[$]1" = X--fallback-echo; then # Avoid inline document here, it may be left over : elif test "X`{ $ECHO '\t'; } 2>/dev/null`" = 'X\t' ; then # Yippee, $ECHO works! : else # Restart under the correct shell. exec $SHELL "[$]0" --no-reexec ${1+"[$]@"} fi if test "X[$]1" = X--fallback-echo; then # used as fallback echo shift cat <<_LT_EOF [$]* _LT_EOF exit 0 fi # The HP-UX ksh and POSIX shell print the target directory to stdout # if CDPATH is set. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH if test -z "$lt_ECHO"; then if test "X${echo_test_string+set}" != Xset; then # find a string as large as possible, as long as the shell can cope with it for cmd in 'sed 50q "[$]0"' 'sed 20q "[$]0"' 'sed 10q "[$]0"' 'sed 2q "[$]0"' 'echo test'; do # expected sizes: less than 2Kb, 1Kb, 512 bytes, 16 bytes, ... if { echo_test_string=`eval $cmd`; } 2>/dev/null && { test "X$echo_test_string" = "X$echo_test_string"; } 2>/dev/null then break fi done fi if test "X`{ $ECHO '\t'; } 2>/dev/null`" = 'X\t' && echo_testing_string=`{ $ECHO "$echo_test_string"; } 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then : else # The Solaris, AIX, and Digital Unix default echo programs unquote # backslashes. This makes it impossible to quote backslashes using # echo "$something" | sed 's/\\/\\\\/g' # # So, first we look for a working echo in the user's PATH. lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR for dir in $PATH /usr/ucb; do IFS="$lt_save_ifs" if (test -f $dir/echo || test -f $dir/echo$ac_exeext) && test "X`($dir/echo '\t') 2>/dev/null`" = 'X\t' && echo_testing_string=`($dir/echo "$echo_test_string") 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then ECHO="$dir/echo" break fi done IFS="$lt_save_ifs" if test "X$ECHO" = Xecho; then # We didn't find a better echo, so look for alternatives. if test "X`{ print -r '\t'; } 2>/dev/null`" = 'X\t' && echo_testing_string=`{ print -r "$echo_test_string"; } 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then # This shell has a builtin print -r that does the trick. ECHO='print -r' elif { test -f /bin/ksh || test -f /bin/ksh$ac_exeext; } && test "X$CONFIG_SHELL" != X/bin/ksh; then # If we have ksh, try running configure again with it. ORIGINAL_CONFIG_SHELL=${CONFIG_SHELL-/bin/sh} export ORIGINAL_CONFIG_SHELL CONFIG_SHELL=/bin/ksh export CONFIG_SHELL exec $CONFIG_SHELL "[$]0" --no-reexec ${1+"[$]@"} else # Try using printf. ECHO='printf %s\n' if test "X`{ $ECHO '\t'; } 2>/dev/null`" = 'X\t' && echo_testing_string=`{ $ECHO "$echo_test_string"; } 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then # Cool, printf works : elif echo_testing_string=`($ORIGINAL_CONFIG_SHELL "[$]0" --fallback-echo '\t') 2>/dev/null` && test "X$echo_testing_string" = 'X\t' && echo_testing_string=`($ORIGINAL_CONFIG_SHELL "[$]0" --fallback-echo "$echo_test_string") 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then CONFIG_SHELL=$ORIGINAL_CONFIG_SHELL export CONFIG_SHELL SHELL="$CONFIG_SHELL" export SHELL ECHO="$CONFIG_SHELL [$]0 --fallback-echo" elif echo_testing_string=`($CONFIG_SHELL "[$]0" --fallback-echo '\t') 2>/dev/null` && test "X$echo_testing_string" = 'X\t' && echo_testing_string=`($CONFIG_SHELL "[$]0" --fallback-echo "$echo_test_string") 2>/dev/null` && test "X$echo_testing_string" = "X$echo_test_string"; then ECHO="$CONFIG_SHELL [$]0 --fallback-echo" else # maybe with a smaller string... prev=: for cmd in 'echo test' 'sed 2q "[$]0"' 'sed 10q "[$]0"' 'sed 20q "[$]0"' 'sed 50q "[$]0"'; do if { test "X$echo_test_string" = "X`eval $cmd`"; } 2>/dev/null then break fi prev="$cmd" done if test "$prev" != 'sed 50q "[$]0"'; then echo_test_string=`eval $prev` export echo_test_string exec ${ORIGINAL_CONFIG_SHELL-${CONFIG_SHELL-/bin/sh}} "[$]0" ${1+"[$]@"} else # Oops. We lost completely, so just stick with echo. ECHO=echo fi fi fi fi fi fi # Copy echo and quote the copy suitably for passing to libtool from # the Makefile, instead of quoting the original, which is used later. lt_ECHO=$ECHO if test "X$lt_ECHO" = "X$CONFIG_SHELL [$]0 --fallback-echo"; then lt_ECHO="$CONFIG_SHELL \\\$\[$]0 --fallback-echo" fi AC_SUBST(lt_ECHO) ]) _LT_DECL([], [SHELL], [1], [Shell to use when invoking shell scripts]) _LT_DECL([], [ECHO], [1], [An echo program that does not interpret backslashes]) ])# _LT_PROG_ECHO_BACKSLASH # _LT_ENABLE_LOCK # --------------- m4_defun([_LT_ENABLE_LOCK], [AC_ARG_ENABLE([libtool-lock], [AS_HELP_STRING([--disable-libtool-lock], [avoid locking (might break parallel builds)])]) test "x$enable_libtool_lock" != xno && enable_libtool_lock=yes # Some flags need to be propagated to the compiler or linker for good # libtool support. case $host in ia64-*-hpux*) # Find out which ABI we are using. echo 'int i;' > conftest.$ac_ext if AC_TRY_EVAL(ac_compile); then case `/usr/bin/file conftest.$ac_objext` in *ELF-32*) HPUX_IA64_MODE="32" ;; *ELF-64*) HPUX_IA64_MODE="64" ;; esac fi rm -rf conftest* ;; *-*-irix6*) # Find out which ABI we are using. echo '[#]line __oline__ "configure"' > conftest.$ac_ext if AC_TRY_EVAL(ac_compile); then if test "$lt_cv_prog_gnu_ld" = yes; then case `/usr/bin/file conftest.$ac_objext` in *32-bit*) LD="${LD-ld} -melf32bsmip" ;; *N32*) LD="${LD-ld} -melf32bmipn32" ;; *64-bit*) LD="${LD-ld} -melf64bmip" ;; esac else case `/usr/bin/file conftest.$ac_objext` in *32-bit*) LD="${LD-ld} -32" ;; *N32*) LD="${LD-ld} -n32" ;; *64-bit*) LD="${LD-ld} -64" ;; esac fi fi rm -rf conftest* ;; x86_64-*kfreebsd*-gnu|x86_64-*linux*|ppc*-*linux*|powerpc*-*linux*| \ s390*-*linux*|s390*-*tpf*|sparc*-*linux*) # Find out which ABI we are using. echo 'int i;' > conftest.$ac_ext if AC_TRY_EVAL(ac_compile); then case `/usr/bin/file conftest.o` in *32-bit*) case $host in x86_64-*kfreebsd*-gnu) LD="${LD-ld} -m elf_i386_fbsd" ;; x86_64-*linux*) LD="${LD-ld} -m elf_i386" ;; ppc64-*linux*|powerpc64-*linux*) LD="${LD-ld} -m elf32ppclinux" ;; s390x-*linux*) LD="${LD-ld} -m elf_s390" ;; sparc64-*linux*) LD="${LD-ld} -m elf32_sparc" ;; esac ;; *64-bit*) case $host in x86_64-*kfreebsd*-gnu) LD="${LD-ld} -m elf_x86_64_fbsd" ;; x86_64-*linux*) LD="${LD-ld} -m elf_x86_64" ;; ppc*-*linux*|powerpc*-*linux*) LD="${LD-ld} -m elf64ppc" ;; s390*-*linux*|s390*-*tpf*) LD="${LD-ld} -m elf64_s390" ;; sparc*-*linux*) LD="${LD-ld} -m elf64_sparc" ;; esac ;; esac fi rm -rf conftest* ;; *-*-sco3.2v5*) # On SCO OpenServer 5, we need -belf to get full-featured binaries. SAVE_CFLAGS="$CFLAGS" CFLAGS="$CFLAGS -belf" AC_CACHE_CHECK([whether the C compiler needs -belf], lt_cv_cc_needs_belf, [AC_LANG_PUSH(C) AC_LINK_IFELSE([AC_LANG_PROGRAM([[]],[[]])],[lt_cv_cc_needs_belf=yes],[lt_cv_cc_needs_belf=no]) AC_LANG_POP]) if test x"$lt_cv_cc_needs_belf" != x"yes"; then # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf CFLAGS="$SAVE_CFLAGS" fi ;; sparc*-*solaris*) # Find out which ABI we are using. echo 'int i;' > conftest.$ac_ext if AC_TRY_EVAL(ac_compile); then case `/usr/bin/file conftest.o` in *64-bit*) case $lt_cv_prog_gnu_ld in yes*) LD="${LD-ld} -m elf64_sparc" ;; *) if ${LD-ld} -64 -r -o conftest2.o conftest.o >/dev/null 2>&1; then LD="${LD-ld} -64" fi ;; esac ;; esac fi rm -rf conftest* ;; esac need_locks="$enable_libtool_lock" ])# _LT_ENABLE_LOCK # _LT_CMD_OLD_ARCHIVE # ------------------- m4_defun([_LT_CMD_OLD_ARCHIVE], [AC_CHECK_TOOL(AR, ar, false) test -z "$AR" && AR=ar test -z "$AR_FLAGS" && AR_FLAGS=cru _LT_DECL([], [AR], [1], [The archiver]) _LT_DECL([], [AR_FLAGS], [1]) AC_CHECK_TOOL(STRIP, strip, :) test -z "$STRIP" && STRIP=: _LT_DECL([], [STRIP], [1], [A symbol stripping program]) AC_CHECK_TOOL(RANLIB, ranlib, :) test -z "$RANLIB" && RANLIB=: _LT_DECL([], [RANLIB], [1], [Commands used to install an old-style archive]) # Determine commands to create old-style static archives. old_archive_cmds='$AR $AR_FLAGS $oldlib$oldobjs' old_postinstall_cmds='chmod 644 $oldlib' old_postuninstall_cmds= if test -n "$RANLIB"; then case $host_os in openbsd*) old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$oldlib" ;; *) old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$oldlib" ;; esac old_archive_cmds="$old_archive_cmds~\$RANLIB \$oldlib" fi _LT_DECL([], [old_postinstall_cmds], [2]) _LT_DECL([], [old_postuninstall_cmds], [2]) _LT_TAGDECL([], [old_archive_cmds], [2], [Commands used to build an old-style archive]) ])# _LT_CMD_OLD_ARCHIVE # _LT_COMPILER_OPTION(MESSAGE, VARIABLE-NAME, FLAGS, # [OUTPUT-FILE], [ACTION-SUCCESS], [ACTION-FAILURE]) # ---------------------------------------------------------------- # Check whether the given compiler option works AC_DEFUN([_LT_COMPILER_OPTION], [m4_require([_LT_FILEUTILS_DEFAULTS])dnl m4_require([_LT_DECL_SED])dnl AC_CACHE_CHECK([$1], [$2], [$2=no m4_if([$4], , [ac_outfile=conftest.$ac_objext], [ac_outfile=$4]) echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="$3" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. # The option is referenced via a variable to avoid confusing sed. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [[^ ]]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:__oline__: $lt_compile\"" >&AS_MESSAGE_LOG_FD) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&AS_MESSAGE_LOG_FD echo "$as_me:__oline__: \$? = $ac_status" >&AS_MESSAGE_LOG_FD if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. $ECHO "X$_lt_compiler_boilerplate" | $Xsed -e '/^$/d' >conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then $2=yes fi fi $RM conftest* ]) if test x"[$]$2" = xyes; then m4_if([$5], , :, [$5]) else m4_if([$6], , :, [$6]) fi ])# _LT_COMPILER_OPTION # Old name: AU_ALIAS([AC_LIBTOOL_COMPILER_OPTION], [_LT_COMPILER_OPTION]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_LIBTOOL_COMPILER_OPTION], []) # _LT_LINKER_OPTION(MESSAGE, VARIABLE-NAME, FLAGS, # [ACTION-SUCCESS], [ACTION-FAILURE]) # ---------------------------------------------------- # Check whether the given linker option works AC_DEFUN([_LT_LINKER_OPTION], [m4_require([_LT_FILEUTILS_DEFAULTS])dnl m4_require([_LT_DECL_SED])dnl AC_CACHE_CHECK([$1], [$2], [$2=no save_LDFLAGS="$LDFLAGS" LDFLAGS="$LDFLAGS $3" echo "$lt_simple_link_test_code" > conftest.$ac_ext if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then # The linker can only warn and ignore the option if not recognized # So say no if there are warnings if test -s conftest.err; then # Append any errors to the config.log. cat conftest.err 1>&AS_MESSAGE_LOG_FD $ECHO "X$_lt_linker_boilerplate" | $Xsed -e '/^$/d' > conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if diff conftest.exp conftest.er2 >/dev/null; then $2=yes fi else $2=yes fi fi $RM -r conftest* LDFLAGS="$save_LDFLAGS" ]) if test x"[$]$2" = xyes; then m4_if([$4], , :, [$4]) else m4_if([$5], , :, [$5]) fi ])# _LT_LINKER_OPTION # Old name: AU_ALIAS([AC_LIBTOOL_LINKER_OPTION], [_LT_LINKER_OPTION]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_LIBTOOL_LINKER_OPTION], []) # LT_CMD_MAX_LEN #--------------- AC_DEFUN([LT_CMD_MAX_LEN], [AC_REQUIRE([AC_CANONICAL_HOST])dnl # find the maximum length of command line arguments AC_MSG_CHECKING([the maximum length of command line arguments]) AC_CACHE_VAL([lt_cv_sys_max_cmd_len], [dnl i=0 teststring="ABCD" case $build_os in msdosdjgpp*) # On DJGPP, this test can blow up pretty badly due to problems in libc # (any single argument exceeding 2000 bytes causes a buffer overrun # during glob expansion). Even if it were fixed, the result of this # check would be larger than it should be. lt_cv_sys_max_cmd_len=12288; # 12K is about right ;; gnu*) # Under GNU Hurd, this test is not required because there is # no limit to the length of command line arguments. # Libtool will interpret -1 as no limit whatsoever lt_cv_sys_max_cmd_len=-1; ;; cygwin* | mingw* | cegcc*) # On Win9x/ME, this test blows up -- it succeeds, but takes # about 5 minutes as the teststring grows exponentially. # Worse, since 9x/ME are not pre-emptively multitasking, # you end up with a "frozen" computer, even though with patience # the test eventually succeeds (with a max line length of 256k). # Instead, let's just punt: use the minimum linelength reported by # all of the supported platforms: 8192 (on NT/2K/XP). lt_cv_sys_max_cmd_len=8192; ;; amigaos*) # On AmigaOS with pdksh, this test takes hours, literally. # So we just punt and use a minimum line length of 8192. lt_cv_sys_max_cmd_len=8192; ;; netbsd* | freebsd* | openbsd* | darwin* | dragonfly*) # This has been around since 386BSD, at least. Likely further. if test -x /sbin/sysctl; then lt_cv_sys_max_cmd_len=`/sbin/sysctl -n kern.argmax` elif test -x /usr/sbin/sysctl; then lt_cv_sys_max_cmd_len=`/usr/sbin/sysctl -n kern.argmax` else lt_cv_sys_max_cmd_len=65536 # usable default for all BSDs fi # And add a safety zone lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` ;; interix*) # We know the value 262144 and hardcode it with a safety zone (like BSD) lt_cv_sys_max_cmd_len=196608 ;; osf*) # Dr. Hans Ekkehard Plesser reports seeing a kernel panic running configure # due to this test when exec_disable_arg_limit is 1 on Tru64. It is not # nice to cause kernel panics so lets avoid the loop below. # First set a reasonable default. lt_cv_sys_max_cmd_len=16384 # if test -x /sbin/sysconfig; then case `/sbin/sysconfig -q proc exec_disable_arg_limit` in *1*) lt_cv_sys_max_cmd_len=-1 ;; esac fi ;; sco3.2v5*) lt_cv_sys_max_cmd_len=102400 ;; sysv5* | sco5v6* | sysv4.2uw2*) kargmax=`grep ARG_MAX /etc/conf/cf.d/stune 2>/dev/null` if test -n "$kargmax"; then lt_cv_sys_max_cmd_len=`echo $kargmax | sed 's/.*[[ ]]//'` else lt_cv_sys_max_cmd_len=32768 fi ;; *) lt_cv_sys_max_cmd_len=`(getconf ARG_MAX) 2> /dev/null` if test -n "$lt_cv_sys_max_cmd_len"; then lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` else # Make teststring a little bigger before we do anything with it. # a 1K string should be a reasonable start. for i in 1 2 3 4 5 6 7 8 ; do teststring=$teststring$teststring done SHELL=${SHELL-${CONFIG_SHELL-/bin/sh}} # If test is not a shell built-in, we'll probably end up computing a # maximum length that is only half of the actual maximum length, but # we can't tell. while { test "X"`$SHELL [$]0 --fallback-echo "X$teststring$teststring" 2>/dev/null` \ = "XX$teststring$teststring"; } >/dev/null 2>&1 && test $i != 17 # 1/2 MB should be enough do i=`expr $i + 1` teststring=$teststring$teststring done # Only check the string length outside the loop. lt_cv_sys_max_cmd_len=`expr "X$teststring" : ".*" 2>&1` teststring= # Add a significant safety factor because C++ compilers can tack on # massive amounts of additional arguments before passing them to the # linker. It appears as though 1/2 is a usable value. lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 2` fi ;; esac ]) if test -n $lt_cv_sys_max_cmd_len ; then AC_MSG_RESULT($lt_cv_sys_max_cmd_len) else AC_MSG_RESULT(none) fi max_cmd_len=$lt_cv_sys_max_cmd_len _LT_DECL([], [max_cmd_len], [0], [What is the maximum length of a command?]) ])# LT_CMD_MAX_LEN # Old name: AU_ALIAS([AC_LIBTOOL_SYS_MAX_CMD_LEN], [LT_CMD_MAX_LEN]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_LIBTOOL_SYS_MAX_CMD_LEN], []) # _LT_HEADER_DLFCN # ---------------- m4_defun([_LT_HEADER_DLFCN], [AC_CHECK_HEADERS([dlfcn.h], [], [], [AC_INCLUDES_DEFAULT])dnl ])# _LT_HEADER_DLFCN # _LT_TRY_DLOPEN_SELF (ACTION-IF-TRUE, ACTION-IF-TRUE-W-USCORE, # ACTION-IF-FALSE, ACTION-IF-CROSS-COMPILING) # ---------------------------------------------------------------- m4_defun([_LT_TRY_DLOPEN_SELF], [m4_require([_LT_HEADER_DLFCN])dnl if test "$cross_compiling" = yes; then : [$4] else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF [#line __oline__ "configure" #include "confdefs.h" #if HAVE_DLFCN_H #include #endif #include #ifdef RTLD_GLOBAL # define LT_DLGLOBAL RTLD_GLOBAL #else # ifdef DL_GLOBAL # define LT_DLGLOBAL DL_GLOBAL # else # define LT_DLGLOBAL 0 # endif #endif /* We may have to define LT_DLLAZY_OR_NOW in the command line if we find out it does not work in some platform. */ #ifndef LT_DLLAZY_OR_NOW # ifdef RTLD_LAZY # define LT_DLLAZY_OR_NOW RTLD_LAZY # else # ifdef DL_LAZY # define LT_DLLAZY_OR_NOW DL_LAZY # else # ifdef RTLD_NOW # define LT_DLLAZY_OR_NOW RTLD_NOW # else # ifdef DL_NOW # define LT_DLLAZY_OR_NOW DL_NOW # else # define LT_DLLAZY_OR_NOW 0 # endif # endif # endif # endif #endif void fnord() { int i=42;} int main () { void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW); int status = $lt_dlunknown; if (self) { if (dlsym (self,"fnord")) status = $lt_dlno_uscore; else if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore; /* dlclose (self); */ } else puts (dlerror ()); return status; }] _LT_EOF if AC_TRY_EVAL(ac_link) && test -s conftest${ac_exeext} 2>/dev/null; then (./conftest; exit; ) >&AS_MESSAGE_LOG_FD 2>/dev/null lt_status=$? case x$lt_status in x$lt_dlno_uscore) $1 ;; x$lt_dlneed_uscore) $2 ;; x$lt_dlunknown|x*) $3 ;; esac else : # compilation failed $3 fi fi rm -fr conftest* ])# _LT_TRY_DLOPEN_SELF # LT_SYS_DLOPEN_SELF # ------------------ AC_DEFUN([LT_SYS_DLOPEN_SELF], [m4_require([_LT_HEADER_DLFCN])dnl if test "x$enable_dlopen" != xyes; then enable_dlopen=unknown enable_dlopen_self=unknown enable_dlopen_self_static=unknown else lt_cv_dlopen=no lt_cv_dlopen_libs= case $host_os in beos*) lt_cv_dlopen="load_add_on" lt_cv_dlopen_libs= lt_cv_dlopen_self=yes ;; mingw* | pw32* | cegcc*) lt_cv_dlopen="LoadLibrary" lt_cv_dlopen_libs= ;; cygwin*) lt_cv_dlopen="dlopen" lt_cv_dlopen_libs= ;; darwin*) # if libdl is installed we need to link against it AC_CHECK_LIB([dl], [dlopen], [lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-ldl"],[ lt_cv_dlopen="dyld" lt_cv_dlopen_libs= lt_cv_dlopen_self=yes ]) ;; *) AC_CHECK_FUNC([shl_load], [lt_cv_dlopen="shl_load"], [AC_CHECK_LIB([dld], [shl_load], [lt_cv_dlopen="shl_load" lt_cv_dlopen_libs="-ldld"], [AC_CHECK_FUNC([dlopen], [lt_cv_dlopen="dlopen"], [AC_CHECK_LIB([dl], [dlopen], [lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-ldl"], [AC_CHECK_LIB([svld], [dlopen], [lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-lsvld"], [AC_CHECK_LIB([dld], [dld_link], [lt_cv_dlopen="dld_link" lt_cv_dlopen_libs="-ldld"]) ]) ]) ]) ]) ]) ;; esac if test "x$lt_cv_dlopen" != xno; then enable_dlopen=yes else enable_dlopen=no fi case $lt_cv_dlopen in dlopen) save_CPPFLAGS="$CPPFLAGS" test "x$ac_cv_header_dlfcn_h" = xyes && CPPFLAGS="$CPPFLAGS -DHAVE_DLFCN_H" save_LDFLAGS="$LDFLAGS" wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $export_dynamic_flag_spec\" save_LIBS="$LIBS" LIBS="$lt_cv_dlopen_libs $LIBS" AC_CACHE_CHECK([whether a program can dlopen itself], lt_cv_dlopen_self, [dnl _LT_TRY_DLOPEN_SELF( lt_cv_dlopen_self=yes, lt_cv_dlopen_self=yes, lt_cv_dlopen_self=no, lt_cv_dlopen_self=cross) ]) if test "x$lt_cv_dlopen_self" = xyes; then wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $lt_prog_compiler_static\" AC_CACHE_CHECK([whether a statically linked program can dlopen itself], lt_cv_dlopen_self_static, [dnl _LT_TRY_DLOPEN_SELF( lt_cv_dlopen_self_static=yes, lt_cv_dlopen_self_static=yes, lt_cv_dlopen_self_static=no, lt_cv_dlopen_self_static=cross) ]) fi CPPFLAGS="$save_CPPFLAGS" LDFLAGS="$save_LDFLAGS" LIBS="$save_LIBS" ;; esac case $lt_cv_dlopen_self in yes|no) enable_dlopen_self=$lt_cv_dlopen_self ;; *) enable_dlopen_self=unknown ;; esac case $lt_cv_dlopen_self_static in yes|no) enable_dlopen_self_static=$lt_cv_dlopen_self_static ;; *) enable_dlopen_self_static=unknown ;; esac fi _LT_DECL([dlopen_support], [enable_dlopen], [0], [Whether dlopen is supported]) _LT_DECL([dlopen_self], [enable_dlopen_self], [0], [Whether dlopen of programs is supported]) _LT_DECL([dlopen_self_static], [enable_dlopen_self_static], [0], [Whether dlopen of statically linked programs is supported]) ])# LT_SYS_DLOPEN_SELF # Old name: AU_ALIAS([AC_LIBTOOL_DLOPEN_SELF], [LT_SYS_DLOPEN_SELF]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_LIBTOOL_DLOPEN_SELF], []) # _LT_COMPILER_C_O([TAGNAME]) # --------------------------- # Check to see if options -c and -o are simultaneously supported by compiler. # This macro does not hard code the compiler like AC_PROG_CC_C_O. m4_defun([_LT_COMPILER_C_O], [m4_require([_LT_DECL_SED])dnl m4_require([_LT_FILEUTILS_DEFAULTS])dnl m4_require([_LT_TAG_COMPILER])dnl AC_CACHE_CHECK([if $compiler supports -c -o file.$ac_objext], [_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)], [_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)=no $RM -r conftest 2>/dev/null mkdir conftest cd conftest mkdir out echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-o out/conftest2.$ac_objext" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [[^ ]]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:__oline__: $lt_compile\"" >&AS_MESSAGE_LOG_FD) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&AS_MESSAGE_LOG_FD echo "$as_me:__oline__: \$? = $ac_status" >&AS_MESSAGE_LOG_FD if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings $ECHO "X$_lt_compiler_boilerplate" | $Xsed -e '/^$/d' > out/conftest.exp $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then _LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)=yes fi fi chmod u+w . 2>&AS_MESSAGE_LOG_FD $RM conftest* # SGI C++ compiler will create directory out/ii_files/ for # template instantiation test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files $RM out/* && rmdir out cd .. $RM -r conftest $RM conftest* ]) _LT_TAGDECL([compiler_c_o], [lt_cv_prog_compiler_c_o], [1], [Does compiler simultaneously support -c and -o options?]) ])# _LT_COMPILER_C_O # _LT_COMPILER_FILE_LOCKS([TAGNAME]) # ---------------------------------- # Check to see if we can do hard links to lock some files if needed m4_defun([_LT_COMPILER_FILE_LOCKS], [m4_require([_LT_ENABLE_LOCK])dnl m4_require([_LT_FILEUTILS_DEFAULTS])dnl _LT_COMPILER_C_O([$1]) hard_links="nottested" if test "$_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)" = no && test "$need_locks" != no; then # do not overwrite the value of need_locks provided by the user AC_MSG_CHECKING([if we can lock with hard links]) hard_links=yes $RM conftest* ln conftest.a conftest.b 2>/dev/null && hard_links=no touch conftest.a ln conftest.a conftest.b 2>&5 || hard_links=no ln conftest.a conftest.b 2>/dev/null && hard_links=no AC_MSG_RESULT([$hard_links]) if test "$hard_links" = no; then AC_MSG_WARN([`$CC' does not support `-c -o', so `make -j' may be unsafe]) need_locks=warn fi else need_locks=no fi _LT_DECL([], [need_locks], [1], [Must we lock files when doing compilation?]) ])# _LT_COMPILER_FILE_LOCKS # _LT_CHECK_OBJDIR # ---------------- m4_defun([_LT_CHECK_OBJDIR], [AC_CACHE_CHECK([for objdir], [lt_cv_objdir], [rm -f .libs 2>/dev/null mkdir .libs 2>/dev/null if test -d .libs; then lt_cv_objdir=.libs else # MS-DOS does not allow filenames that begin with a dot. lt_cv_objdir=_libs fi rmdir .libs 2>/dev/null]) objdir=$lt_cv_objdir _LT_DECL([], [objdir], [0], [The name of the directory that contains temporary libtool files])dnl m4_pattern_allow([LT_OBJDIR])dnl AC_DEFINE_UNQUOTED(LT_OBJDIR, "$lt_cv_objdir/", [Define to the sub-directory in which libtool stores uninstalled libraries.]) ])# _LT_CHECK_OBJDIR # _LT_LINKER_HARDCODE_LIBPATH([TAGNAME]) # -------------------------------------- # Check hardcoding attributes. m4_defun([_LT_LINKER_HARDCODE_LIBPATH], [AC_MSG_CHECKING([how to hardcode library paths into programs]) _LT_TAGVAR(hardcode_action, $1)= if test -n "$_LT_TAGVAR(hardcode_libdir_flag_spec, $1)" || test -n "$_LT_TAGVAR(runpath_var, $1)" || test "X$_LT_TAGVAR(hardcode_automatic, $1)" = "Xyes" ; then # We can hardcode non-existent directories. if test "$_LT_TAGVAR(hardcode_direct, $1)" != no && # If the only mechanism to avoid hardcoding is shlibpath_var, we # have to relink, otherwise we might link with an installed library # when we should be linking with a yet-to-be-installed one ## test "$_LT_TAGVAR(hardcode_shlibpath_var, $1)" != no && test "$_LT_TAGVAR(hardcode_minus_L, $1)" != no; then # Linking always hardcodes the temporary library directory. _LT_TAGVAR(hardcode_action, $1)=relink else # We can link without hardcoding, and we can hardcode nonexisting dirs. _LT_TAGVAR(hardcode_action, $1)=immediate fi else # We cannot hardcode anything, or else we can only hardcode existing # directories. _LT_TAGVAR(hardcode_action, $1)=unsupported fi AC_MSG_RESULT([$_LT_TAGVAR(hardcode_action, $1)]) if test "$_LT_TAGVAR(hardcode_action, $1)" = relink || test "$_LT_TAGVAR(inherit_rpath, $1)" = yes; then # Fast installation is not supported enable_fast_install=no elif test "$shlibpath_overrides_runpath" = yes || test "$enable_shared" = no; then # Fast installation is not necessary enable_fast_install=needless fi _LT_TAGDECL([], [hardcode_action], [0], [How to hardcode a shared library path into an executable]) ])# _LT_LINKER_HARDCODE_LIBPATH # _LT_CMD_STRIPLIB # ---------------- m4_defun([_LT_CMD_STRIPLIB], [m4_require([_LT_DECL_EGREP]) striplib= old_striplib= AC_MSG_CHECKING([whether stripping libraries is possible]) if test -n "$STRIP" && $STRIP -V 2>&1 | $GREP "GNU strip" >/dev/null; then test -z "$old_striplib" && old_striplib="$STRIP --strip-debug" test -z "$striplib" && striplib="$STRIP --strip-unneeded" AC_MSG_RESULT([yes]) else # FIXME - insert some real tests, host_os isn't really good enough case $host_os in darwin*) if test -n "$STRIP" ; then striplib="$STRIP -x" old_striplib="$STRIP -S" AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) fi ;; *) AC_MSG_RESULT([no]) ;; esac fi _LT_DECL([], [old_striplib], [1], [Commands to strip libraries]) _LT_DECL([], [striplib], [1]) ])# _LT_CMD_STRIPLIB # _LT_SYS_DYNAMIC_LINKER([TAG]) # ----------------------------- # PORTME Fill in your ld.so characteristics m4_defun([_LT_SYS_DYNAMIC_LINKER], [AC_REQUIRE([AC_CANONICAL_HOST])dnl m4_require([_LT_DECL_EGREP])dnl m4_require([_LT_FILEUTILS_DEFAULTS])dnl m4_require([_LT_DECL_OBJDUMP])dnl m4_require([_LT_DECL_SED])dnl AC_MSG_CHECKING([dynamic linker characteristics]) m4_if([$1], [], [ if test "$GCC" = yes; then case $host_os in darwin*) lt_awk_arg="/^libraries:/,/LR/" ;; *) lt_awk_arg="/^libraries:/" ;; esac lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e "s,=/,/,g"` if $ECHO "$lt_search_path_spec" | $GREP ';' >/dev/null ; then # if the path contains ";" then we assume it to be the separator # otherwise default to the standard path separator (i.e. ":") - it is # assumed that no part of a normal pathname contains ";" but that should # okay in the real world where ";" in dirpaths is itself problematic. lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED -e 's/;/ /g'` else lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` fi # Ok, now we have the path, separated by spaces, we can step through it # and add multilib dir if necessary. lt_tmp_lt_search_path_spec= lt_multi_os_dir=`$CC $CPPFLAGS $CFLAGS $LDFLAGS -print-multi-os-directory 2>/dev/null` for lt_sys_path in $lt_search_path_spec; do if test -d "$lt_sys_path/$lt_multi_os_dir"; then lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path/$lt_multi_os_dir" else test -d "$lt_sys_path" && \ lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path" fi done lt_search_path_spec=`$ECHO $lt_tmp_lt_search_path_spec | awk ' BEGIN {RS=" "; FS="/|\n";} { lt_foo=""; lt_count=0; for (lt_i = NF; lt_i > 0; lt_i--) { if ($lt_i != "" && $lt_i != ".") { if ($lt_i == "..") { lt_count++; } else { if (lt_count == 0) { lt_foo="/" $lt_i lt_foo; } else { lt_count--; } } } } if (lt_foo != "") { lt_freq[[lt_foo]]++; } if (lt_freq[[lt_foo]] == 1) { print lt_foo; } }'` sys_lib_search_path_spec=`$ECHO $lt_search_path_spec` else sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" fi]) library_names_spec= libname_spec='lib$name' soname_spec= shrext_cmds=".so" postinstall_cmds= postuninstall_cmds= finish_cmds= finish_eval= shlibpath_var= shlibpath_overrides_runpath=unknown version_type=none dynamic_linker="$host_os ld.so" sys_lib_dlsearch_path_spec="/lib /usr/lib" need_lib_prefix=unknown hardcode_into_libs=no # when you set need_version to no, make sure it does not cause -set_version # flags to be left without arguments need_version=unknown case $host_os in aix3*) version_type=linux library_names_spec='${libname}${release}${shared_ext}$versuffix $libname.a' shlibpath_var=LIBPATH # AIX 3 has no versioning support, so we append a major version to the name. soname_spec='${libname}${release}${shared_ext}$major' ;; aix[[4-9]]*) version_type=linux need_lib_prefix=no need_version=no hardcode_into_libs=yes if test "$host_cpu" = ia64; then # AIX 5 supports IA64 library_names_spec='${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext}$versuffix $libname${shared_ext}' shlibpath_var=LD_LIBRARY_PATH else # With GCC up to 2.95.x, collect2 would create an import file # for dependence libraries. The import file would start with # the line `#! .'. This would cause the generated library to # depend on `.', always an invalid library. This was fixed in # development snapshots of GCC prior to 3.0. case $host_os in aix4 | aix4.[[01]] | aix4.[[01]].*) if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)' echo ' yes ' echo '#endif'; } | ${CC} -E - | $GREP yes > /dev/null; then : else can_build_shared=no fi ;; esac # AIX (on Power*) has no versioning support, so currently we can not hardcode correct # soname into executable. Probably we can add versioning support to # collect2, so additional links can be useful in future. if test "$aix_use_runtimelinking" = yes; then # If using run time linking (on AIX 4.2 or later) use lib.so # instead of lib.a to let people know that these are not # typical AIX shared libraries. library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' else # We preserve .a as extension for shared libraries through AIX4.2 # and later when we are not doing run time linking. library_names_spec='${libname}${release}.a $libname.a' soname_spec='${libname}${release}${shared_ext}$major' fi shlibpath_var=LIBPATH fi ;; amigaos*) case $host_cpu in powerpc) # Since July 2007 AmigaOS4 officially supports .so libraries. # When compiling the executable, add -use-dynld -Lsobjs: to the compileline. library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' ;; m68k) library_names_spec='$libname.ixlibrary $libname.a' # Create ${libname}_ixlibrary.a entries in /sys/libs. finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`$ECHO "X$lib" | $Xsed -e '\''s%^.*/\([[^/]]*\)\.ixlibrary$%\1%'\''`; test $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done' ;; esac ;; beos*) library_names_spec='${libname}${shared_ext}' dynamic_linker="$host_os ld.so" shlibpath_var=LIBRARY_PATH ;; bsdi[[45]]*) version_type=linux need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir' shlibpath_var=LD_LIBRARY_PATH sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib" sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib" # the default ld.so.conf also contains /usr/contrib/lib and # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow # libtool to hard-code these into programs ;; cygwin* | mingw* | pw32* | cegcc*) version_type=windows shrext_cmds=".dll" need_version=no need_lib_prefix=no case $GCC,$host_os in yes,cygwin* | yes,mingw* | yes,pw32* | yes,cegcc*) library_names_spec='$libname.dll.a' # DLL is installed to $(libdir)/../bin by postinstall_cmds postinstall_cmds='base_file=`basename \${file}`~ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~ dldir=$destdir/`dirname \$dlpath`~ test -d \$dldir || mkdir -p \$dldir~ $install_prog $dir/$dlname \$dldir/$dlname~ chmod a+x \$dldir/$dlname~ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; fi' postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ dlpath=$dir/\$dldll~ $RM \$dlpath' shlibpath_overrides_runpath=yes case $host_os in cygwin*) # Cygwin DLLs use 'cyg' prefix rather than 'lib' soname_spec='`echo ${libname} | sed -e 's/^lib/cyg/'``echo ${release} | $SED -e 's/[[.]]/-/g'`${versuffix}${shared_ext}' sys_lib_search_path_spec="/usr/lib /lib/w32api /lib /usr/local/lib" ;; mingw* | cegcc*) # MinGW DLLs use traditional 'lib' prefix soname_spec='${libname}`echo ${release} | $SED -e 's/[[.]]/-/g'`${versuffix}${shared_ext}' sys_lib_search_path_spec=`$CC -print-search-dirs | $GREP "^libraries:" | $SED -e "s/^libraries://" -e "s,=/,/,g"` if $ECHO "$sys_lib_search_path_spec" | [$GREP ';[c-zC-Z]:/' >/dev/null]; then # It is most probably a Windows format PATH printed by # mingw gcc, but we are running on Cygwin. Gcc prints its search # path with ; separators, and with drive letters. We can handle the # drive letters (cygwin fileutils understands them), so leave them, # especially as we might pass files found there to a mingw objdump, # which wouldn't understand a cygwinified path. Ahh. sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'` else sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` fi ;; pw32*) # pw32 DLLs use 'pw' prefix rather than 'lib' library_names_spec='`echo ${libname} | sed -e 's/^lib/pw/'``echo ${release} | $SED -e 's/[[.]]/-/g'`${versuffix}${shared_ext}' ;; esac ;; *) library_names_spec='${libname}`echo ${release} | $SED -e 's/[[.]]/-/g'`${versuffix}${shared_ext} $libname.lib' ;; esac dynamic_linker='Win32 ld.exe' # FIXME: first we should search . and the directory the executable is in shlibpath_var=PATH ;; darwin* | rhapsody*) dynamic_linker="$host_os dyld" version_type=darwin need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${major}$shared_ext ${libname}$shared_ext' soname_spec='${libname}${release}${major}$shared_ext' shlibpath_overrides_runpath=yes shlibpath_var=DYLD_LIBRARY_PATH shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`' m4_if([$1], [],[ sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/local/lib"]) sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib' ;; dgux*) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname$shared_ext' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH ;; freebsd1*) dynamic_linker=no ;; freebsd* | dragonfly*) # DragonFly does not have aout. When/if they implement a new # versioning mechanism, adjust this. if test -x /usr/bin/objformat; then objformat=`/usr/bin/objformat` else case $host_os in freebsd[[123]]*) objformat=aout ;; *) objformat=elf ;; esac fi version_type=freebsd-$objformat case $version_type in freebsd-elf*) library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}' need_version=no need_lib_prefix=no ;; freebsd-*) library_names_spec='${libname}${release}${shared_ext}$versuffix $libname${shared_ext}$versuffix' need_version=yes ;; esac shlibpath_var=LD_LIBRARY_PATH case $host_os in freebsd2*) shlibpath_overrides_runpath=yes ;; freebsd3.[[01]]* | freebsdelf3.[[01]]*) shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; freebsd3.[[2-9]]* | freebsdelf3.[[2-9]]* | \ freebsd4.[[0-5]] | freebsdelf4.[[0-5]] | freebsd4.1.1 | freebsdelf4.1.1) shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; *) # from 4.6 on, and DragonFly shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; esac ;; gnu*) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH hardcode_into_libs=yes ;; hpux9* | hpux10* | hpux11*) # Give a soname corresponding to the major version so that dld.sl refuses to # link against other versions. version_type=sunos need_lib_prefix=no need_version=no case $host_cpu in ia64*) shrext_cmds='.so' hardcode_into_libs=yes dynamic_linker="$host_os dld.so" shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' if test "X$HPUX_IA64_MODE" = X32; then sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" else sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" fi sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec ;; hppa*64*) shrext_cmds='.sl' hardcode_into_libs=yes dynamic_linker="$host_os dld.sl" shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64" sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec ;; *) shrext_cmds='.sl' dynamic_linker="$host_os dld.sl" shlibpath_var=SHLIB_PATH shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' ;; esac # HP-UX runs *really* slowly unless shared libraries are mode 555. postinstall_cmds='chmod 555 $lib' ;; interix[[3-9]]*) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; irix5* | irix6* | nonstopux*) case $host_os in nonstopux*) version_type=nonstopux ;; *) if test "$lt_cv_prog_gnu_ld" = yes; then version_type=linux else version_type=irix fi ;; esac need_lib_prefix=no need_version=no soname_spec='${libname}${release}${shared_ext}$major' library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext} $libname${shared_ext}' case $host_os in irix5* | nonstopux*) libsuff= shlibsuff= ;; *) case $LD in # libtool.m4 will add one of these switches to LD *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= libmagic=32-bit;; *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 libmagic=N32;; *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 libmagic=64-bit;; *) libsuff= shlibsuff= libmagic=never-match;; esac ;; esac shlibpath_var=LD_LIBRARY${shlibsuff}_PATH shlibpath_overrides_runpath=no sys_lib_search_path_spec="/usr/lib${libsuff} /lib${libsuff} /usr/local/lib${libsuff}" sys_lib_dlsearch_path_spec="/usr/lib${libsuff} /lib${libsuff}" hardcode_into_libs=yes ;; # No shared lib support for Linux oldld, aout, or coff. linux*oldld* | linux*aout* | linux*coff*) dynamic_linker=no ;; # This must be Linux ELF. linux* | k*bsd*-gnu) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no # Some binutils ld are patched to set DT_RUNPATH save_LDFLAGS=$LDFLAGS save_libdir=$libdir eval "libdir=/foo; wl=\"$_LT_TAGVAR(lt_prog_compiler_wl, $1)\"; \ LDFLAGS=\"\$LDFLAGS $_LT_TAGVAR(hardcode_libdir_flag_spec, $1)\"" AC_LINK_IFELSE([AC_LANG_PROGRAM([],[])], [AS_IF([ ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null], [shlibpath_overrides_runpath=yes])]) LDFLAGS=$save_LDFLAGS libdir=$save_libdir # This implies no fast_install, which is unacceptable. # Some rework will be needed to allow for fast_install # before this can be enabled. hardcode_into_libs=yes # Append ld.so.conf contents to the search path if test -f /etc/ld.so.conf; then lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \[$]2)); skip = 1; } { if (!skip) print \[$]0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;/^$/d' | tr '\n' ' '` sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra" fi # We used to test for /lib/ld.so.1 and disable shared libraries on # powerpc, because MkLinux only supported shared libraries with the # GNU dynamic linker. Since this was broken with cross compilers, # most powerpc-linux boxes support dynamic linking these days and # people can always --disable-shared, the test was removed, and we # assume the GNU/Linux dynamic linker is in use. dynamic_linker='GNU/Linux ld.so' ;; netbsdelf*-gnu) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes dynamic_linker='NetBSD ld.elf_so' ;; netbsd*) version_type=sunos need_lib_prefix=no need_version=no if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix' finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' dynamic_linker='NetBSD (a.out) ld.so' else library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' dynamic_linker='NetBSD ld.elf_so' fi shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; newsos6) version_type=linux library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes ;; *nto* | *qnx*) version_type=qnx need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes dynamic_linker='ldqnx.so' ;; openbsd*) version_type=sunos sys_lib_dlsearch_path_spec="/usr/lib" need_lib_prefix=no # Some older versions of OpenBSD (3.3 at least) *do* need versioned libs. case $host_os in openbsd3.3 | openbsd3.3.*) need_version=yes ;; *) need_version=no ;; esac library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix' finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' shlibpath_var=LD_LIBRARY_PATH if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then case $host_os in openbsd2.[[89]] | openbsd2.[[89]].*) shlibpath_overrides_runpath=no ;; *) shlibpath_overrides_runpath=yes ;; esac else shlibpath_overrides_runpath=yes fi ;; os2*) libname_spec='$name' shrext_cmds=".dll" need_lib_prefix=no library_names_spec='$libname${shared_ext} $libname.a' dynamic_linker='OS/2 ld.exe' shlibpath_var=LIBPATH ;; osf3* | osf4* | osf5*) version_type=osf need_lib_prefix=no need_version=no soname_spec='${libname}${release}${shared_ext}$major' library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' shlibpath_var=LD_LIBRARY_PATH sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib" sys_lib_dlsearch_path_spec="$sys_lib_search_path_spec" ;; rdos*) dynamic_linker=no ;; solaris*) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes # ldd complains unless libraries are executable postinstall_cmds='chmod +x $lib' ;; sunos4*) version_type=sunos library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix' finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes if test "$with_gnu_ld" = yes; then need_lib_prefix=no fi need_version=yes ;; sysv4 | sysv4.3*) version_type=linux library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH case $host_vendor in sni) shlibpath_overrides_runpath=no need_lib_prefix=no runpath_var=LD_RUN_PATH ;; siemens) need_lib_prefix=no ;; motorola) need_lib_prefix=no need_version=no shlibpath_overrides_runpath=no sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib' ;; esac ;; sysv4*MP*) if test -d /usr/nec ;then version_type=linux library_names_spec='$libname${shared_ext}.$versuffix $libname${shared_ext}.$major $libname${shared_ext}' soname_spec='$libname${shared_ext}.$major' shlibpath_var=LD_LIBRARY_PATH fi ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) version_type=freebsd-elf need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes if test "$with_gnu_ld" = yes; then sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib' else sys_lib_search_path_spec='/usr/ccs/lib /usr/lib' case $host_os in sco3.2v5*) sys_lib_search_path_spec="$sys_lib_search_path_spec /lib" ;; esac fi sys_lib_dlsearch_path_spec='/usr/lib' ;; tpf*) # TPF is a cross-target only. Preferred cross-host = GNU/Linux. version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; uts4*) version_type=linux library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH ;; *) dynamic_linker=no ;; esac AC_MSG_RESULT([$dynamic_linker]) test "$dynamic_linker" = no && can_build_shared=no variables_saved_for_relink="PATH $shlibpath_var $runpath_var" if test "$GCC" = yes; then variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" fi if test "${lt_cv_sys_lib_search_path_spec+set}" = set; then sys_lib_search_path_spec="$lt_cv_sys_lib_search_path_spec" fi if test "${lt_cv_sys_lib_dlsearch_path_spec+set}" = set; then sys_lib_dlsearch_path_spec="$lt_cv_sys_lib_dlsearch_path_spec" fi _LT_DECL([], [variables_saved_for_relink], [1], [Variables whose values should be saved in libtool wrapper scripts and restored at link time]) _LT_DECL([], [need_lib_prefix], [0], [Do we need the "lib" prefix for modules?]) _LT_DECL([], [need_version], [0], [Do we need a version for libraries?]) _LT_DECL([], [version_type], [0], [Library versioning type]) _LT_DECL([], [runpath_var], [0], [Shared library runtime path variable]) _LT_DECL([], [shlibpath_var], [0],[Shared library path variable]) _LT_DECL([], [shlibpath_overrides_runpath], [0], [Is shlibpath searched before the hard-coded library search path?]) _LT_DECL([], [libname_spec], [1], [Format of library name prefix]) _LT_DECL([], [library_names_spec], [1], [[List of archive names. First name is the real one, the rest are links. The last name is the one that the linker finds with -lNAME]]) _LT_DECL([], [soname_spec], [1], [[The coded name of the library, if different from the real name]]) _LT_DECL([], [postinstall_cmds], [2], [Command to use after installation of a shared archive]) _LT_DECL([], [postuninstall_cmds], [2], [Command to use after uninstallation of a shared archive]) _LT_DECL([], [finish_cmds], [2], [Commands used to finish a libtool library installation in a directory]) _LT_DECL([], [finish_eval], [1], [[As "finish_cmds", except a single script fragment to be evaled but not shown]]) _LT_DECL([], [hardcode_into_libs], [0], [Whether we should hardcode library paths into libraries]) _LT_DECL([], [sys_lib_search_path_spec], [2], [Compile-time system search path for libraries]) _LT_DECL([], [sys_lib_dlsearch_path_spec], [2], [Run-time system search path for libraries]) ])# _LT_SYS_DYNAMIC_LINKER # _LT_PATH_TOOL_PREFIX(TOOL) # -------------------------- # find a file program which can recognize shared library AC_DEFUN([_LT_PATH_TOOL_PREFIX], [m4_require([_LT_DECL_EGREP])dnl AC_MSG_CHECKING([for $1]) AC_CACHE_VAL(lt_cv_path_MAGIC_CMD, [case $MAGIC_CMD in [[\\/*] | ?:[\\/]*]) lt_cv_path_MAGIC_CMD="$MAGIC_CMD" # Let the user override the test with a path. ;; *) lt_save_MAGIC_CMD="$MAGIC_CMD" lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR dnl $ac_dummy forces splitting on constant user-supplied paths. dnl POSIX.2 word splitting is done only on the output of word expansions, dnl not every word. This closes a longstanding sh security hole. ac_dummy="m4_if([$2], , $PATH, [$2])" for ac_dir in $ac_dummy; do IFS="$lt_save_ifs" test -z "$ac_dir" && ac_dir=. if test -f $ac_dir/$1; then lt_cv_path_MAGIC_CMD="$ac_dir/$1" if test -n "$file_magic_test_file"; then case $deplibs_check_method in "file_magic "*) file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"` MAGIC_CMD="$lt_cv_path_MAGIC_CMD" if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null | $EGREP "$file_magic_regex" > /dev/null; then : else cat <<_LT_EOF 1>&2 *** Warning: the command libtool uses to detect shared libraries, *** $file_magic_cmd, produces output that libtool cannot recognize. *** The result is that libtool may fail to recognize shared libraries *** as such. This will affect the creation of libtool libraries that *** depend on shared libraries, but programs linked with such libtool *** libraries will work regardless of this problem. Nevertheless, you *** may want to report the problem to your system manager and/or to *** bug-libtool@gnu.org _LT_EOF fi ;; esac fi break fi done IFS="$lt_save_ifs" MAGIC_CMD="$lt_save_MAGIC_CMD" ;; esac]) MAGIC_CMD="$lt_cv_path_MAGIC_CMD" if test -n "$MAGIC_CMD"; then AC_MSG_RESULT($MAGIC_CMD) else AC_MSG_RESULT(no) fi _LT_DECL([], [MAGIC_CMD], [0], [Used to examine libraries when file_magic_cmd begins with "file"])dnl ])# _LT_PATH_TOOL_PREFIX # Old name: AU_ALIAS([AC_PATH_TOOL_PREFIX], [_LT_PATH_TOOL_PREFIX]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_PATH_TOOL_PREFIX], []) # _LT_PATH_MAGIC # -------------- # find a file program which can recognize a shared library m4_defun([_LT_PATH_MAGIC], [_LT_PATH_TOOL_PREFIX(${ac_tool_prefix}file, /usr/bin$PATH_SEPARATOR$PATH) if test -z "$lt_cv_path_MAGIC_CMD"; then if test -n "$ac_tool_prefix"; then _LT_PATH_TOOL_PREFIX(file, /usr/bin$PATH_SEPARATOR$PATH) else MAGIC_CMD=: fi fi ])# _LT_PATH_MAGIC # LT_PATH_LD # ---------- # find the pathname to the GNU or non-GNU linker AC_DEFUN([LT_PATH_LD], [AC_REQUIRE([AC_PROG_CC])dnl AC_REQUIRE([AC_CANONICAL_HOST])dnl AC_REQUIRE([AC_CANONICAL_BUILD])dnl m4_require([_LT_DECL_SED])dnl m4_require([_LT_DECL_EGREP])dnl AC_ARG_WITH([gnu-ld], [AS_HELP_STRING([--with-gnu-ld], [assume the C compiler uses GNU ld @<:@default=no@:>@])], [test "$withval" = no || with_gnu_ld=yes], [with_gnu_ld=no])dnl ac_prog=ld if test "$GCC" = yes; then # Check if gcc -print-prog-name=ld gives a path. AC_MSG_CHECKING([for ld used by $CC]) case $host in *-*-mingw*) # gcc leaves a trailing carriage return which upsets mingw ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;; *) ac_prog=`($CC -print-prog-name=ld) 2>&5` ;; esac case $ac_prog in # Accept absolute paths. [[\\/]]* | ?:[[\\/]]*) re_direlt='/[[^/]][[^/]]*/\.\./' # Canonicalize the pathname of ld ac_prog=`$ECHO "$ac_prog"| $SED 's%\\\\%/%g'` while $ECHO "$ac_prog" | $GREP "$re_direlt" > /dev/null 2>&1; do ac_prog=`$ECHO $ac_prog| $SED "s%$re_direlt%/%"` done test -z "$LD" && LD="$ac_prog" ;; "") # If it fails, then pretend we aren't using GCC. ac_prog=ld ;; *) # If it is relative, then search for the first ld in PATH. with_gnu_ld=unknown ;; esac elif test "$with_gnu_ld" = yes; then AC_MSG_CHECKING([for GNU ld]) else AC_MSG_CHECKING([for non-GNU ld]) fi AC_CACHE_VAL(lt_cv_path_LD, [if test -z "$LD"; then lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR for ac_dir in $PATH; do IFS="$lt_save_ifs" test -z "$ac_dir" && ac_dir=. if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then lt_cv_path_LD="$ac_dir/$ac_prog" # Check to see if the program is GNU ld. I'd rather use --version, # but apparently some variants of GNU ld only accept -v. # Break only if it was the GNU/non-GNU ld that we prefer. case `"$lt_cv_path_LD" -v 2>&1 &1 /dev/null 2>&1; then lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL' lt_cv_file_magic_cmd='func_win32_libid' else lt_cv_deplibs_check_method='file_magic file format pei*-i386(.*architecture: i386)?' lt_cv_file_magic_cmd='$OBJDUMP -f' fi ;; cegcc) # use the weaker test based on 'objdump'. See mingw*. lt_cv_deplibs_check_method='file_magic file format pe-arm-.*little(.*architecture: arm)?' lt_cv_file_magic_cmd='$OBJDUMP -f' ;; darwin* | rhapsody*) lt_cv_deplibs_check_method=pass_all ;; freebsd* | dragonfly*) if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then case $host_cpu in i*86 ) # Not sure whether the presence of OpenBSD here was a mistake. # Let's accept both of them until this is cleared up. lt_cv_deplibs_check_method='file_magic (FreeBSD|OpenBSD|DragonFly)/i[[3-9]]86 (compact )?demand paged shared library' lt_cv_file_magic_cmd=/usr/bin/file lt_cv_file_magic_test_file=`echo /usr/lib/libc.so.*` ;; esac else lt_cv_deplibs_check_method=pass_all fi ;; gnu*) lt_cv_deplibs_check_method=pass_all ;; hpux10.20* | hpux11*) lt_cv_file_magic_cmd=/usr/bin/file case $host_cpu in ia64*) lt_cv_deplibs_check_method='file_magic (s[[0-9]][[0-9]][[0-9]]|ELF-[[0-9]][[0-9]]) shared object file - IA64' lt_cv_file_magic_test_file=/usr/lib/hpux32/libc.so ;; hppa*64*) [lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF-[0-9][0-9]) shared object file - PA-RISC [0-9].[0-9]'] lt_cv_file_magic_test_file=/usr/lib/pa20_64/libc.sl ;; *) lt_cv_deplibs_check_method='file_magic (s[[0-9]][[0-9]][[0-9]]|PA-RISC[[0-9]].[[0-9]]) shared library' lt_cv_file_magic_test_file=/usr/lib/libc.sl ;; esac ;; interix[[3-9]]*) # PIC code is broken on Interix 3.x, that's why |\.a not |_pic\.a here lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so|\.a)$' ;; irix5* | irix6* | nonstopux*) case $LD in *-32|*"-32 ") libmagic=32-bit;; *-n32|*"-n32 ") libmagic=N32;; *-64|*"-64 ") libmagic=64-bit;; *) libmagic=never-match;; esac lt_cv_deplibs_check_method=pass_all ;; # This must be Linux ELF. linux* | k*bsd*-gnu) lt_cv_deplibs_check_method=pass_all ;; netbsd* | netbsdelf*-gnu) if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so\.[[0-9]]+\.[[0-9]]+|_pic\.a)$' else lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so|_pic\.a)$' fi ;; newos6*) lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[ML]]SB (executable|dynamic lib)' lt_cv_file_magic_cmd=/usr/bin/file lt_cv_file_magic_test_file=/usr/lib/libnls.so ;; *nto* | *qnx*) lt_cv_deplibs_check_method=pass_all ;; openbsd*) if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so\.[[0-9]]+\.[[0-9]]+|\.so|_pic\.a)$' else lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so\.[[0-9]]+\.[[0-9]]+|_pic\.a)$' fi ;; osf3* | osf4* | osf5*) lt_cv_deplibs_check_method=pass_all ;; rdos*) lt_cv_deplibs_check_method=pass_all ;; solaris*) lt_cv_deplibs_check_method=pass_all ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) lt_cv_deplibs_check_method=pass_all ;; sysv4 | sysv4.3*) case $host_vendor in motorola) lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[ML]]SB (shared object|dynamic lib) M[[0-9]][[0-9]]* Version [[0-9]]' lt_cv_file_magic_test_file=`echo /usr/lib/libc.so*` ;; ncr) lt_cv_deplibs_check_method=pass_all ;; sequent) lt_cv_file_magic_cmd='/bin/file' lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[LM]]SB (shared object|dynamic lib )' ;; sni) lt_cv_file_magic_cmd='/bin/file' lt_cv_deplibs_check_method="file_magic ELF [[0-9]][[0-9]]*-bit [[LM]]SB dynamic lib" lt_cv_file_magic_test_file=/lib/libc.so ;; siemens) lt_cv_deplibs_check_method=pass_all ;; pc) lt_cv_deplibs_check_method=pass_all ;; esac ;; tpf*) lt_cv_deplibs_check_method=pass_all ;; esac ]) file_magic_cmd=$lt_cv_file_magic_cmd deplibs_check_method=$lt_cv_deplibs_check_method test -z "$deplibs_check_method" && deplibs_check_method=unknown _LT_DECL([], [deplibs_check_method], [1], [Method to check whether dependent libraries are shared objects]) _LT_DECL([], [file_magic_cmd], [1], [Command to use when deplibs_check_method == "file_magic"]) ])# _LT_CHECK_MAGIC_METHOD # LT_PATH_NM # ---------- # find the pathname to a BSD- or MS-compatible name lister AC_DEFUN([LT_PATH_NM], [AC_REQUIRE([AC_PROG_CC])dnl AC_CACHE_CHECK([for BSD- or MS-compatible name lister (nm)], lt_cv_path_NM, [if test -n "$NM"; then # Let the user override the test. lt_cv_path_NM="$NM" else lt_nm_to_check="${ac_tool_prefix}nm" if test -n "$ac_tool_prefix" && test "$build" = "$host"; then lt_nm_to_check="$lt_nm_to_check nm" fi for lt_tmp_nm in $lt_nm_to_check; do lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR for ac_dir in $PATH /usr/ccs/bin/elf /usr/ccs/bin /usr/ucb /bin; do IFS="$lt_save_ifs" test -z "$ac_dir" && ac_dir=. tmp_nm="$ac_dir/$lt_tmp_nm" if test -f "$tmp_nm" || test -f "$tmp_nm$ac_exeext" ; then # Check to see if the nm accepts a BSD-compat flag. # Adding the `sed 1q' prevents false positives on HP-UX, which says: # nm: unknown option "B" ignored # Tru64's nm complains that /dev/null is an invalid object file case `"$tmp_nm" -B /dev/null 2>&1 | sed '1q'` in */dev/null* | *'Invalid file or object type'*) lt_cv_path_NM="$tmp_nm -B" break ;; *) case `"$tmp_nm" -p /dev/null 2>&1 | sed '1q'` in */dev/null*) lt_cv_path_NM="$tmp_nm -p" break ;; *) lt_cv_path_NM=${lt_cv_path_NM="$tmp_nm"} # keep the first match, but continue # so that we can try to find one that supports BSD flags ;; esac ;; esac fi done IFS="$lt_save_ifs" done : ${lt_cv_path_NM=no} fi]) if test "$lt_cv_path_NM" != "no"; then NM="$lt_cv_path_NM" else # Didn't find any BSD compatible name lister, look for dumpbin. AC_CHECK_TOOLS(DUMPBIN, ["dumpbin -symbols" "link -dump -symbols"], :) AC_SUBST([DUMPBIN]) if test "$DUMPBIN" != ":"; then NM="$DUMPBIN" fi fi test -z "$NM" && NM=nm AC_SUBST([NM]) _LT_DECL([], [NM], [1], [A BSD- or MS-compatible name lister])dnl AC_CACHE_CHECK([the name lister ($NM) interface], [lt_cv_nm_interface], [lt_cv_nm_interface="BSD nm" echo "int some_variable = 0;" > conftest.$ac_ext (eval echo "\"\$as_me:__oline__: $ac_compile\"" >&AS_MESSAGE_LOG_FD) (eval "$ac_compile" 2>conftest.err) cat conftest.err >&AS_MESSAGE_LOG_FD (eval echo "\"\$as_me:__oline__: $NM \\\"conftest.$ac_objext\\\"\"" >&AS_MESSAGE_LOG_FD) (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) cat conftest.err >&AS_MESSAGE_LOG_FD (eval echo "\"\$as_me:__oline__: output\"" >&AS_MESSAGE_LOG_FD) cat conftest.out >&AS_MESSAGE_LOG_FD if $GREP 'External.*some_variable' conftest.out > /dev/null; then lt_cv_nm_interface="MS dumpbin" fi rm -f conftest*]) ])# LT_PATH_NM # Old names: AU_ALIAS([AM_PROG_NM], [LT_PATH_NM]) AU_ALIAS([AC_PROG_NM], [LT_PATH_NM]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AM_PROG_NM], []) dnl AC_DEFUN([AC_PROG_NM], []) # LT_LIB_M # -------- # check for math library AC_DEFUN([LT_LIB_M], [AC_REQUIRE([AC_CANONICAL_HOST])dnl LIBM= case $host in *-*-beos* | *-*-cygwin* | *-*-pw32* | *-*-darwin*) # These system don't have libm, or don't need it ;; *-ncr-sysv4.3*) AC_CHECK_LIB(mw, _mwvalidcheckl, LIBM="-lmw") AC_CHECK_LIB(m, cos, LIBM="$LIBM -lm") ;; *) AC_CHECK_LIB(m, cos, LIBM="-lm") ;; esac AC_SUBST([LIBM]) ])# LT_LIB_M # Old name: AU_ALIAS([AC_CHECK_LIBM], [LT_LIB_M]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([AC_CHECK_LIBM], []) # _LT_COMPILER_NO_RTTI([TAGNAME]) # ------------------------------- m4_defun([_LT_COMPILER_NO_RTTI], [m4_require([_LT_TAG_COMPILER])dnl _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)= if test "$GCC" = yes; then _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -fno-builtin' _LT_COMPILER_OPTION([if $compiler supports -fno-rtti -fno-exceptions], lt_cv_prog_compiler_rtti_exceptions, [-fno-rtti -fno-exceptions], [], [_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)="$_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1) -fno-rtti -fno-exceptions"]) fi _LT_TAGDECL([no_builtin_flag], [lt_prog_compiler_no_builtin_flag], [1], [Compiler flag to turn off builtin functions]) ])# _LT_COMPILER_NO_RTTI # _LT_CMD_GLOBAL_SYMBOLS # ---------------------- m4_defun([_LT_CMD_GLOBAL_SYMBOLS], [AC_REQUIRE([AC_CANONICAL_HOST])dnl AC_REQUIRE([AC_PROG_CC])dnl AC_REQUIRE([LT_PATH_NM])dnl AC_REQUIRE([LT_PATH_LD])dnl m4_require([_LT_DECL_SED])dnl m4_require([_LT_DECL_EGREP])dnl m4_require([_LT_TAG_COMPILER])dnl # Check for command to grab the raw symbol name followed by C symbol from nm. AC_MSG_CHECKING([command to parse $NM output from $compiler object]) AC_CACHE_VAL([lt_cv_sys_global_symbol_pipe], [ # These are sane defaults that work on at least a few old systems. # [They come from Ultrix. What could be older than Ultrix?!! ;)] # Character class describing NM global symbol codes. symcode='[[BCDEGRST]]' # Regexp to match symbols that can be accessed directly from C. sympat='\([[_A-Za-z]][[_A-Za-z0-9]]*\)' # Define system-specific variables. case $host_os in aix*) symcode='[[BCDT]]' ;; cygwin* | mingw* | pw32* | cegcc*) symcode='[[ABCDGISTW]]' ;; hpux*) if test "$host_cpu" = ia64; then symcode='[[ABCDEGRST]]' fi ;; irix* | nonstopux*) symcode='[[BCDEGRST]]' ;; osf*) symcode='[[BCDEGQRST]]' ;; solaris*) symcode='[[BDRT]]' ;; sco3.2v5*) symcode='[[DT]]' ;; sysv4.2uw2*) symcode='[[DT]]' ;; sysv5* | sco5v6* | unixware* | OpenUNIX*) symcode='[[ABDT]]' ;; sysv4) symcode='[[DFNSTU]]' ;; esac # If we're using GNU nm, then use its standard symbol codes. case `$NM -V 2>&1` in *GNU* | *'with BFD'*) symcode='[[ABCDGIRSTW]]' ;; esac # Transform an extracted symbol line into a proper C declaration. # Some systems (esp. on ia64) link data and code symbols differently, # so use this general approach. lt_cv_sys_global_symbol_to_cdecl="sed -n -e 's/^T .* \(.*\)$/extern int \1();/p' -e 's/^$symcode* .* \(.*\)$/extern char \1;/p'" # Transform an extracted symbol line into symbol name and symbol address lt_cv_sys_global_symbol_to_c_name_address="sed -n -e 's/^: \([[^ ]]*\) $/ {\\\"\1\\\", (void *) 0},/p' -e 's/^$symcode* \([[^ ]]*\) \([[^ ]]*\)$/ {\"\2\", (void *) \&\2},/p'" lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="sed -n -e 's/^: \([[^ ]]*\) $/ {\\\"\1\\\", (void *) 0},/p' -e 's/^$symcode* \([[^ ]]*\) \(lib[[^ ]]*\)$/ {\"\2\", (void *) \&\2},/p' -e 's/^$symcode* \([[^ ]]*\) \([[^ ]]*\)$/ {\"lib\2\", (void *) \&\2},/p'" # Handle CRLF in mingw tool chain opt_cr= case $build_os in mingw*) opt_cr=`$ECHO 'x\{0,1\}' | tr x '\015'` # option cr in regexp ;; esac # Try without a prefix underscore, then with it. for ac_symprfx in "" "_"; do # Transform symcode, sympat, and symprfx into a raw symbol and a C symbol. symxfrm="\\1 $ac_symprfx\\2 \\2" # Write the raw and C identifiers. if test "$lt_cv_nm_interface" = "MS dumpbin"; then # Fake it for dumpbin and say T for any non-static function # and D for any global variable. # Also find C++ and __fastcall symbols from MSVC++, # which start with @ or ?. lt_cv_sys_global_symbol_pipe="$AWK ['"\ " {last_section=section; section=\$ 3};"\ " /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\ " \$ 0!~/External *\|/{next};"\ " / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\ " {if(hide[section]) next};"\ " {f=0}; \$ 0~/\(\).*\|/{f=1}; {printf f ? \"T \" : \"D \"};"\ " {split(\$ 0, a, /\||\r/); split(a[2], s)};"\ " s[1]~/^[@?]/{print s[1], s[1]; next};"\ " s[1]~prfx {split(s[1],t,\"@\"); print t[1], substr(t[1],length(prfx))}"\ " ' prfx=^$ac_symprfx]" else lt_cv_sys_global_symbol_pipe="sed -n -e 's/^.*[[ ]]\($symcode$symcode*\)[[ ]][[ ]]*$ac_symprfx$sympat$opt_cr$/$symxfrm/p'" fi # Check to see that the pipe works correctly. pipe_works=no rm -f conftest* cat > conftest.$ac_ext <<_LT_EOF #ifdef __cplusplus extern "C" { #endif char nm_test_var; void nm_test_func(void); void nm_test_func(void){} #ifdef __cplusplus } #endif int main(){nm_test_var='a';nm_test_func();return(0);} _LT_EOF if AC_TRY_EVAL(ac_compile); then # Now try to grab the symbols. nlist=conftest.nm if AC_TRY_EVAL(NM conftest.$ac_objext \| $lt_cv_sys_global_symbol_pipe \> $nlist) && test -s "$nlist"; then # Try sorting and uniquifying the output. if sort "$nlist" | uniq > "$nlist"T; then mv -f "$nlist"T "$nlist" else rm -f "$nlist"T fi # Make sure that we snagged all the symbols we need. if $GREP ' nm_test_var$' "$nlist" >/dev/null; then if $GREP ' nm_test_func$' "$nlist" >/dev/null; then cat <<_LT_EOF > conftest.$ac_ext #ifdef __cplusplus extern "C" { #endif _LT_EOF # Now generate the symbol file. eval "$lt_cv_sys_global_symbol_to_cdecl"' < "$nlist" | $GREP -v main >> conftest.$ac_ext' cat <<_LT_EOF >> conftest.$ac_ext /* The mapping between symbol names and symbols. */ const struct { const char *name; void *address; } lt__PROGRAM__LTX_preloaded_symbols[[]] = { { "@PROGRAM@", (void *) 0 }, _LT_EOF $SED "s/^$symcode$symcode* \(.*\) \(.*\)$/ {\"\2\", (void *) \&\2},/" < "$nlist" | $GREP -v main >> conftest.$ac_ext cat <<\_LT_EOF >> conftest.$ac_ext {0, (void *) 0} }; /* This works around a problem in FreeBSD linker */ #ifdef FREEBSD_WORKAROUND static const void *lt_preloaded_setup() { return lt__PROGRAM__LTX_preloaded_symbols; } #endif #ifdef __cplusplus } #endif _LT_EOF # Now try linking the two files. mv conftest.$ac_objext conftstm.$ac_objext lt_save_LIBS="$LIBS" lt_save_CFLAGS="$CFLAGS" LIBS="conftstm.$ac_objext" CFLAGS="$CFLAGS$_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)" if AC_TRY_EVAL(ac_link) && test -s conftest${ac_exeext}; then pipe_works=yes fi LIBS="$lt_save_LIBS" CFLAGS="$lt_save_CFLAGS" else echo "cannot find nm_test_func in $nlist" >&AS_MESSAGE_LOG_FD fi else echo "cannot find nm_test_var in $nlist" >&AS_MESSAGE_LOG_FD fi else echo "cannot run $lt_cv_sys_global_symbol_pipe" >&AS_MESSAGE_LOG_FD fi else echo "$progname: failed program was:" >&AS_MESSAGE_LOG_FD cat conftest.$ac_ext >&5 fi rm -rf conftest* conftst* # Do not use the global_symbol_pipe unless it works. if test "$pipe_works" = yes; then break else lt_cv_sys_global_symbol_pipe= fi done ]) if test -z "$lt_cv_sys_global_symbol_pipe"; then lt_cv_sys_global_symbol_to_cdecl= fi if test -z "$lt_cv_sys_global_symbol_pipe$lt_cv_sys_global_symbol_to_cdecl"; then AC_MSG_RESULT(failed) else AC_MSG_RESULT(ok) fi _LT_DECL([global_symbol_pipe], [lt_cv_sys_global_symbol_pipe], [1], [Take the output of nm and produce a listing of raw symbols and C names]) _LT_DECL([global_symbol_to_cdecl], [lt_cv_sys_global_symbol_to_cdecl], [1], [Transform the output of nm in a proper C declaration]) _LT_DECL([global_symbol_to_c_name_address], [lt_cv_sys_global_symbol_to_c_name_address], [1], [Transform the output of nm in a C name address pair]) _LT_DECL([global_symbol_to_c_name_address_lib_prefix], [lt_cv_sys_global_symbol_to_c_name_address_lib_prefix], [1], [Transform the output of nm in a C name address pair when lib prefix is needed]) ]) # _LT_CMD_GLOBAL_SYMBOLS # _LT_COMPILER_PIC([TAGNAME]) # --------------------------- m4_defun([_LT_COMPILER_PIC], [m4_require([_LT_TAG_COMPILER])dnl _LT_TAGVAR(lt_prog_compiler_wl, $1)= _LT_TAGVAR(lt_prog_compiler_pic, $1)= _LT_TAGVAR(lt_prog_compiler_static, $1)= AC_MSG_CHECKING([for $compiler option to produce PIC]) m4_if([$1], [CXX], [ # C++ specific cases for pic, static, wl, etc. if test "$GXX" = yes; then _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' case $host_os in aix*) # All AIX code is PIC. if test "$host_cpu" = ia64; then # AIX 5 now supports IA64 processor _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' fi ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' ;; m68k) # FIXME: we need at least 68020 code to build shared libraries, but # adding the `-m68020' flag to GCC prevents building anything better, # like `-m68040'. _LT_TAGVAR(lt_prog_compiler_pic, $1)='-m68020 -resident32 -malways-restore-a4' ;; esac ;; beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*) # PIC is the default for these OSes. ;; mingw* | cygwin* | os2* | pw32* | cegcc*) # This hack is so that the source file can tell whether it is being # built for inclusion in a dll (and should export symbols for example). # Although the cygwin gcc ignores -fPIC, still need this for old-style # (--disable-auto-import) libraries m4_if([$1], [GCJ], [], [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT']) ;; darwin* | rhapsody*) # PIC is the default on this platform # Common symbols not allowed in MH_DYLIB files _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fno-common' ;; *djgpp*) # DJGPP does not support shared libraries at all _LT_TAGVAR(lt_prog_compiler_pic, $1)= ;; interix[[3-9]]*) # Interix 3.x gcc -fpic/-fPIC options generate broken code. # Instead, we relocate shared libraries at runtime. ;; sysv4*MP*) if test -d /usr/nec; then _LT_TAGVAR(lt_prog_compiler_pic, $1)=-Kconform_pic fi ;; hpux*) # PIC is the default for 64-bit PA HP-UX, but not for 32-bit # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag # sets the default TLS model and affects inlining. case $host_cpu in hppa*64*) ;; *) _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' ;; esac ;; *qnx* | *nto*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared' ;; *) _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' ;; esac else case $host_os in aix[[4-9]]*) # All AIX code is PIC. if test "$host_cpu" = ia64; then # AIX 5 now supports IA64 processor _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' else _LT_TAGVAR(lt_prog_compiler_static, $1)='-bnso -bI:/lib/syscalls.exp' fi ;; chorus*) case $cc_basename in cxch68*) # Green Hills C++ Compiler # _LT_TAGVAR(lt_prog_compiler_static, $1)="--no_auto_instantiation -u __main -u __premain -u _abort -r $COOL_DIR/lib/libOrb.a $MVME_DIR/lib/CC/libC.a $MVME_DIR/lib/classix/libcx.s.a" ;; esac ;; dgux*) case $cc_basename in ec++*) _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' ;; ghcx*) # Green Hills C++ Compiler _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' ;; *) ;; esac ;; freebsd* | dragonfly*) # FreeBSD uses GNU C++ ;; hpux9* | hpux10* | hpux11*) case $cc_basename in CC*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_static, $1)='${wl}-a ${wl}archive' if test "$host_cpu" != ia64; then _LT_TAGVAR(lt_prog_compiler_pic, $1)='+Z' fi ;; aCC*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_static, $1)='${wl}-a ${wl}archive' case $host_cpu in hppa*64*|ia64*) # +Z the default ;; *) _LT_TAGVAR(lt_prog_compiler_pic, $1)='+Z' ;; esac ;; *) ;; esac ;; interix*) # This is c89, which is MS Visual C++ (no shared libs) # Anyone wants to do a port? ;; irix5* | irix6* | nonstopux*) case $cc_basename in CC*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' # CC pic flag -KPIC is the default. ;; *) ;; esac ;; linux* | k*bsd*-gnu) case $cc_basename in KCC*) # KAI C++ Compiler _LT_TAGVAR(lt_prog_compiler_wl, $1)='--backend -Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' ;; ecpc* ) # old Intel C++ for x86_64 which still supported -KPIC. _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' ;; icpc* ) # Intel C++, used to be incompatible with GCC. # ICC 10 doesn't accept -KPIC any more. _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' ;; pgCC* | pgcpp*) # Portland Group C++ compiler _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fpic' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' ;; cxx*) # Compaq C++ # Make sure the PIC flag is empty. It appears that all Alpha # Linux and Compaq Tru64 Unix objects are PIC. _LT_TAGVAR(lt_prog_compiler_pic, $1)= _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' ;; xlc* | xlC*) # IBM XL 8.0 on PPC _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-qpic' _LT_TAGVAR(lt_prog_compiler_static, $1)='-qstaticlink' ;; *) case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C++ 5.9 _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ' ;; esac ;; esac ;; lynxos*) ;; m88k*) ;; mvs*) case $cc_basename in cxx*) _LT_TAGVAR(lt_prog_compiler_pic, $1)='-W c,exportall' ;; *) ;; esac ;; netbsd* | netbsdelf*-gnu) ;; *qnx* | *nto*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared' ;; osf3* | osf4* | osf5*) case $cc_basename in KCC*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='--backend -Wl,' ;; RCC*) # Rational C++ 2.4.1 _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' ;; cxx*) # Digital/Compaq C++ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' # Make sure the PIC flag is empty. It appears that all Alpha # Linux and Compaq Tru64 Unix objects are PIC. _LT_TAGVAR(lt_prog_compiler_pic, $1)= _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' ;; *) ;; esac ;; psos*) ;; solaris*) case $cc_basename in CC*) # Sun C++ 4.2, 5.x and Centerline C++ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ' ;; gcx*) # Green Hills C++ Compiler _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC' ;; *) ;; esac ;; sunos4*) case $cc_basename in CC*) # Sun C++ 4.x _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' ;; lcc*) # Lucid _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' ;; *) ;; esac ;; sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*) case $cc_basename in CC*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' ;; esac ;; tandem*) case $cc_basename in NCC*) # NonStop-UX NCC 3.20 _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' ;; *) ;; esac ;; vxworks*) ;; *) _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no ;; esac fi ], [ if test "$GCC" = yes; then _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' case $host_os in aix*) # All AIX code is PIC. if test "$host_cpu" = ia64; then # AIX 5 now supports IA64 processor _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' fi ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' ;; m68k) # FIXME: we need at least 68020 code to build shared libraries, but # adding the `-m68020' flag to GCC prevents building anything better, # like `-m68040'. _LT_TAGVAR(lt_prog_compiler_pic, $1)='-m68020 -resident32 -malways-restore-a4' ;; esac ;; beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*) # PIC is the default for these OSes. ;; mingw* | cygwin* | pw32* | os2* | cegcc*) # This hack is so that the source file can tell whether it is being # built for inclusion in a dll (and should export symbols for example). # Although the cygwin gcc ignores -fPIC, still need this for old-style # (--disable-auto-import) libraries m4_if([$1], [GCJ], [], [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT']) ;; darwin* | rhapsody*) # PIC is the default on this platform # Common symbols not allowed in MH_DYLIB files _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fno-common' ;; hpux*) # PIC is the default for 64-bit PA HP-UX, but not for 32-bit # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag # sets the default TLS model and affects inlining. case $host_cpu in hppa*64*) # +Z the default ;; *) _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' ;; esac ;; interix[[3-9]]*) # Interix 3.x gcc -fpic/-fPIC options generate broken code. # Instead, we relocate shared libraries at runtime. ;; msdosdjgpp*) # Just because we use GCC doesn't mean we suddenly get shared libraries # on systems that don't support them. _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no enable_shared=no ;; *nto* | *qnx*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared' ;; sysv4*MP*) if test -d /usr/nec; then _LT_TAGVAR(lt_prog_compiler_pic, $1)=-Kconform_pic fi ;; *) _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' ;; esac else # PORTME Check for flag to pass linker flags through the system compiler. case $host_os in aix*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' if test "$host_cpu" = ia64; then # AIX 5 now supports IA64 processor _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' else _LT_TAGVAR(lt_prog_compiler_static, $1)='-bnso -bI:/lib/syscalls.exp' fi ;; mingw* | cygwin* | pw32* | os2* | cegcc*) # This hack is so that the source file can tell whether it is being # built for inclusion in a dll (and should export symbols for example). m4_if([$1], [GCJ], [], [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT']) ;; hpux9* | hpux10* | hpux11*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' # PIC is the default for IA64 HP-UX and 64-bit HP-UX, but # not for PA HP-UX. case $host_cpu in hppa*64*|ia64*) # +Z the default ;; *) _LT_TAGVAR(lt_prog_compiler_pic, $1)='+Z' ;; esac # Is there a better lt_prog_compiler_static that works with the bundled CC? _LT_TAGVAR(lt_prog_compiler_static, $1)='${wl}-a ${wl}archive' ;; irix5* | irix6* | nonstopux*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' # PIC (with -KPIC) is the default. _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' ;; linux* | k*bsd*-gnu) case $cc_basename in # old Intel for x86_64 which still supported -KPIC. ecc*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' ;; # icc used to be incompatible with GCC. # ICC 10 doesn't accept -KPIC any more. icc* | ifort*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' ;; # Lahey Fortran 8.1. lf95*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='--shared' _LT_TAGVAR(lt_prog_compiler_static, $1)='--static' ;; pgcc* | pgf77* | pgf90* | pgf95*) # Portland Group compilers (*not* the Pentium gcc compiler, # which looks to be a dead project) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fpic' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' ;; ccc*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' # All Alpha code is PIC. _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' ;; xl*) # IBM XL C 8.0/Fortran 10.1 on PPC _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-qpic' _LT_TAGVAR(lt_prog_compiler_static, $1)='-qstaticlink' ;; *) case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C 5.9 _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' ;; *Sun\ F*) # Sun Fortran 8.3 passes all unrecognized flags to the linker _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' _LT_TAGVAR(lt_prog_compiler_wl, $1)='' ;; esac ;; esac ;; newsos6) _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' ;; *nto* | *qnx*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared' ;; osf3* | osf4* | osf5*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' # All OSF/1 code is PIC. _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' ;; rdos*) _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' ;; solaris*) _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' case $cc_basename in f77* | f90* | f95*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ';; *) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,';; esac ;; sunos4*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' ;; sysv4 | sysv4.2uw2* | sysv4.3*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' ;; sysv4*MP*) if test -d /usr/nec ;then _LT_TAGVAR(lt_prog_compiler_pic, $1)='-Kconform_pic' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' fi ;; sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' ;; unicos*) _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no ;; uts4*) _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' ;; *) _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no ;; esac fi ]) case $host_os in # For platforms which do not support PIC, -DPIC is meaningless: *djgpp*) _LT_TAGVAR(lt_prog_compiler_pic, $1)= ;; *) _LT_TAGVAR(lt_prog_compiler_pic, $1)="$_LT_TAGVAR(lt_prog_compiler_pic, $1)@&t@m4_if([$1],[],[ -DPIC],[m4_if([$1],[CXX],[ -DPIC],[])])" ;; esac AC_MSG_RESULT([$_LT_TAGVAR(lt_prog_compiler_pic, $1)]) _LT_TAGDECL([wl], [lt_prog_compiler_wl], [1], [How to pass a linker flag through the compiler]) # # Check to make sure the PIC flag actually works. # if test -n "$_LT_TAGVAR(lt_prog_compiler_pic, $1)"; then _LT_COMPILER_OPTION([if $compiler PIC flag $_LT_TAGVAR(lt_prog_compiler_pic, $1) works], [_LT_TAGVAR(lt_cv_prog_compiler_pic_works, $1)], [$_LT_TAGVAR(lt_prog_compiler_pic, $1)@&t@m4_if([$1],[],[ -DPIC],[m4_if([$1],[CXX],[ -DPIC],[])])], [], [case $_LT_TAGVAR(lt_prog_compiler_pic, $1) in "" | " "*) ;; *) _LT_TAGVAR(lt_prog_compiler_pic, $1)=" $_LT_TAGVAR(lt_prog_compiler_pic, $1)" ;; esac], [_LT_TAGVAR(lt_prog_compiler_pic, $1)= _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no]) fi _LT_TAGDECL([pic_flag], [lt_prog_compiler_pic], [1], [Additional compiler flags for building library objects]) # # Check to make sure the static flag actually works. # wl=$_LT_TAGVAR(lt_prog_compiler_wl, $1) eval lt_tmp_static_flag=\"$_LT_TAGVAR(lt_prog_compiler_static, $1)\" _LT_LINKER_OPTION([if $compiler static flag $lt_tmp_static_flag works], _LT_TAGVAR(lt_cv_prog_compiler_static_works, $1), $lt_tmp_static_flag, [], [_LT_TAGVAR(lt_prog_compiler_static, $1)=]) _LT_TAGDECL([link_static_flag], [lt_prog_compiler_static], [1], [Compiler flag to prevent dynamic linking]) ])# _LT_COMPILER_PIC # _LT_LINKER_SHLIBS([TAGNAME]) # ---------------------------- # See if the linker supports building shared libraries. m4_defun([_LT_LINKER_SHLIBS], [AC_REQUIRE([LT_PATH_LD])dnl AC_REQUIRE([LT_PATH_NM])dnl m4_require([_LT_FILEUTILS_DEFAULTS])dnl m4_require([_LT_DECL_EGREP])dnl m4_require([_LT_DECL_SED])dnl m4_require([_LT_CMD_GLOBAL_SYMBOLS])dnl m4_require([_LT_TAG_COMPILER])dnl AC_MSG_CHECKING([whether the $compiler linker ($LD) supports shared libraries]) m4_if([$1], [CXX], [ _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' case $host_os in aix[[4-9]]*) # If we're using GNU nm, then we don't want the "-C" option. # -C means demangle to AIX nm, but means don't demangle with GNU nm if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then _LT_TAGVAR(export_symbols_cmds, $1)='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && ([substr](\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols' else _LT_TAGVAR(export_symbols_cmds, $1)='$NM -BCpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && ([substr](\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols' fi ;; pw32*) _LT_TAGVAR(export_symbols_cmds, $1)="$ltdll_cmds" ;; cygwin* | mingw* | cegcc*) _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[[BCDGRS]][[ ]]/s/.*[[ ]]\([[^ ]]*\)/\1 DATA/;/^.*[[ ]]__nm__/s/^.*[[ ]]__nm__\([[^ ]]*\)[[ ]][[^ ]]*/\1 DATA/;/^I[[ ]]/d;/^[[AITW]][[ ]]/s/.* //'\'' | sort | uniq > $export_symbols' ;; linux* | k*bsd*-gnu) _LT_TAGVAR(link_all_deplibs, $1)=no ;; *) _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' ;; esac _LT_TAGVAR(exclude_expsyms, $1)=['_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*'] ], [ runpath_var= _LT_TAGVAR(allow_undefined_flag, $1)= _LT_TAGVAR(always_export_symbols, $1)=no _LT_TAGVAR(archive_cmds, $1)= _LT_TAGVAR(archive_expsym_cmds, $1)= _LT_TAGVAR(compiler_needs_object, $1)=no _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no _LT_TAGVAR(export_dynamic_flag_spec, $1)= _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' _LT_TAGVAR(hardcode_automatic, $1)=no _LT_TAGVAR(hardcode_direct, $1)=no _LT_TAGVAR(hardcode_direct_absolute, $1)=no _LT_TAGVAR(hardcode_libdir_flag_spec, $1)= _LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)= _LT_TAGVAR(hardcode_libdir_separator, $1)= _LT_TAGVAR(hardcode_minus_L, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=unsupported _LT_TAGVAR(inherit_rpath, $1)=no _LT_TAGVAR(link_all_deplibs, $1)=unknown _LT_TAGVAR(module_cmds, $1)= _LT_TAGVAR(module_expsym_cmds, $1)= _LT_TAGVAR(old_archive_from_new_cmds, $1)= _LT_TAGVAR(old_archive_from_expsyms_cmds, $1)= _LT_TAGVAR(thread_safe_flag_spec, $1)= _LT_TAGVAR(whole_archive_flag_spec, $1)= # include_expsyms should be a list of space-separated symbols to be *always* # included in the symbol list _LT_TAGVAR(include_expsyms, $1)= # exclude_expsyms can be an extended regexp of symbols to exclude # it will be wrapped by ` (' and `)$', so one must not match beginning or # end of line. Example: `a|bc|.*d.*' will exclude the symbols `a' and `bc', # as well as any symbol that contains `d'. _LT_TAGVAR(exclude_expsyms, $1)=['_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*'] # Although _GLOBAL_OFFSET_TABLE_ is a valid symbol C name, most a.out # platforms (ab)use it in PIC code, but their linkers get confused if # the symbol is explicitly referenced. Since portable code cannot # rely on this symbol name, it's probably fine to never include it in # preloaded symbol tables. # Exclude shared library initialization/finalization symbols. dnl Note also adjust exclude_expsyms for C++ above. extract_expsyms_cmds= case $host_os in cygwin* | mingw* | pw32* | cegcc*) # FIXME: the MSVC++ port hasn't been tested in a loooong time # When not using gcc, we currently assume that we are using # Microsoft Visual C++. if test "$GCC" != yes; then with_gnu_ld=no fi ;; interix*) # we just hope/assume this is gcc and not c89 (= MSVC++) with_gnu_ld=yes ;; openbsd*) with_gnu_ld=no ;; linux* | k*bsd*-gnu) _LT_TAGVAR(link_all_deplibs, $1)=no ;; esac _LT_TAGVAR(ld_shlibs, $1)=yes if test "$with_gnu_ld" = yes; then # If archive_cmds runs LD, not CC, wlarc should be empty wlarc='${wl}' # Set some defaults for GNU ld with shared library support. These # are reset later if shared libraries are not supported. Putting them # here allows them to be overridden if necessary. runpath_var=LD_RUN_PATH _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic' # ancient GNU ld didn't support --whole-archive et. al. if $LD --help 2>&1 | $GREP 'no-whole-archive' > /dev/null; then _LT_TAGVAR(whole_archive_flag_spec, $1)="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive' else _LT_TAGVAR(whole_archive_flag_spec, $1)= fi supports_anon_versioning=no case `$LD -v 2>&1` in *\ [[01]].* | *\ 2.[[0-9]].* | *\ 2.10.*) ;; # catch versions < 2.11 *\ 2.11.93.0.2\ *) supports_anon_versioning=yes ;; # RH7.3 ... *\ 2.11.92.0.12\ *) supports_anon_versioning=yes ;; # Mandrake 8.2 ... *\ 2.11.*) ;; # other 2.11 versions *) supports_anon_versioning=yes ;; esac # See if GNU ld supports shared libraries. case $host_os in aix[[3-9]]*) # On AIX/PPC, the GNU linker is very broken if test "$host_cpu" != ia64; then _LT_TAGVAR(ld_shlibs, $1)=no cat <<_LT_EOF 1>&2 *** Warning: the GNU linker, at least up to release 2.9.1, is reported *** to be unable to reliably create shared libraries on AIX. *** Therefore, libtool is disabling shared libraries support. If you *** really care for shared libraries, you may want to modify your PATH *** so that a non-GNU linker is found, and then restart. _LT_EOF fi ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='' ;; m68k) _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(hardcode_minus_L, $1)=yes ;; esac ;; beos*) if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then _LT_TAGVAR(allow_undefined_flag, $1)=unsupported # Joseph Beckenbach says some releases of gcc # support --undefined. This deserves some investigation. FIXME _LT_TAGVAR(archive_cmds, $1)='$CC -nostart $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; cygwin* | mingw* | pw32* | cegcc*) # _LT_TAGVAR(hardcode_libdir_flag_spec, $1) is actually meaningless, # as there is no search path for DLLs. _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(allow_undefined_flag, $1)=unsupported _LT_TAGVAR(always_export_symbols, $1)=no _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[[BCDGRS]][[ ]]/s/.*[[ ]]\([[^ ]]*\)/\1 DATA/'\'' | $SED -e '\''/^[[AITW]][[ ]]/s/.*[[ ]]//'\'' | sort | uniq > $export_symbols' if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' # If the export-symbols file already is a .def file (1st line # is EXPORTS), use it as is; otherwise, prepend... _LT_TAGVAR(archive_expsym_cmds, $1)='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then cp $export_symbols $output_objdir/$soname.def; else echo EXPORTS > $output_objdir/$soname.def; cat $export_symbols >> $output_objdir/$soname.def; fi~ $CC -shared $output_objdir/$soname.def $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; interix[[3-9]]*) _LT_TAGVAR(hardcode_direct, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=no _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E' # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc. # Instead, shared libraries are loaded at an image base (0x10000000 by # default) and relocated if they conflict, which is a slow very memory # consuming and fragmenting process. To avoid this, we pick a random, # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link # time. Moving up from 0x10000000 also allows more sbrk(2) space. _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='sed "s,^,_," $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--retain-symbols-file,$output_objdir/$soname.expsym ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' ;; gnu* | linux* | tpf* | k*bsd*-gnu) tmp_diet=no if test "$host_os" = linux-dietlibc; then case $cc_basename in diet\ *) tmp_diet=yes;; # linux-dietlibc with static linking (!diet-dyn) esac fi if $LD --help 2>&1 | $EGREP ': supported targets:.* elf' > /dev/null \ && test "$tmp_diet" = no then tmp_addflag= tmp_sharedflag='-shared' case $cc_basename,$host_cpu in pgcc*) # Portland Group C compiler _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; $ECHO \"$new_convenience\"` ${wl}--no-whole-archive' tmp_addflag=' $pic_flag' ;; pgf77* | pgf90* | pgf95*) # Portland Group f77 and f90 compilers _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; $ECHO \"$new_convenience\"` ${wl}--no-whole-archive' tmp_addflag=' $pic_flag -Mnomain' ;; ecc*,ia64* | icc*,ia64*) # Intel C compiler on ia64 tmp_addflag=' -i_dynamic' ;; efc*,ia64* | ifort*,ia64*) # Intel Fortran compiler on ia64 tmp_addflag=' -i_dynamic -nofor_main' ;; ifc* | ifort*) # Intel Fortran compiler tmp_addflag=' -nofor_main' ;; lf95*) # Lahey Fortran 8.1 _LT_TAGVAR(whole_archive_flag_spec, $1)= tmp_sharedflag='--shared' ;; xl[[cC]]*) # IBM XL C 8.0 on PPC (deal with xlf below) tmp_sharedflag='-qmkshrobj' tmp_addflag= ;; esac case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C 5.9 _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; $ECHO \"$new_convenience\"` ${wl}--no-whole-archive' _LT_TAGVAR(compiler_needs_object, $1)=yes tmp_sharedflag='-G' ;; *Sun\ F*) # Sun Fortran 8.3 tmp_sharedflag='-G' ;; esac _LT_TAGVAR(archive_cmds, $1)='$CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' if test "x$supports_anon_versioning" = xyes; then _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $output_objdir/$libname.ver~ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ echo "local: *; };" >> $output_objdir/$libname.ver~ $CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-version-script ${wl}$output_objdir/$libname.ver -o $lib' fi case $cc_basename in xlf*) # IBM XL Fortran 10.1 on PPC cannot create shared libs itself _LT_TAGVAR(whole_archive_flag_spec, $1)='--whole-archive$convenience --no-whole-archive' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)= _LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)='-rpath $libdir' _LT_TAGVAR(archive_cmds, $1)='$LD -shared $libobjs $deplibs $compiler_flags -soname $soname -o $lib' if test "x$supports_anon_versioning" = xyes; then _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $output_objdir/$libname.ver~ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ echo "local: *; };" >> $output_objdir/$libname.ver~ $LD -shared $libobjs $deplibs $compiler_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib' fi ;; esac else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; netbsd* | netbsdelf*-gnu) if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable $libobjs $deplibs $linker_flags -o $lib' wlarc= else _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' fi ;; solaris*) if $LD -v 2>&1 | $GREP 'BFD 2\.8' > /dev/null; then _LT_TAGVAR(ld_shlibs, $1)=no cat <<_LT_EOF 1>&2 *** Warning: The releases 2.8.* of the GNU linker cannot reliably *** create shared libraries on Solaris systems. Therefore, libtool *** is disabling shared libraries support. We urge you to upgrade GNU *** binutils to release 2.9.1 or newer. Another option is to modify *** your PATH or compiler configuration so that the native linker is *** used, and then restart. _LT_EOF elif $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*) case `$LD -v 2>&1` in *\ [[01]].* | *\ 2.[[0-9]].* | *\ 2.1[[0-5]].*) _LT_TAGVAR(ld_shlibs, $1)=no cat <<_LT_EOF 1>&2 *** Warning: Releases of the GNU linker prior to 2.16.91.0.3 can not *** reliably create shared libraries on SCO systems. Therefore, libtool *** is disabling shared libraries support. We urge you to upgrade GNU *** binutils to release 2.16.91.0.3 or newer. Another option is to modify *** your PATH or compiler configuration so that the native linker is *** used, and then restart. _LT_EOF ;; *) # For security reasons, it is highly recommended that you always # use absolute paths for naming shared libraries, and exclude the # DT_RUNPATH tag from executables and libraries. But doing so # requires that you compile everything twice, which is a pain. if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; esac ;; sunos4*) _LT_TAGVAR(archive_cmds, $1)='$LD -assert pure-text -Bshareable -o $lib $libobjs $deplibs $linker_flags' wlarc= _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; *) if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; esac if test "$_LT_TAGVAR(ld_shlibs, $1)" = no; then runpath_var= _LT_TAGVAR(hardcode_libdir_flag_spec, $1)= _LT_TAGVAR(export_dynamic_flag_spec, $1)= _LT_TAGVAR(whole_archive_flag_spec, $1)= fi else # PORTME fill in a description of your system's linker (not GNU ld) case $host_os in aix3*) _LT_TAGVAR(allow_undefined_flag, $1)=unsupported _LT_TAGVAR(always_export_symbols, $1)=yes _LT_TAGVAR(archive_expsym_cmds, $1)='$LD -o $output_objdir/$soname $libobjs $deplibs $linker_flags -bE:$export_symbols -T512 -H512 -bM:SRE~$AR $AR_FLAGS $lib $output_objdir/$soname' # Note: this linker hardcodes the directories in LIBPATH if there # are no directories specified by -L. _LT_TAGVAR(hardcode_minus_L, $1)=yes if test "$GCC" = yes && test -z "$lt_prog_compiler_static"; then # Neither direct hardcoding nor static linking is supported with a # broken collect2. _LT_TAGVAR(hardcode_direct, $1)=unsupported fi ;; aix[[4-9]]*) if test "$host_cpu" = ia64; then # On IA64, the linker does run time linking by default, so we don't # have to do anything special. aix_use_runtimelinking=no exp_sym_flag='-Bexport' no_entry_flag="" else # If we're using GNU nm, then we don't want the "-C" option. # -C means demangle to AIX nm, but means don't demangle with GNU nm if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then _LT_TAGVAR(export_symbols_cmds, $1)='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && ([substr](\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols' else _LT_TAGVAR(export_symbols_cmds, $1)='$NM -BCpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && ([substr](\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols' fi aix_use_runtimelinking=no # Test if we are trying to use run time linking or normal # AIX style linking. If -brtl is somewhere in LDFLAGS, we # need to do runtime linking. case $host_os in aix4.[[23]]|aix4.[[23]].*|aix[[5-9]]*) for ld_flag in $LDFLAGS; do if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then aix_use_runtimelinking=yes break fi done ;; esac exp_sym_flag='-bexport' no_entry_flag='-bnoentry' fi # When large executables or shared objects are built, AIX ld can # have problems creating the table of contents. If linking a library # or program results in "error TOC overflow" add -mminimal-toc to # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS. _LT_TAGVAR(archive_cmds, $1)='' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_direct_absolute, $1)=yes _LT_TAGVAR(hardcode_libdir_separator, $1)=':' _LT_TAGVAR(link_all_deplibs, $1)=yes _LT_TAGVAR(file_list_spec, $1)='${wl}-f,' if test "$GCC" = yes; then case $host_os in aix4.[[012]]|aix4.[[012]].*) # We only want to do this on AIX 4.2 and lower, the check # below for broken collect2 doesn't work under 4.3+ collect2name=`${CC} -print-prog-name=collect2` if test -f "$collect2name" && strings "$collect2name" | $GREP resolve_lib_name >/dev/null then # We have reworked collect2 : else # We have old collect2 _LT_TAGVAR(hardcode_direct, $1)=unsupported # It fails to find uninstalled libraries when the uninstalled # path is not listed in the libpath. Setting hardcode_minus_L # to unsupported forces relinking _LT_TAGVAR(hardcode_minus_L, $1)=yes _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)= fi ;; esac shared_flag='-shared' if test "$aix_use_runtimelinking" = yes; then shared_flag="$shared_flag "'${wl}-G' fi _LT_TAGVAR(link_all_deplibs, $1)=no else # not using gcc if test "$host_cpu" = ia64; then # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release # chokes on -Wl,-G. The following line is correct: shared_flag='-G' else if test "$aix_use_runtimelinking" = yes; then shared_flag='${wl}-G' else shared_flag='${wl}-bM:SRE' fi fi fi _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-bexpall' # It seems that -bexpall does not export symbols beginning with # underscore (_), so it is better to generate a list of symbols to export. _LT_TAGVAR(always_export_symbols, $1)=yes if test "$aix_use_runtimelinking" = yes; then # Warning - without using the other runtime loading flags (-brtl), # -berok will link without error, but may produce a broken library. _LT_TAGVAR(allow_undefined_flag, $1)='-berok' # Determine the default libpath from the value encoded in an # empty executable. _LT_SYS_MODULE_PATH_AIX _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-blibpath:$libdir:'"$aix_libpath" _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags `if test "x${allow_undefined_flag}" != "x"; then $ECHO "X${wl}${allow_undefined_flag}" | $Xsed; else :; fi` '"\${wl}$exp_sym_flag:\$export_symbols $shared_flag" else if test "$host_cpu" = ia64; then _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R $libdir:/usr/lib:/lib' _LT_TAGVAR(allow_undefined_flag, $1)="-z nodefs" _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags ${wl}${allow_undefined_flag} '"\${wl}$exp_sym_flag:\$export_symbols" else # Determine the default libpath from the value encoded in an # empty executable. _LT_SYS_MODULE_PATH_AIX _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-blibpath:$libdir:'"$aix_libpath" # Warning - without using the other run time loading flags, # -berok will link without error, but may produce a broken library. _LT_TAGVAR(no_undefined_flag, $1)=' ${wl}-bernotok' _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-berok' # Exported symbols can be pulled into shared objects from archives _LT_TAGVAR(whole_archive_flag_spec, $1)='$convenience' _LT_TAGVAR(archive_cmds_need_lc, $1)=yes # This is similar to how AIX traditionally builds its shared libraries. _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs ${wl}-bnoentry $compiler_flags ${wl}-bE:$export_symbols${allow_undefined_flag}~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$soname' fi fi ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='' ;; m68k) _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(hardcode_minus_L, $1)=yes ;; esac ;; bsdi[[45]]*) _LT_TAGVAR(export_dynamic_flag_spec, $1)=-rdynamic ;; cygwin* | mingw* | pw32* | cegcc*) # When not using gcc, we currently assume that we are using # Microsoft Visual C++. # hardcode_libdir_flag_spec is actually meaningless, as there is # no search path for DLLs. _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=' ' _LT_TAGVAR(allow_undefined_flag, $1)=unsupported # Tell ltmain to make .lib files, not .a files. libext=lib # Tell ltmain to make .dll files, not .so files. shrext_cmds=".dll" # FIXME: Setting linknames here is a bad hack. _LT_TAGVAR(archive_cmds, $1)='$CC -o $lib $libobjs $compiler_flags `$ECHO "X$deplibs" | $Xsed -e '\''s/ -lc$//'\''` -link -dll~linknames=' # The linker will automatically build a .lib file if we build a DLL. _LT_TAGVAR(old_archive_from_new_cmds, $1)='true' # FIXME: Should let the user specify the lib program. _LT_TAGVAR(old_archive_cmds, $1)='lib -OUT:$oldlib$oldobjs$old_deplibs' _LT_TAGVAR(fix_srcfile_path, $1)='`cygpath -w "$srcfile"`' _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes ;; darwin* | rhapsody*) _LT_DARWIN_LINKER_FEATURES($1) ;; dgux*) _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; freebsd1*) _LT_TAGVAR(ld_shlibs, $1)=no ;; # FreeBSD 2.2.[012] allows us to include c++rt0.o to get C++ constructor # support. Future versions do this automatically, but an explicit c++rt0.o # does not break anything, and helps significantly (at the cost of a little # extra space). freebsd2.2*) _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags /usr/lib/c++rt0.o' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; # Unfortunately, older versions of FreeBSD 2 do not have this feature. freebsd2*) _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_minus_L, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; # FreeBSD 3 and greater uses gcc -shared to do shared libraries. freebsd* | dragonfly*) _LT_TAGVAR(archive_cmds, $1)='$CC -shared -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; hpux9*) if test "$GCC" = yes; then _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -shared -fPIC ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib' else _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$LD -b +b $install_libdir -o $output_objdir/$soname $libobjs $deplibs $linker_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib' fi _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: _LT_TAGVAR(hardcode_direct, $1)=yes # hardcode_minus_L: Not really in the search PATH, # but as the default location of the library. _LT_TAGVAR(hardcode_minus_L, $1)=yes _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E' ;; hpux10*) if test "$GCC" = yes -a "$with_gnu_ld" = no; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared -fPIC ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags' else _LT_TAGVAR(archive_cmds, $1)='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags' fi if test "$with_gnu_ld" = no; then _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)='+b $libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_direct_absolute, $1)=yes _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E' # hardcode_minus_L: Not really in the search PATH, # but as the default location of the library. _LT_TAGVAR(hardcode_minus_L, $1)=yes fi ;; hpux11*) if test "$GCC" = yes -a "$with_gnu_ld" = no; then case $host_cpu in hppa*64*) _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags' ;; ia64*) _LT_TAGVAR(archive_cmds, $1)='$CC -shared -fPIC ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' ;; *) _LT_TAGVAR(archive_cmds, $1)='$CC -shared -fPIC ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags' ;; esac else case $host_cpu in hppa*64*) _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags' ;; ia64*) _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' ;; *) _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags' ;; esac fi if test "$with_gnu_ld" = no; then _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: case $host_cpu in hppa*64*|ia64*) _LT_TAGVAR(hardcode_direct, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; *) _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_direct_absolute, $1)=yes _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E' # hardcode_minus_L: Not really in the search PATH, # but as the default location of the library. _LT_TAGVAR(hardcode_minus_L, $1)=yes ;; esac fi ;; irix5* | irix6* | nonstopux*) if test "$GCC" = yes; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib' # Try to use the -exported_symbol ld option, if it does not # work, assume that -exports_file does not work either and # implicitly export all symbols. save_LDFLAGS="$LDFLAGS" LDFLAGS="$LDFLAGS -shared ${wl}-exported_symbol ${wl}foo ${wl}-update_registry ${wl}/dev/null" AC_LINK_IFELSE(int foo(void) {}, _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations ${wl}-exports_file ${wl}$export_symbols -o $lib' ) LDFLAGS="$save_LDFLAGS" else _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -exports_file $export_symbols -o $lib' fi _LT_TAGVAR(archive_cmds_need_lc, $1)='no' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: _LT_TAGVAR(inherit_rpath, $1)=yes _LT_TAGVAR(link_all_deplibs, $1)=yes ;; netbsd* | netbsdelf*-gnu) if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' # a.out else _LT_TAGVAR(archive_cmds, $1)='$LD -shared -o $lib $libobjs $deplibs $linker_flags' # ELF fi _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; newsos6) _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; *nto* | *qnx*) ;; openbsd*) if test -f /usr/libexec/ld.so; then _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=no _LT_TAGVAR(hardcode_direct_absolute, $1)=yes if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags ${wl}-retain-symbols-file,$export_symbols' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E' else case $host_os in openbsd[[01]].* | openbsd2.[[0-7]] | openbsd2.[[0-7]].*) _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' ;; *) _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir' ;; esac fi else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; os2*) _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(hardcode_minus_L, $1)=yes _LT_TAGVAR(allow_undefined_flag, $1)=unsupported _LT_TAGVAR(archive_cmds, $1)='$ECHO "LIBRARY $libname INITINSTANCE" > $output_objdir/$libname.def~$ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~$ECHO DATA >> $output_objdir/$libname.def~$ECHO " SINGLE NONSHARED" >> $output_objdir/$libname.def~$ECHO EXPORTS >> $output_objdir/$libname.def~emxexp $libobjs >> $output_objdir/$libname.def~$CC -Zdll -Zcrtdll -o $lib $libobjs $deplibs $compiler_flags $output_objdir/$libname.def' _LT_TAGVAR(old_archive_from_new_cmds, $1)='emximp -o $output_objdir/$libname.a $output_objdir/$libname.def' ;; osf3*) if test "$GCC" = yes; then _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-expect_unresolved ${wl}\*' _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib' else _LT_TAGVAR(allow_undefined_flag, $1)=' -expect_unresolved \*' _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib' fi _LT_TAGVAR(archive_cmds_need_lc, $1)='no' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: ;; osf4* | osf5*) # as osf3* with the addition of -msym flag if test "$GCC" = yes; then _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-expect_unresolved ${wl}\*' _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags ${wl}-msym ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' else _LT_TAGVAR(allow_undefined_flag, $1)=' -expect_unresolved \*' _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -msym -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done; printf "%s\\n" "-hidden">> $lib.exp~ $CC -shared${allow_undefined_flag} ${wl}-input ${wl}$lib.exp $compiler_flags $libobjs $deplibs -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib~$RM $lib.exp' # Both c and cxx compiler support -rpath directly _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-rpath $libdir' fi _LT_TAGVAR(archive_cmds_need_lc, $1)='no' _LT_TAGVAR(hardcode_libdir_separator, $1)=: ;; solaris*) _LT_TAGVAR(no_undefined_flag, $1)=' -z defs' if test "$GCC" = yes; then wlarc='${wl}' _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}-z ${wl}text ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -shared ${wl}-z ${wl}text ${wl}-M ${wl}$lib.exp ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' else case `$CC -V 2>&1` in *"Compilers 5.0"*) wlarc='' _LT_TAGVAR(archive_cmds, $1)='$LD -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $LD -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $linker_flags~$RM $lib.exp' ;; *) wlarc='${wl}' _LT_TAGVAR(archive_cmds, $1)='$CC -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' ;; esac fi _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' _LT_TAGVAR(hardcode_shlibpath_var, $1)=no case $host_os in solaris2.[[0-5]] | solaris2.[[0-5]].*) ;; *) # The compiler driver will combine and reorder linker options, # but understands `-z linker_flag'. GCC discards it without `$wl', # but is careful enough not to reorder. # Supported since Solaris 2.6 (maybe 2.5.1?) if test "$GCC" = yes; then _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}-z ${wl}allextract$convenience ${wl}-z ${wl}defaultextract' else _LT_TAGVAR(whole_archive_flag_spec, $1)='-z allextract$convenience -z defaultextract' fi ;; esac _LT_TAGVAR(link_all_deplibs, $1)=yes ;; sunos4*) if test "x$host_vendor" = xsequent; then # Use $CC to link under sequent, because it throws in some extra .o # files that make .init and .fini sections work. _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h $soname -o $lib $libobjs $deplibs $compiler_flags' else _LT_TAGVAR(archive_cmds, $1)='$LD -assert pure-text -Bstatic -o $lib $libobjs $deplibs $linker_flags' fi _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_minus_L, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; sysv4) case $host_vendor in sni) _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(hardcode_direct, $1)=yes # is this really true??? ;; siemens) ## LD is ld it makes a PLAMLIB ## CC just makes a GrossModule. _LT_TAGVAR(archive_cmds, $1)='$LD -G -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(reload_cmds, $1)='$CC -r -o $output$reload_objs' _LT_TAGVAR(hardcode_direct, $1)=no ;; motorola) _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(hardcode_direct, $1)=no #Motorola manual says yes, but my tests say they lie ;; esac runpath_var='LD_RUN_PATH' _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; sysv4.3*) _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(hardcode_shlibpath_var, $1)=no _LT_TAGVAR(export_dynamic_flag_spec, $1)='-Bexport' ;; sysv4*MP*) if test -d /usr/nec; then _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(hardcode_shlibpath_var, $1)=no runpath_var=LD_RUN_PATH hardcode_runpath_var=yes _LT_TAGVAR(ld_shlibs, $1)=yes fi ;; sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[[01]].[[10]]* | unixware7* | sco3.2v5.0.[[024]]*) _LT_TAGVAR(no_undefined_flag, $1)='${wl}-z,text' _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=no runpath_var='LD_RUN_PATH' if test "$GCC" = yes; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' else _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' fi ;; sysv5* | sco3.2v5* | sco5v6*) # Note: We can NOT use -z defs as we might desire, because we do not # link with -lc, and that would cause any symbols used from libc to # always be unresolved, which means just about no library would # ever link correctly. If we're not using GNU ld we use -z text # though, which does catch some bad symbols but isn't as heavy-handed # as -z defs. _LT_TAGVAR(no_undefined_flag, $1)='${wl}-z,text' _LT_TAGVAR(allow_undefined_flag, $1)='${wl}-z,nodefs' _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=no _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R,$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=':' _LT_TAGVAR(link_all_deplibs, $1)=yes _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-Bexport' runpath_var='LD_RUN_PATH' if test "$GCC" = yes; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' else _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' fi ;; uts4*) _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; *) _LT_TAGVAR(ld_shlibs, $1)=no ;; esac if test x$host_vendor = xsni; then case $host in sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*) _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-Blargedynsym' ;; esac fi fi ]) AC_MSG_RESULT([$_LT_TAGVAR(ld_shlibs, $1)]) test "$_LT_TAGVAR(ld_shlibs, $1)" = no && can_build_shared=no _LT_TAGVAR(with_gnu_ld, $1)=$with_gnu_ld _LT_DECL([], [libext], [0], [Old archive suffix (normally "a")])dnl _LT_DECL([], [shrext_cmds], [1], [Shared library suffix (normally ".so")])dnl _LT_DECL([], [extract_expsyms_cmds], [2], [The commands to extract the exported symbol list from a shared archive]) # # Do we need to explicitly link libc? # case "x$_LT_TAGVAR(archive_cmds_need_lc, $1)" in x|xyes) # Assume -lc should be added _LT_TAGVAR(archive_cmds_need_lc, $1)=yes if test "$enable_shared" = yes && test "$GCC" = yes; then case $_LT_TAGVAR(archive_cmds, $1) in *'~'*) # FIXME: we may have to deal with multi-command sequences. ;; '$CC '*) # Test whether the compiler implicitly links with -lc since on some # systems, -lgcc has to come before -lc. If gcc already passes -lc # to ld, don't add -lc before -lgcc. AC_MSG_CHECKING([whether -lc should be explicitly linked in]) $RM conftest* echo "$lt_simple_compile_test_code" > conftest.$ac_ext if AC_TRY_EVAL(ac_compile) 2>conftest.err; then soname=conftest lib=conftest libobjs=conftest.$ac_objext deplibs= wl=$_LT_TAGVAR(lt_prog_compiler_wl, $1) pic_flag=$_LT_TAGVAR(lt_prog_compiler_pic, $1) compiler_flags=-v linker_flags=-v verstring= output_objdir=. libname=conftest lt_save_allow_undefined_flag=$_LT_TAGVAR(allow_undefined_flag, $1) _LT_TAGVAR(allow_undefined_flag, $1)= if AC_TRY_EVAL(_LT_TAGVAR(archive_cmds, $1) 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1) then _LT_TAGVAR(archive_cmds_need_lc, $1)=no else _LT_TAGVAR(archive_cmds_need_lc, $1)=yes fi _LT_TAGVAR(allow_undefined_flag, $1)=$lt_save_allow_undefined_flag else cat conftest.err 1>&5 fi $RM conftest* AC_MSG_RESULT([$_LT_TAGVAR(archive_cmds_need_lc, $1)]) ;; esac fi ;; esac _LT_TAGDECL([build_libtool_need_lc], [archive_cmds_need_lc], [0], [Whether or not to add -lc for building shared libraries]) _LT_TAGDECL([allow_libtool_libs_with_static_runtimes], [enable_shared_with_static_runtimes], [0], [Whether or not to disallow shared libs when runtime libs are static]) _LT_TAGDECL([], [export_dynamic_flag_spec], [1], [Compiler flag to allow reflexive dlopens]) _LT_TAGDECL([], [whole_archive_flag_spec], [1], [Compiler flag to generate shared objects directly from archives]) _LT_TAGDECL([], [compiler_needs_object], [1], [Whether the compiler copes with passing no objects directly]) _LT_TAGDECL([], [old_archive_from_new_cmds], [2], [Create an old-style archive from a shared archive]) _LT_TAGDECL([], [old_archive_from_expsyms_cmds], [2], [Create a temporary old-style archive to link instead of a shared archive]) _LT_TAGDECL([], [archive_cmds], [2], [Commands used to build a shared archive]) _LT_TAGDECL([], [archive_expsym_cmds], [2]) _LT_TAGDECL([], [module_cmds], [2], [Commands used to build a loadable module if different from building a shared archive.]) _LT_TAGDECL([], [module_expsym_cmds], [2]) _LT_TAGDECL([], [with_gnu_ld], [1], [Whether we are building with GNU ld or not]) _LT_TAGDECL([], [allow_undefined_flag], [1], [Flag that allows shared libraries with undefined symbols to be built]) _LT_TAGDECL([], [no_undefined_flag], [1], [Flag that enforces no undefined symbols]) _LT_TAGDECL([], [hardcode_libdir_flag_spec], [1], [Flag to hardcode $libdir into a binary during linking. This must work even if $libdir does not exist]) _LT_TAGDECL([], [hardcode_libdir_flag_spec_ld], [1], [[If ld is used when linking, flag to hardcode $libdir into a binary during linking. This must work even if $libdir does not exist]]) _LT_TAGDECL([], [hardcode_libdir_separator], [1], [Whether we need a single "-rpath" flag with a separated argument]) _LT_TAGDECL([], [hardcode_direct], [0], [Set to "yes" if using DIR/libNAME${shared_ext} during linking hardcodes DIR into the resulting binary]) _LT_TAGDECL([], [hardcode_direct_absolute], [0], [Set to "yes" if using DIR/libNAME${shared_ext} during linking hardcodes DIR into the resulting binary and the resulting library dependency is "absolute", i.e impossible to change by setting ${shlibpath_var} if the library is relocated]) _LT_TAGDECL([], [hardcode_minus_L], [0], [Set to "yes" if using the -LDIR flag during linking hardcodes DIR into the resulting binary]) _LT_TAGDECL([], [hardcode_shlibpath_var], [0], [Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR into the resulting binary]) _LT_TAGDECL([], [hardcode_automatic], [0], [Set to "yes" if building a shared library automatically hardcodes DIR into the library and all subsequent libraries and executables linked against it]) _LT_TAGDECL([], [inherit_rpath], [0], [Set to yes if linker adds runtime paths of dependent libraries to runtime path list]) _LT_TAGDECL([], [link_all_deplibs], [0], [Whether libtool must link a program against all its dependency libraries]) _LT_TAGDECL([], [fix_srcfile_path], [1], [Fix the shell variable $srcfile for the compiler]) _LT_TAGDECL([], [always_export_symbols], [0], [Set to "yes" if exported symbols are required]) _LT_TAGDECL([], [export_symbols_cmds], [2], [The commands to list exported symbols]) _LT_TAGDECL([], [exclude_expsyms], [1], [Symbols that should not be listed in the preloaded symbols]) _LT_TAGDECL([], [include_expsyms], [1], [Symbols that must always be exported]) _LT_TAGDECL([], [prelink_cmds], [2], [Commands necessary for linking programs (against libraries) with templates]) _LT_TAGDECL([], [file_list_spec], [1], [Specify filename containing input files]) dnl FIXME: Not yet implemented dnl _LT_TAGDECL([], [thread_safe_flag_spec], [1], dnl [Compiler flag to generate thread safe objects]) ])# _LT_LINKER_SHLIBS # _LT_LANG_C_CONFIG([TAG]) # ------------------------ # Ensure that the configuration variables for a C compiler are suitably # defined. These variables are subsequently used by _LT_CONFIG to write # the compiler configuration to `libtool'. m4_defun([_LT_LANG_C_CONFIG], [m4_require([_LT_DECL_EGREP])dnl lt_save_CC="$CC" AC_LANG_PUSH(C) # Source file extension for C test sources. ac_ext=c # Object file extension for compiled C test sources. objext=o _LT_TAGVAR(objext, $1)=$objext # Code to be used in simple compile tests lt_simple_compile_test_code="int some_variable = 0;" # Code to be used in simple link tests lt_simple_link_test_code='int main(){return(0);}' _LT_TAG_COMPILER # Save the default compiler, since it gets overwritten when the other # tags are being tested, and _LT_TAGVAR(compiler, []) is a NOP. compiler_DEFAULT=$CC # save warnings/boilerplate of simple test code _LT_COMPILER_BOILERPLATE _LT_LINKER_BOILERPLATE ## CAVEAT EMPTOR: ## There is no encapsulation within the following macros, do not change ## the running order or otherwise move them around unless you know exactly ## what you are doing... if test -n "$compiler"; then _LT_COMPILER_NO_RTTI($1) _LT_COMPILER_PIC($1) _LT_COMPILER_C_O($1) _LT_COMPILER_FILE_LOCKS($1) _LT_LINKER_SHLIBS($1) _LT_SYS_DYNAMIC_LINKER($1) _LT_LINKER_HARDCODE_LIBPATH($1) LT_SYS_DLOPEN_SELF _LT_CMD_STRIPLIB # Report which library types will actually be built AC_MSG_CHECKING([if libtool supports shared libraries]) AC_MSG_RESULT([$can_build_shared]) AC_MSG_CHECKING([whether to build shared libraries]) test "$can_build_shared" = "no" && enable_shared=no # On AIX, shared libraries and static libraries use the same namespace, and # are all built from PIC. case $host_os in aix3*) test "$enable_shared" = yes && enable_static=no if test -n "$RANLIB"; then archive_cmds="$archive_cmds~\$RANLIB \$lib" postinstall_cmds='$RANLIB $lib' fi ;; aix[[4-9]]*) if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then test "$enable_shared" = yes && enable_static=no fi ;; esac AC_MSG_RESULT([$enable_shared]) AC_MSG_CHECKING([whether to build static libraries]) # Make sure either enable_shared or enable_static is yes. test "$enable_shared" = yes || enable_static=yes AC_MSG_RESULT([$enable_static]) _LT_CONFIG($1) fi AC_LANG_POP CC="$lt_save_CC" ])# _LT_LANG_C_CONFIG # _LT_PROG_CXX # ------------ # Since AC_PROG_CXX is broken, in that it returns g++ if there is no c++ # compiler, we have our own version here. m4_defun([_LT_PROG_CXX], [ pushdef([AC_MSG_ERROR], [_lt_caught_CXX_error=yes]) AC_PROG_CXX if test -n "$CXX" && ( test "X$CXX" != "Xno" && ( (test "X$CXX" = "Xg++" && `g++ -v >/dev/null 2>&1` ) || (test "X$CXX" != "Xg++"))) ; then AC_PROG_CXXCPP else _lt_caught_CXX_error=yes fi popdef([AC_MSG_ERROR]) ])# _LT_PROG_CXX dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([_LT_PROG_CXX], []) # _LT_LANG_CXX_CONFIG([TAG]) # -------------------------- # Ensure that the configuration variables for a C++ compiler are suitably # defined. These variables are subsequently used by _LT_CONFIG to write # the compiler configuration to `libtool'. m4_defun([_LT_LANG_CXX_CONFIG], [AC_REQUIRE([_LT_PROG_CXX])dnl m4_require([_LT_FILEUTILS_DEFAULTS])dnl m4_require([_LT_DECL_EGREP])dnl AC_LANG_PUSH(C++) _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(allow_undefined_flag, $1)= _LT_TAGVAR(always_export_symbols, $1)=no _LT_TAGVAR(archive_expsym_cmds, $1)= _LT_TAGVAR(compiler_needs_object, $1)=no _LT_TAGVAR(export_dynamic_flag_spec, $1)= _LT_TAGVAR(hardcode_direct, $1)=no _LT_TAGVAR(hardcode_direct_absolute, $1)=no _LT_TAGVAR(hardcode_libdir_flag_spec, $1)= _LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)= _LT_TAGVAR(hardcode_libdir_separator, $1)= _LT_TAGVAR(hardcode_minus_L, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=unsupported _LT_TAGVAR(hardcode_automatic, $1)=no _LT_TAGVAR(inherit_rpath, $1)=no _LT_TAGVAR(module_cmds, $1)= _LT_TAGVAR(module_expsym_cmds, $1)= _LT_TAGVAR(link_all_deplibs, $1)=unknown _LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds _LT_TAGVAR(no_undefined_flag, $1)= _LT_TAGVAR(whole_archive_flag_spec, $1)= _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no # Source file extension for C++ test sources. ac_ext=cpp # Object file extension for compiled C++ test sources. objext=o _LT_TAGVAR(objext, $1)=$objext # No sense in running all these tests if we already determined that # the CXX compiler isn't working. Some variables (like enable_shared) # are currently assumed to apply to all compilers on this platform, # and will be corrupted by setting them based on a non-working compiler. if test "$_lt_caught_CXX_error" != yes; then # Code to be used in simple compile tests lt_simple_compile_test_code="int some_variable = 0;" # Code to be used in simple link tests lt_simple_link_test_code='int main(int, char *[[]]) { return(0); }' # ltmain only uses $CC for tagged configurations so make sure $CC is set. _LT_TAG_COMPILER # save warnings/boilerplate of simple test code _LT_COMPILER_BOILERPLATE _LT_LINKER_BOILERPLATE # Allow CC to be a program name with arguments. lt_save_CC=$CC lt_save_LD=$LD lt_save_GCC=$GCC GCC=$GXX lt_save_with_gnu_ld=$with_gnu_ld lt_save_path_LD=$lt_cv_path_LD if test -n "${lt_cv_prog_gnu_ldcxx+set}"; then lt_cv_prog_gnu_ld=$lt_cv_prog_gnu_ldcxx else $as_unset lt_cv_prog_gnu_ld fi if test -n "${lt_cv_path_LDCXX+set}"; then lt_cv_path_LD=$lt_cv_path_LDCXX else $as_unset lt_cv_path_LD fi test -z "${LDCXX+set}" || LD=$LDCXX CC=${CXX-"c++"} compiler=$CC _LT_TAGVAR(compiler, $1)=$CC _LT_CC_BASENAME([$compiler]) if test -n "$compiler"; then # We don't want -fno-exception when compiling C++ code, so set the # no_builtin_flag separately if test "$GXX" = yes; then _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -fno-builtin' else _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)= fi if test "$GXX" = yes; then # Set up default GNU C++ configuration LT_PATH_LD # Check if GNU C++ uses GNU ld as the underlying linker, since the # archiving commands below assume that GNU ld is being used. if test "$with_gnu_ld" = yes; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic' # If archive_cmds runs LD, not CC, wlarc should be empty # XXX I think wlarc can be eliminated in ltcf-cxx, but I need to # investigate it a little bit more. (MM) wlarc='${wl}' # ancient GNU ld didn't support --whole-archive et. al. if eval "`$CC -print-prog-name=ld` --help 2>&1" | $GREP 'no-whole-archive' > /dev/null; then _LT_TAGVAR(whole_archive_flag_spec, $1)="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive' else _LT_TAGVAR(whole_archive_flag_spec, $1)= fi else with_gnu_ld=no wlarc= # A generic and very simple default shared library creation # command for GNU C++ for the case where it uses the native # linker, instead of GNU ld. If possible, this setting should # overridden to take advantage of the native linker features on # the platform it is being used on. _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $lib' fi # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "\-L"' else GXX=no with_gnu_ld=no wlarc= fi # PORTME: fill in a description of your system's C++ link characteristics AC_MSG_CHECKING([whether the $compiler linker ($LD) supports shared libraries]) _LT_TAGVAR(ld_shlibs, $1)=yes case $host_os in aix3*) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; aix[[4-9]]*) if test "$host_cpu" = ia64; then # On IA64, the linker does run time linking by default, so we don't # have to do anything special. aix_use_runtimelinking=no exp_sym_flag='-Bexport' no_entry_flag="" else aix_use_runtimelinking=no # Test if we are trying to use run time linking or normal # AIX style linking. If -brtl is somewhere in LDFLAGS, we # need to do runtime linking. case $host_os in aix4.[[23]]|aix4.[[23]].*|aix[[5-9]]*) for ld_flag in $LDFLAGS; do case $ld_flag in *-brtl*) aix_use_runtimelinking=yes break ;; esac done ;; esac exp_sym_flag='-bexport' no_entry_flag='-bnoentry' fi # When large executables or shared objects are built, AIX ld can # have problems creating the table of contents. If linking a library # or program results in "error TOC overflow" add -mminimal-toc to # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS. _LT_TAGVAR(archive_cmds, $1)='' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_direct_absolute, $1)=yes _LT_TAGVAR(hardcode_libdir_separator, $1)=':' _LT_TAGVAR(link_all_deplibs, $1)=yes _LT_TAGVAR(file_list_spec, $1)='${wl}-f,' if test "$GXX" = yes; then case $host_os in aix4.[[012]]|aix4.[[012]].*) # We only want to do this on AIX 4.2 and lower, the check # below for broken collect2 doesn't work under 4.3+ collect2name=`${CC} -print-prog-name=collect2` if test -f "$collect2name" && strings "$collect2name" | $GREP resolve_lib_name >/dev/null then # We have reworked collect2 : else # We have old collect2 _LT_TAGVAR(hardcode_direct, $1)=unsupported # It fails to find uninstalled libraries when the uninstalled # path is not listed in the libpath. Setting hardcode_minus_L # to unsupported forces relinking _LT_TAGVAR(hardcode_minus_L, $1)=yes _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)= fi esac shared_flag='-shared' if test "$aix_use_runtimelinking" = yes; then shared_flag="$shared_flag "'${wl}-G' fi else # not using gcc if test "$host_cpu" = ia64; then # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release # chokes on -Wl,-G. The following line is correct: shared_flag='-G' else if test "$aix_use_runtimelinking" = yes; then shared_flag='${wl}-G' else shared_flag='${wl}-bM:SRE' fi fi fi _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-bexpall' # It seems that -bexpall does not export symbols beginning with # underscore (_), so it is better to generate a list of symbols to # export. _LT_TAGVAR(always_export_symbols, $1)=yes if test "$aix_use_runtimelinking" = yes; then # Warning - without using the other runtime loading flags (-brtl), # -berok will link without error, but may produce a broken library. _LT_TAGVAR(allow_undefined_flag, $1)='-berok' # Determine the default libpath from the value encoded in an empty # executable. _LT_SYS_MODULE_PATH_AIX _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-blibpath:$libdir:'"$aix_libpath" _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags `if test "x${allow_undefined_flag}" != "x"; then $ECHO "X${wl}${allow_undefined_flag}" | $Xsed; else :; fi` '"\${wl}$exp_sym_flag:\$export_symbols $shared_flag" else if test "$host_cpu" = ia64; then _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R $libdir:/usr/lib:/lib' _LT_TAGVAR(allow_undefined_flag, $1)="-z nodefs" _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags ${wl}${allow_undefined_flag} '"\${wl}$exp_sym_flag:\$export_symbols" else # Determine the default libpath from the value encoded in an # empty executable. _LT_SYS_MODULE_PATH_AIX _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-blibpath:$libdir:'"$aix_libpath" # Warning - without using the other run time loading flags, # -berok will link without error, but may produce a broken library. _LT_TAGVAR(no_undefined_flag, $1)=' ${wl}-bernotok' _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-berok' # Exported symbols can be pulled into shared objects from archives _LT_TAGVAR(whole_archive_flag_spec, $1)='$convenience' _LT_TAGVAR(archive_cmds_need_lc, $1)=yes # This is similar to how AIX traditionally builds its shared # libraries. _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs ${wl}-bnoentry $compiler_flags ${wl}-bE:$export_symbols${allow_undefined_flag}~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$soname' fi fi ;; beos*) if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then _LT_TAGVAR(allow_undefined_flag, $1)=unsupported # Joseph Beckenbach says some releases of gcc # support --undefined. This deserves some investigation. FIXME _LT_TAGVAR(archive_cmds, $1)='$CC -nostart $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; chorus*) case $cc_basename in *) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; esac ;; cygwin* | mingw* | pw32* | cegcc*) # _LT_TAGVAR(hardcode_libdir_flag_spec, $1) is actually meaningless, # as there is no search path for DLLs. _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' _LT_TAGVAR(allow_undefined_flag, $1)=unsupported _LT_TAGVAR(always_export_symbols, $1)=no _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' # If the export-symbols file already is a .def file (1st line # is EXPORTS), use it as is; otherwise, prepend... _LT_TAGVAR(archive_expsym_cmds, $1)='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then cp $export_symbols $output_objdir/$soname.def; else echo EXPORTS > $output_objdir/$soname.def; cat $export_symbols >> $output_objdir/$soname.def; fi~ $CC -shared -nostdlib $output_objdir/$soname.def $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; darwin* | rhapsody*) _LT_DARWIN_LINKER_FEATURES($1) ;; dgux*) case $cc_basename in ec++*) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; ghcx*) # Green Hills C++ Compiler # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; *) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; esac ;; freebsd[[12]]*) # C++ shared libraries reported to be fairly broken before # switch to ELF _LT_TAGVAR(ld_shlibs, $1)=no ;; freebsd-elf*) _LT_TAGVAR(archive_cmds_need_lc, $1)=no ;; freebsd* | dragonfly*) # FreeBSD 3 and later use GNU C++ and GNU ld with standard ELF # conventions _LT_TAGVAR(ld_shlibs, $1)=yes ;; gnu*) ;; hpux9*) _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_minus_L, $1)=yes # Not in the search PATH, # but as the default # location of the library. case $cc_basename in CC*) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; aCC*) _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -b ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib' # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`($CC -b $CFLAGS -v conftest.$objext 2>&1) | $EGREP "\-L"`; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; $ECHO "X$list" | $Xsed' ;; *) if test "$GXX" = yes; then _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -shared -nostdlib -fPIC ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib' else # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no fi ;; esac ;; hpux10*|hpux11*) if test $with_gnu_ld = no; then _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: case $host_cpu in hppa*64*|ia64*) ;; *) _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E' ;; esac fi case $host_cpu in hppa*64*|ia64*) _LT_TAGVAR(hardcode_direct, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=no ;; *) _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_direct_absolute, $1)=yes _LT_TAGVAR(hardcode_minus_L, $1)=yes # Not in the search PATH, # but as the default # location of the library. ;; esac case $cc_basename in CC*) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; aCC*) case $host_cpu in hppa*64*) _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; ia64*) _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; *) _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; esac # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`($CC -b $CFLAGS -v conftest.$objext 2>&1) | $GREP "\-L"`; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; $ECHO "X$list" | $Xsed' ;; *) if test "$GXX" = yes; then if test $with_gnu_ld = no; then case $host_cpu in hppa*64*) _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib -fPIC ${wl}+h ${wl}$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; ia64*) _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib -fPIC ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; *) _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib -fPIC ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; esac fi else # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no fi ;; esac ;; interix[[3-9]]*) _LT_TAGVAR(hardcode_direct, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=no _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E' # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc. # Instead, shared libraries are loaded at an image base (0x10000000 by # default) and relocated if they conflict, which is a slow very memory # consuming and fragmenting process. To avoid this, we pick a random, # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link # time. Moving up from 0x10000000 also allows more sbrk(2) space. _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='sed "s,^,_," $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--retain-symbols-file,$output_objdir/$soname.expsym ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' ;; irix5* | irix6*) case $cc_basename in CC*) # SGI C++ _LT_TAGVAR(archive_cmds, $1)='$CC -shared -all -multigot $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib' # Archives containing C++ object files must be created using # "CC -ar", where "CC" is the IRIX C++ compiler. This is # necessary to make sure instantiated templates are included # in the archive. _LT_TAGVAR(old_archive_cmds, $1)='$CC -ar -WR,-u -o $oldlib $oldobjs' ;; *) if test "$GXX" = yes; then if test "$with_gnu_ld" = no; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib' else _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` -o $lib' fi fi _LT_TAGVAR(link_all_deplibs, $1)=yes ;; esac _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: _LT_TAGVAR(inherit_rpath, $1)=yes ;; linux* | k*bsd*-gnu) case $cc_basename in KCC*) # Kuck and Associates, Inc. (KAI) C++ Compiler # KCC will only create a shared library if the output file # ends with ".so" (or ".sl" for HP-UX), so rename the library # to its proper name (with version) after linking. _LT_TAGVAR(archive_cmds, $1)='tempext=`echo $shared_ext | $SED -e '\''s/\([[^()0-9A-Za-z{}]]\)/\\\\\1/g'\''`; templib=`echo $lib | $SED -e "s/\${tempext}\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib; mv \$templib $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='tempext=`echo $shared_ext | $SED -e '\''s/\([[^()0-9A-Za-z{}]]\)/\\\\\1/g'\''`; templib=`echo $lib | $SED -e "s/\${tempext}\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib ${wl}-retain-symbols-file,$export_symbols; mv \$templib $lib' # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`$CC $CFLAGS -v conftest.$objext -o libconftest$shared_ext 2>&1 | $GREP "ld"`; rm -f libconftest$shared_ext; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; $ECHO "X$list" | $Xsed' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic' # Archives containing C++ object files must be created using # "CC -Bstatic", where "CC" is the KAI C++ compiler. _LT_TAGVAR(old_archive_cmds, $1)='$CC -Bstatic -o $oldlib $oldobjs' ;; icpc* | ecpc* ) # Intel C++ with_gnu_ld=yes # version 8.0 and above of icpc choke on multiply defined symbols # if we add $predep_objects and $postdep_objects, however 7.1 and # earlier do not add the objects themselves. case `$CC -V 2>&1` in *"Version 7."*) _LT_TAGVAR(archive_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' ;; *) # Version 8.0 or newer tmp_idyn= case $host_cpu in ia64*) tmp_idyn=' -i_dynamic';; esac _LT_TAGVAR(archive_cmds, $1)='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib' ;; esac _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic' _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive$convenience ${wl}--no-whole-archive' ;; pgCC* | pgcpp*) # Portland Group C++ compiler case `$CC -V` in *pgCC\ [[1-5]]* | *pgcpp\ [[1-5]]*) _LT_TAGVAR(prelink_cmds, $1)='tpldir=Template.dir~ rm -rf $tpldir~ $CC --prelink_objects --instantiation_dir $tpldir $objs $libobjs $compile_deplibs~ compile_command="$compile_command `find $tpldir -name \*.o | $NL2SP`"' _LT_TAGVAR(old_archive_cmds, $1)='tpldir=Template.dir~ rm -rf $tpldir~ $CC --prelink_objects --instantiation_dir $tpldir $oldobjs$old_deplibs~ $AR $AR_FLAGS $oldlib$oldobjs$old_deplibs `find $tpldir -name \*.o | $NL2SP`~ $RANLIB $oldlib' _LT_TAGVAR(archive_cmds, $1)='tpldir=Template.dir~ rm -rf $tpldir~ $CC --prelink_objects --instantiation_dir $tpldir $predep_objects $libobjs $deplibs $convenience $postdep_objects~ $CC -shared $pic_flag $predep_objects $libobjs $deplibs `find $tpldir -name \*.o | $NL2SP` $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='tpldir=Template.dir~ rm -rf $tpldir~ $CC --prelink_objects --instantiation_dir $tpldir $predep_objects $libobjs $deplibs $convenience $postdep_objects~ $CC -shared $pic_flag $predep_objects $libobjs $deplibs `find $tpldir -name \*.o | $NL2SP` $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname ${wl}-retain-symbols-file ${wl}$export_symbols -o $lib' ;; *) # Version 6 will use weak symbols _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname ${wl}-retain-symbols-file ${wl}$export_symbols -o $lib' ;; esac _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}--rpath ${wl}$libdir' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic' _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; $ECHO \"$new_convenience\"` ${wl}--no-whole-archive' ;; cxx*) # Compaq C++ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname -o $lib ${wl}-retain-symbols-file $wl$export_symbols' runpath_var=LD_RUN_PATH _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-rpath $libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "ld"`; templist=`$ECHO "X$templist" | $Xsed -e "s/\(^.*ld.*\)\( .*ld .*$\)/\1/"`; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; $ECHO "X$list" | $Xsed' ;; xl*) # IBM XL 8.0 on PPC, with GNU ld _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic' _LT_TAGVAR(archive_cmds, $1)='$CC -qmkshrobj $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib' if test "x$supports_anon_versioning" = xyes; then _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $output_objdir/$libname.ver~ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ echo "local: *; };" >> $output_objdir/$libname.ver~ $CC -qmkshrobj $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-version-script ${wl}$output_objdir/$libname.ver -o $lib' fi ;; *) case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C++ 5.9 _LT_TAGVAR(no_undefined_flag, $1)=' -zdefs' _LT_TAGVAR(archive_cmds, $1)='$CC -G${allow_undefined_flag} -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G${allow_undefined_flag} -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-retain-symbols-file ${wl}$export_symbols' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; $ECHO \"$new_convenience\"` ${wl}--no-whole-archive' _LT_TAGVAR(compiler_needs_object, $1)=yes # Not sure whether something based on # $CC $CFLAGS -v conftest.$objext -o libconftest$shared_ext 2>&1 # would be better. output_verbose_link_cmd='echo' # Archives containing C++ object files must be created using # "CC -xar", where "CC" is the Sun C++ compiler. This is # necessary to make sure instantiated templates are included # in the archive. _LT_TAGVAR(old_archive_cmds, $1)='$CC -xar -o $oldlib $oldobjs' ;; esac ;; esac ;; lynxos*) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; m88k*) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; mvs*) case $cc_basename in cxx*) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; *) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; esac ;; netbsd*) if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $predep_objects $libobjs $deplibs $postdep_objects $linker_flags' wlarc= _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=no fi # Workaround some broken pre-1.5 toolchains output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP conftest.$objext | $SED -e "s:-lgcc -lc -lgcc::"' ;; *nto* | *qnx*) _LT_TAGVAR(ld_shlibs, $1)=yes ;; openbsd2*) # C++ shared libraries are fairly broken _LT_TAGVAR(ld_shlibs, $1)=no ;; openbsd*) if test -f /usr/libexec/ld.so; then _LT_TAGVAR(hardcode_direct, $1)=yes _LT_TAGVAR(hardcode_shlibpath_var, $1)=no _LT_TAGVAR(hardcode_direct_absolute, $1)=yes _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $lib' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir' if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-retain-symbols-file,$export_symbols -o $lib' _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E' _LT_TAGVAR(whole_archive_flag_spec, $1)="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive' fi output_verbose_link_cmd=echo else _LT_TAGVAR(ld_shlibs, $1)=no fi ;; osf3* | osf4* | osf5*) case $cc_basename in KCC*) # Kuck and Associates, Inc. (KAI) C++ Compiler # KCC will only create a shared library if the output file # ends with ".so" (or ".sl" for HP-UX), so rename the library # to its proper name (with version) after linking. _LT_TAGVAR(archive_cmds, $1)='tempext=`echo $shared_ext | $SED -e '\''s/\([[^()0-9A-Za-z{}]]\)/\\\\\1/g'\''`; templib=`echo "$lib" | $SED -e "s/\${tempext}\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib; mv \$templib $lib' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: # Archives containing C++ object files must be created using # the KAI C++ compiler. case $host in osf3*) _LT_TAGVAR(old_archive_cmds, $1)='$CC -Bstatic -o $oldlib $oldobjs' ;; *) _LT_TAGVAR(old_archive_cmds, $1)='$CC -o $oldlib $oldobjs' ;; esac ;; RCC*) # Rational C++ 2.4.1 # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; cxx*) case $host in osf3*) _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-expect_unresolved ${wl}\*' _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $soname `test -n "$verstring" && $ECHO "X${wl}-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' ;; *) _LT_TAGVAR(allow_undefined_flag, $1)=' -expect_unresolved \*' _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -msym -soname $soname `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done~ echo "-hidden">> $lib.exp~ $CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -msym -soname $soname ${wl}-input ${wl}$lib.exp `test -n "$verstring" && $ECHO "X-set_version $verstring" | $Xsed` -update_registry ${output_objdir}/so_locations -o $lib~ $RM $lib.exp' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-rpath $libdir' ;; esac _LT_TAGVAR(hardcode_libdir_separator, $1)=: # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "ld" | $GREP -v "ld:"`; templist=`$ECHO "X$templist" | $Xsed -e "s/\(^.*ld.*\)\( .*ld.*$\)/\1/"`; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; $ECHO "X$list" | $Xsed' ;; *) if test "$GXX" = yes && test "$with_gnu_ld" = no; then _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-expect_unresolved ${wl}\*' case $host in osf3*) _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib ${allow_undefined_flag} $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "X${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib' ;; *) _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib ${allow_undefined_flag} $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-msym ${wl}-soname ${wl}$soname `test -n "$verstring" && $ECHO "${wl}-set_version ${wl}$verstring" | $Xsed` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib' ;; esac _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=: # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "\-L"' else # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no fi ;; esac ;; psos*) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; sunos4*) case $cc_basename in CC*) # Sun C++ 4.x # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; lcc*) # Lucid # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; *) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; esac ;; solaris*) case $cc_basename in CC*) # Sun C++ 4.2, 5.x and Centerline C++ _LT_TAGVAR(archive_cmds_need_lc,$1)=yes _LT_TAGVAR(no_undefined_flag, $1)=' -zdefs' _LT_TAGVAR(archive_cmds, $1)='$CC -G${allow_undefined_flag} -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -G${allow_undefined_flag} ${wl}-M ${wl}$lib.exp -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp' _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' _LT_TAGVAR(hardcode_shlibpath_var, $1)=no case $host_os in solaris2.[[0-5]] | solaris2.[[0-5]].*) ;; *) # The compiler driver will combine and reorder linker options, # but understands `-z linker_flag'. # Supported since Solaris 2.6 (maybe 2.5.1?) _LT_TAGVAR(whole_archive_flag_spec, $1)='-z allextract$convenience -z defaultextract' ;; esac _LT_TAGVAR(link_all_deplibs, $1)=yes output_verbose_link_cmd='echo' # Archives containing C++ object files must be created using # "CC -xar", where "CC" is the Sun C++ compiler. This is # necessary to make sure instantiated templates are included # in the archive. _LT_TAGVAR(old_archive_cmds, $1)='$CC -xar -o $oldlib $oldobjs' ;; gcx*) # Green Hills C++ Compiler _LT_TAGVAR(archive_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-h $wl$soname -o $lib' # The C++ compiler must be used to create the archive. _LT_TAGVAR(old_archive_cmds, $1)='$CC $LDFLAGS -archive -o $oldlib $oldobjs' ;; *) # GNU C++ compiler with Solaris linker if test "$GXX" = yes && test "$with_gnu_ld" = no; then _LT_TAGVAR(no_undefined_flag, $1)=' ${wl}-z ${wl}defs' if $CC --version | $GREP -v '^2\.7' > /dev/null; then _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $LDFLAGS $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-h $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -shared -nostdlib ${wl}-M $wl$lib.exp -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp' # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "\-L"' else # g++ 2.7 appears to require `-G' NOT `-shared' on this # platform. _LT_TAGVAR(archive_cmds, $1)='$CC -G -nostdlib $LDFLAGS $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-h $wl$soname -o $lib' _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -G -nostdlib ${wl}-M $wl$lib.exp -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp' # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. output_verbose_link_cmd='$CC -G $CFLAGS -v conftest.$objext 2>&1 | $GREP "\-L"' fi _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R $wl$libdir' case $host_os in solaris2.[[0-5]] | solaris2.[[0-5]].*) ;; *) _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}-z ${wl}allextract$convenience ${wl}-z ${wl}defaultextract' ;; esac fi ;; esac ;; sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[[01]].[[10]]* | unixware7* | sco3.2v5.0.[[024]]*) _LT_TAGVAR(no_undefined_flag, $1)='${wl}-z,text' _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=no runpath_var='LD_RUN_PATH' case $cc_basename in CC*) _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' ;; *) _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' ;; esac ;; sysv5* | sco3.2v5* | sco5v6*) # Note: We can NOT use -z defs as we might desire, because we do not # link with -lc, and that would cause any symbols used from libc to # always be unresolved, which means just about no library would # ever link correctly. If we're not using GNU ld we use -z text # though, which does catch some bad symbols but isn't as heavy-handed # as -z defs. _LT_TAGVAR(no_undefined_flag, $1)='${wl}-z,text' _LT_TAGVAR(allow_undefined_flag, $1)='${wl}-z,nodefs' _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(hardcode_shlibpath_var, $1)=no _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R,$libdir' _LT_TAGVAR(hardcode_libdir_separator, $1)=':' _LT_TAGVAR(link_all_deplibs, $1)=yes _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-Bexport' runpath_var='LD_RUN_PATH' case $cc_basename in CC*) _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' ;; *) _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags' ;; esac ;; tandem*) case $cc_basename in NCC*) # NonStop-UX NCC 3.20 # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; *) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; esac ;; vxworks*) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; *) # FIXME: insert proper C++ library support _LT_TAGVAR(ld_shlibs, $1)=no ;; esac AC_MSG_RESULT([$_LT_TAGVAR(ld_shlibs, $1)]) test "$_LT_TAGVAR(ld_shlibs, $1)" = no && can_build_shared=no _LT_TAGVAR(GCC, $1)="$GXX" _LT_TAGVAR(LD, $1)="$LD" ## CAVEAT EMPTOR: ## There is no encapsulation within the following macros, do not change ## the running order or otherwise move them around unless you know exactly ## what you are doing... _LT_SYS_HIDDEN_LIBDEPS($1) _LT_COMPILER_PIC($1) _LT_COMPILER_C_O($1) _LT_COMPILER_FILE_LOCKS($1) _LT_LINKER_SHLIBS($1) _LT_SYS_DYNAMIC_LINKER($1) _LT_LINKER_HARDCODE_LIBPATH($1) _LT_CONFIG($1) fi # test -n "$compiler" CC=$lt_save_CC LDCXX=$LD LD=$lt_save_LD GCC=$lt_save_GCC with_gnu_ld=$lt_save_with_gnu_ld lt_cv_path_LDCXX=$lt_cv_path_LD lt_cv_path_LD=$lt_save_path_LD lt_cv_prog_gnu_ldcxx=$lt_cv_prog_gnu_ld lt_cv_prog_gnu_ld=$lt_save_with_gnu_ld fi # test "$_lt_caught_CXX_error" != yes AC_LANG_POP ])# _LT_LANG_CXX_CONFIG # _LT_SYS_HIDDEN_LIBDEPS([TAGNAME]) # --------------------------------- # Figure out "hidden" library dependencies from verbose # compiler output when linking a shared library. # Parse the compiler output and extract the necessary # objects, libraries and library flags. m4_defun([_LT_SYS_HIDDEN_LIBDEPS], [m4_require([_LT_FILEUTILS_DEFAULTS])dnl # Dependencies to place before and after the object being linked: _LT_TAGVAR(predep_objects, $1)= _LT_TAGVAR(postdep_objects, $1)= _LT_TAGVAR(predeps, $1)= _LT_TAGVAR(postdeps, $1)= _LT_TAGVAR(compiler_lib_search_path, $1)= dnl we can't use the lt_simple_compile_test_code here, dnl because it contains code intended for an executable, dnl not a library. It's possible we should let each dnl tag define a new lt_????_link_test_code variable, dnl but it's only used here... m4_if([$1], [], [cat > conftest.$ac_ext <<_LT_EOF int a; void foo (void) { a = 0; } _LT_EOF ], [$1], [CXX], [cat > conftest.$ac_ext <<_LT_EOF class Foo { public: Foo (void) { a = 0; } private: int a; }; _LT_EOF ], [$1], [F77], [cat > conftest.$ac_ext <<_LT_EOF subroutine foo implicit none integer*4 a a=0 return end _LT_EOF ], [$1], [FC], [cat > conftest.$ac_ext <<_LT_EOF subroutine foo implicit none integer a a=0 return end _LT_EOF ], [$1], [GCJ], [cat > conftest.$ac_ext <<_LT_EOF public class foo { private int a; public void bar (void) { a = 0; } }; _LT_EOF ]) dnl Parse the compiler output and extract the necessary dnl objects, libraries and library flags. if AC_TRY_EVAL(ac_compile); then # Parse the compiler output and extract the necessary # objects, libraries and library flags. # Sentinel used to keep track of whether or not we are before # the conftest object file. pre_test_object_deps_done=no for p in `eval "$output_verbose_link_cmd"`; do case $p in -L* | -R* | -l*) # Some compilers place space between "-{L,R}" and the path. # Remove the space. if test $p = "-L" || test $p = "-R"; then prev=$p continue else prev= fi if test "$pre_test_object_deps_done" = no; then case $p in -L* | -R*) # Internal compiler library paths should come after those # provided the user. The postdeps already come after the # user supplied libs so there is no need to process them. if test -z "$_LT_TAGVAR(compiler_lib_search_path, $1)"; then _LT_TAGVAR(compiler_lib_search_path, $1)="${prev}${p}" else _LT_TAGVAR(compiler_lib_search_path, $1)="${_LT_TAGVAR(compiler_lib_search_path, $1)} ${prev}${p}" fi ;; # The "-l" case would never come before the object being # linked, so don't bother handling this case. esac else if test -z "$_LT_TAGVAR(postdeps, $1)"; then _LT_TAGVAR(postdeps, $1)="${prev}${p}" else _LT_TAGVAR(postdeps, $1)="${_LT_TAGVAR(postdeps, $1)} ${prev}${p}" fi fi ;; *.$objext) # This assumes that the test object file only shows up # once in the compiler output. if test "$p" = "conftest.$objext"; then pre_test_object_deps_done=yes continue fi if test "$pre_test_object_deps_done" = no; then if test -z "$_LT_TAGVAR(predep_objects, $1)"; then _LT_TAGVAR(predep_objects, $1)="$p" else _LT_TAGVAR(predep_objects, $1)="$_LT_TAGVAR(predep_objects, $1) $p" fi else if test -z "$_LT_TAGVAR(postdep_objects, $1)"; then _LT_TAGVAR(postdep_objects, $1)="$p" else _LT_TAGVAR(postdep_objects, $1)="$_LT_TAGVAR(postdep_objects, $1) $p" fi fi ;; *) ;; # Ignore the rest. esac done # Clean up. rm -f a.out a.exe else echo "libtool.m4: error: problem compiling $1 test program" fi $RM -f confest.$objext # PORTME: override above test on systems where it is broken m4_if([$1], [CXX], [case $host_os in interix[[3-9]]*) # Interix 3.5 installs completely hosed .la files for C++, so rather than # hack all around it, let's just trust "g++" to DTRT. _LT_TAGVAR(predep_objects,$1)= _LT_TAGVAR(postdep_objects,$1)= _LT_TAGVAR(postdeps,$1)= ;; linux*) case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C++ 5.9 # The more standards-conforming stlport4 library is # incompatible with the Cstd library. Avoid specifying # it if it's in CXXFLAGS. Ignore libCrun as # -library=stlport4 depends on it. case " $CXX $CXXFLAGS " in *" -library=stlport4 "*) solaris_use_stlport4=yes ;; esac if test "$solaris_use_stlport4" != yes; then _LT_TAGVAR(postdeps,$1)='-library=Cstd -library=Crun' fi ;; esac ;; solaris*) case $cc_basename in CC*) # The more standards-conforming stlport4 library is # incompatible with the Cstd library. Avoid specifying # it if it's in CXXFLAGS. Ignore libCrun as # -library=stlport4 depends on it. case " $CXX $CXXFLAGS " in *" -library=stlport4 "*) solaris_use_stlport4=yes ;; esac # Adding this requires a known-good setup of shared libraries for # Sun compiler versions before 5.6, else PIC objects from an old # archive will be linked into the output, leading to subtle bugs. if test "$solaris_use_stlport4" != yes; then _LT_TAGVAR(postdeps,$1)='-library=Cstd -library=Crun' fi ;; esac ;; esac ]) case " $_LT_TAGVAR(postdeps, $1) " in *" -lc "*) _LT_TAGVAR(archive_cmds_need_lc, $1)=no ;; esac _LT_TAGVAR(compiler_lib_search_dirs, $1)= if test -n "${_LT_TAGVAR(compiler_lib_search_path, $1)}"; then _LT_TAGVAR(compiler_lib_search_dirs, $1)=`echo " ${_LT_TAGVAR(compiler_lib_search_path, $1)}" | ${SED} -e 's! -L! !g' -e 's!^ !!'` fi _LT_TAGDECL([], [compiler_lib_search_dirs], [1], [The directories searched by this compiler when creating a shared library]) _LT_TAGDECL([], [predep_objects], [1], [Dependencies to place before and after the objects being linked to create a shared library]) _LT_TAGDECL([], [postdep_objects], [1]) _LT_TAGDECL([], [predeps], [1]) _LT_TAGDECL([], [postdeps], [1]) _LT_TAGDECL([], [compiler_lib_search_path], [1], [The library search path used internally by the compiler when linking a shared library]) ])# _LT_SYS_HIDDEN_LIBDEPS # _LT_PROG_F77 # ------------ # Since AC_PROG_F77 is broken, in that it returns the empty string # if there is no fortran compiler, we have our own version here. m4_defun([_LT_PROG_F77], [ pushdef([AC_MSG_ERROR], [_lt_disable_F77=yes]) AC_PROG_F77 if test -z "$F77" || test "X$F77" = "Xno"; then _lt_disable_F77=yes fi popdef([AC_MSG_ERROR]) ])# _LT_PROG_F77 dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([_LT_PROG_F77], []) # _LT_LANG_F77_CONFIG([TAG]) # -------------------------- # Ensure that the configuration variables for a Fortran 77 compiler are # suitably defined. These variables are subsequently used by _LT_CONFIG # to write the compiler configuration to `libtool'. m4_defun([_LT_LANG_F77_CONFIG], [AC_REQUIRE([_LT_PROG_F77])dnl AC_LANG_PUSH(Fortran 77) _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(allow_undefined_flag, $1)= _LT_TAGVAR(always_export_symbols, $1)=no _LT_TAGVAR(archive_expsym_cmds, $1)= _LT_TAGVAR(export_dynamic_flag_spec, $1)= _LT_TAGVAR(hardcode_direct, $1)=no _LT_TAGVAR(hardcode_direct_absolute, $1)=no _LT_TAGVAR(hardcode_libdir_flag_spec, $1)= _LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)= _LT_TAGVAR(hardcode_libdir_separator, $1)= _LT_TAGVAR(hardcode_minus_L, $1)=no _LT_TAGVAR(hardcode_automatic, $1)=no _LT_TAGVAR(inherit_rpath, $1)=no _LT_TAGVAR(module_cmds, $1)= _LT_TAGVAR(module_expsym_cmds, $1)= _LT_TAGVAR(link_all_deplibs, $1)=unknown _LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds _LT_TAGVAR(no_undefined_flag, $1)= _LT_TAGVAR(whole_archive_flag_spec, $1)= _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no # Source file extension for f77 test sources. ac_ext=f # Object file extension for compiled f77 test sources. objext=o _LT_TAGVAR(objext, $1)=$objext # No sense in running all these tests if we already determined that # the F77 compiler isn't working. Some variables (like enable_shared) # are currently assumed to apply to all compilers on this platform, # and will be corrupted by setting them based on a non-working compiler. if test "$_lt_disable_F77" != yes; then # Code to be used in simple compile tests lt_simple_compile_test_code="\ subroutine t return end " # Code to be used in simple link tests lt_simple_link_test_code="\ program t end " # ltmain only uses $CC for tagged configurations so make sure $CC is set. _LT_TAG_COMPILER # save warnings/boilerplate of simple test code _LT_COMPILER_BOILERPLATE _LT_LINKER_BOILERPLATE # Allow CC to be a program name with arguments. lt_save_CC="$CC" lt_save_GCC=$GCC CC=${F77-"f77"} compiler=$CC _LT_TAGVAR(compiler, $1)=$CC _LT_CC_BASENAME([$compiler]) GCC=$G77 if test -n "$compiler"; then AC_MSG_CHECKING([if libtool supports shared libraries]) AC_MSG_RESULT([$can_build_shared]) AC_MSG_CHECKING([whether to build shared libraries]) test "$can_build_shared" = "no" && enable_shared=no # On AIX, shared libraries and static libraries use the same namespace, and # are all built from PIC. case $host_os in aix3*) test "$enable_shared" = yes && enable_static=no if test -n "$RANLIB"; then archive_cmds="$archive_cmds~\$RANLIB \$lib" postinstall_cmds='$RANLIB $lib' fi ;; aix[[4-9]]*) if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then test "$enable_shared" = yes && enable_static=no fi ;; esac AC_MSG_RESULT([$enable_shared]) AC_MSG_CHECKING([whether to build static libraries]) # Make sure either enable_shared or enable_static is yes. test "$enable_shared" = yes || enable_static=yes AC_MSG_RESULT([$enable_static]) _LT_TAGVAR(GCC, $1)="$G77" _LT_TAGVAR(LD, $1)="$LD" ## CAVEAT EMPTOR: ## There is no encapsulation within the following macros, do not change ## the running order or otherwise move them around unless you know exactly ## what you are doing... _LT_COMPILER_PIC($1) _LT_COMPILER_C_O($1) _LT_COMPILER_FILE_LOCKS($1) _LT_LINKER_SHLIBS($1) _LT_SYS_DYNAMIC_LINKER($1) _LT_LINKER_HARDCODE_LIBPATH($1) _LT_CONFIG($1) fi # test -n "$compiler" GCC=$lt_save_GCC CC="$lt_save_CC" fi # test "$_lt_disable_F77" != yes AC_LANG_POP ])# _LT_LANG_F77_CONFIG # _LT_PROG_FC # ----------- # Since AC_PROG_FC is broken, in that it returns the empty string # if there is no fortran compiler, we have our own version here. m4_defun([_LT_PROG_FC], [ pushdef([AC_MSG_ERROR], [_lt_disable_FC=yes]) AC_PROG_FC if test -z "$FC" || test "X$FC" = "Xno"; then _lt_disable_FC=yes fi popdef([AC_MSG_ERROR]) ])# _LT_PROG_FC dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([_LT_PROG_FC], []) # _LT_LANG_FC_CONFIG([TAG]) # ------------------------- # Ensure that the configuration variables for a Fortran compiler are # suitably defined. These variables are subsequently used by _LT_CONFIG # to write the compiler configuration to `libtool'. m4_defun([_LT_LANG_FC_CONFIG], [AC_REQUIRE([_LT_PROG_FC])dnl AC_LANG_PUSH(Fortran) _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(allow_undefined_flag, $1)= _LT_TAGVAR(always_export_symbols, $1)=no _LT_TAGVAR(archive_expsym_cmds, $1)= _LT_TAGVAR(export_dynamic_flag_spec, $1)= _LT_TAGVAR(hardcode_direct, $1)=no _LT_TAGVAR(hardcode_direct_absolute, $1)=no _LT_TAGVAR(hardcode_libdir_flag_spec, $1)= _LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)= _LT_TAGVAR(hardcode_libdir_separator, $1)= _LT_TAGVAR(hardcode_minus_L, $1)=no _LT_TAGVAR(hardcode_automatic, $1)=no _LT_TAGVAR(inherit_rpath, $1)=no _LT_TAGVAR(module_cmds, $1)= _LT_TAGVAR(module_expsym_cmds, $1)= _LT_TAGVAR(link_all_deplibs, $1)=unknown _LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds _LT_TAGVAR(no_undefined_flag, $1)= _LT_TAGVAR(whole_archive_flag_spec, $1)= _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no # Source file extension for fc test sources. ac_ext=${ac_fc_srcext-f} # Object file extension for compiled fc test sources. objext=o _LT_TAGVAR(objext, $1)=$objext # No sense in running all these tests if we already determined that # the FC compiler isn't working. Some variables (like enable_shared) # are currently assumed to apply to all compilers on this platform, # and will be corrupted by setting them based on a non-working compiler. if test "$_lt_disable_FC" != yes; then # Code to be used in simple compile tests lt_simple_compile_test_code="\ subroutine t return end " # Code to be used in simple link tests lt_simple_link_test_code="\ program t end " # ltmain only uses $CC for tagged configurations so make sure $CC is set. _LT_TAG_COMPILER # save warnings/boilerplate of simple test code _LT_COMPILER_BOILERPLATE _LT_LINKER_BOILERPLATE # Allow CC to be a program name with arguments. lt_save_CC="$CC" lt_save_GCC=$GCC CC=${FC-"f95"} compiler=$CC GCC=$ac_cv_fc_compiler_gnu _LT_TAGVAR(compiler, $1)=$CC _LT_CC_BASENAME([$compiler]) if test -n "$compiler"; then AC_MSG_CHECKING([if libtool supports shared libraries]) AC_MSG_RESULT([$can_build_shared]) AC_MSG_CHECKING([whether to build shared libraries]) test "$can_build_shared" = "no" && enable_shared=no # On AIX, shared libraries and static libraries use the same namespace, and # are all built from PIC. case $host_os in aix3*) test "$enable_shared" = yes && enable_static=no if test -n "$RANLIB"; then archive_cmds="$archive_cmds~\$RANLIB \$lib" postinstall_cmds='$RANLIB $lib' fi ;; aix[[4-9]]*) if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then test "$enable_shared" = yes && enable_static=no fi ;; esac AC_MSG_RESULT([$enable_shared]) AC_MSG_CHECKING([whether to build static libraries]) # Make sure either enable_shared or enable_static is yes. test "$enable_shared" = yes || enable_static=yes AC_MSG_RESULT([$enable_static]) _LT_TAGVAR(GCC, $1)="$ac_cv_fc_compiler_gnu" _LT_TAGVAR(LD, $1)="$LD" ## CAVEAT EMPTOR: ## There is no encapsulation within the following macros, do not change ## the running order or otherwise move them around unless you know exactly ## what you are doing... _LT_SYS_HIDDEN_LIBDEPS($1) _LT_COMPILER_PIC($1) _LT_COMPILER_C_O($1) _LT_COMPILER_FILE_LOCKS($1) _LT_LINKER_SHLIBS($1) _LT_SYS_DYNAMIC_LINKER($1) _LT_LINKER_HARDCODE_LIBPATH($1) _LT_CONFIG($1) fi # test -n "$compiler" GCC=$lt_save_GCC CC="$lt_save_CC" fi # test "$_lt_disable_FC" != yes AC_LANG_POP ])# _LT_LANG_FC_CONFIG # _LT_LANG_GCJ_CONFIG([TAG]) # -------------------------- # Ensure that the configuration variables for the GNU Java Compiler compiler # are suitably defined. These variables are subsequently used by _LT_CONFIG # to write the compiler configuration to `libtool'. m4_defun([_LT_LANG_GCJ_CONFIG], [AC_REQUIRE([LT_PROG_GCJ])dnl AC_LANG_SAVE # Source file extension for Java test sources. ac_ext=java # Object file extension for compiled Java test sources. objext=o _LT_TAGVAR(objext, $1)=$objext # Code to be used in simple compile tests lt_simple_compile_test_code="class foo {}" # Code to be used in simple link tests lt_simple_link_test_code='public class conftest { public static void main(String[[]] argv) {}; }' # ltmain only uses $CC for tagged configurations so make sure $CC is set. _LT_TAG_COMPILER # save warnings/boilerplate of simple test code _LT_COMPILER_BOILERPLATE _LT_LINKER_BOILERPLATE # Allow CC to be a program name with arguments. lt_save_CC="$CC" lt_save_GCC=$GCC GCC=yes CC=${GCJ-"gcj"} compiler=$CC _LT_TAGVAR(compiler, $1)=$CC _LT_TAGVAR(LD, $1)="$LD" _LT_CC_BASENAME([$compiler]) # GCJ did not exist at the time GCC didn't implicitly link libc in. _LT_TAGVAR(archive_cmds_need_lc, $1)=no _LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds ## CAVEAT EMPTOR: ## There is no encapsulation within the following macros, do not change ## the running order or otherwise move them around unless you know exactly ## what you are doing... if test -n "$compiler"; then _LT_COMPILER_NO_RTTI($1) _LT_COMPILER_PIC($1) _LT_COMPILER_C_O($1) _LT_COMPILER_FILE_LOCKS($1) _LT_LINKER_SHLIBS($1) _LT_LINKER_HARDCODE_LIBPATH($1) _LT_CONFIG($1) fi AC_LANG_RESTORE GCC=$lt_save_GCC CC="$lt_save_CC" ])# _LT_LANG_GCJ_CONFIG # _LT_LANG_RC_CONFIG([TAG]) # ------------------------- # Ensure that the configuration variables for the Windows resource compiler # are suitably defined. These variables are subsequently used by _LT_CONFIG # to write the compiler configuration to `libtool'. m4_defun([_LT_LANG_RC_CONFIG], [AC_REQUIRE([LT_PROG_RC])dnl AC_LANG_SAVE # Source file extension for RC test sources. ac_ext=rc # Object file extension for compiled RC test sources. objext=o _LT_TAGVAR(objext, $1)=$objext # Code to be used in simple compile tests lt_simple_compile_test_code='sample MENU { MENUITEM "&Soup", 100, CHECKED }' # Code to be used in simple link tests lt_simple_link_test_code="$lt_simple_compile_test_code" # ltmain only uses $CC for tagged configurations so make sure $CC is set. _LT_TAG_COMPILER # save warnings/boilerplate of simple test code _LT_COMPILER_BOILERPLATE _LT_LINKER_BOILERPLATE # Allow CC to be a program name with arguments. lt_save_CC="$CC" lt_save_GCC=$GCC GCC= CC=${RC-"windres"} compiler=$CC _LT_TAGVAR(compiler, $1)=$CC _LT_CC_BASENAME([$compiler]) _LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)=yes if test -n "$compiler"; then : _LT_CONFIG($1) fi GCC=$lt_save_GCC AC_LANG_RESTORE CC="$lt_save_CC" ])# _LT_LANG_RC_CONFIG # LT_PROG_GCJ # ----------- AC_DEFUN([LT_PROG_GCJ], [m4_ifdef([AC_PROG_GCJ], [AC_PROG_GCJ], [m4_ifdef([A][M_PROG_GCJ], [A][M_PROG_GCJ], [AC_CHECK_TOOL(GCJ, gcj,) test "x${GCJFLAGS+set}" = xset || GCJFLAGS="-g -O2" AC_SUBST(GCJFLAGS)])])[]dnl ]) # Old name: AU_ALIAS([LT_AC_PROG_GCJ], [LT_PROG_GCJ]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([LT_AC_PROG_GCJ], []) # LT_PROG_RC # ---------- AC_DEFUN([LT_PROG_RC], [AC_CHECK_TOOL(RC, windres,) ]) # Old name: AU_ALIAS([LT_AC_PROG_RC], [LT_PROG_RC]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([LT_AC_PROG_RC], []) # _LT_DECL_EGREP # -------------- # If we don't have a new enough Autoconf to choose the best grep # available, choose the one first in the user's PATH. m4_defun([_LT_DECL_EGREP], [AC_REQUIRE([AC_PROG_EGREP])dnl AC_REQUIRE([AC_PROG_FGREP])dnl test -z "$GREP" && GREP=grep _LT_DECL([], [GREP], [1], [A grep program that handles long lines]) _LT_DECL([], [EGREP], [1], [An ERE matcher]) _LT_DECL([], [FGREP], [1], [A literal string matcher]) dnl Non-bleeding-edge autoconf doesn't subst GREP, so do it here too AC_SUBST([GREP]) ]) # _LT_DECL_OBJDUMP # -------------- # If we don't have a new enough Autoconf to choose the best objdump # available, choose the one first in the user's PATH. m4_defun([_LT_DECL_OBJDUMP], [AC_CHECK_TOOL(OBJDUMP, objdump, false) test -z "$OBJDUMP" && OBJDUMP=objdump _LT_DECL([], [OBJDUMP], [1], [An object symbol dumper]) AC_SUBST([OBJDUMP]) ]) # _LT_DECL_SED # ------------ # Check for a fully-functional sed program, that truncates # as few characters as possible. Prefer GNU sed if found. m4_defun([_LT_DECL_SED], [AC_PROG_SED test -z "$SED" && SED=sed Xsed="$SED -e 1s/^X//" _LT_DECL([], [SED], [1], [A sed program that does not truncate output]) _LT_DECL([], [Xsed], ["\$SED -e 1s/^X//"], [Sed that helps us avoid accidentally triggering echo(1) options like -n]) ])# _LT_DECL_SED m4_ifndef([AC_PROG_SED], [ ############################################################ # NOTE: This macro has been submitted for inclusion into # # GNU Autoconf as AC_PROG_SED. When it is available in # # a released version of Autoconf we should remove this # # macro and use it instead. # ############################################################ m4_defun([AC_PROG_SED], [AC_MSG_CHECKING([for a sed that does not truncate output]) AC_CACHE_VAL(lt_cv_path_SED, [# Loop through the user's path and test for sed and gsed. # Then use that list of sed's as ones to test for truncation. as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for lt_ac_prog in sed gsed; do for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$lt_ac_prog$ac_exec_ext"; then lt_ac_sed_list="$lt_ac_sed_list $as_dir/$lt_ac_prog$ac_exec_ext" fi done done done IFS=$as_save_IFS lt_ac_max=0 lt_ac_count=0 # Add /usr/xpg4/bin/sed as it is typically found on Solaris # along with /bin/sed that truncates output. for lt_ac_sed in $lt_ac_sed_list /usr/xpg4/bin/sed; do test ! -f $lt_ac_sed && continue cat /dev/null > conftest.in lt_ac_count=0 echo $ECHO_N "0123456789$ECHO_C" >conftest.in # Check for GNU sed and select it if it is found. if "$lt_ac_sed" --version 2>&1 < /dev/null | grep 'GNU' > /dev/null; then lt_cv_path_SED=$lt_ac_sed break fi while true; do cat conftest.in conftest.in >conftest.tmp mv conftest.tmp conftest.in cp conftest.in conftest.nl echo >>conftest.nl $lt_ac_sed -e 's/a$//' < conftest.nl >conftest.out || break cmp -s conftest.out conftest.nl || break # 10000 chars as input seems more than enough test $lt_ac_count -gt 10 && break lt_ac_count=`expr $lt_ac_count + 1` if test $lt_ac_count -gt $lt_ac_max; then lt_ac_max=$lt_ac_count lt_cv_path_SED=$lt_ac_sed fi done done ]) SED=$lt_cv_path_SED AC_SUBST([SED]) AC_MSG_RESULT([$SED]) ])#AC_PROG_SED ])#m4_ifndef # Old name: AU_ALIAS([LT_AC_PROG_SED], [AC_PROG_SED]) dnl aclocal-1.4 backwards compatibility: dnl AC_DEFUN([LT_AC_PROG_SED], []) # _LT_CHECK_SHELL_FEATURES # ------------------------ # Find out whether the shell is Bourne or XSI compatible, # or has some other useful features. m4_defun([_LT_CHECK_SHELL_FEATURES], [AC_MSG_CHECKING([whether the shell understands some XSI constructs]) # Try some XSI features xsi_shell=no ( _lt_dummy="a/b/c" test "${_lt_dummy##*/},${_lt_dummy%/*},"${_lt_dummy%"$_lt_dummy"}, \ = c,a/b,, \ && eval 'test $(( 1 + 1 )) -eq 2 \ && test "${#_lt_dummy}" -eq 5' ) >/dev/null 2>&1 \ && xsi_shell=yes AC_MSG_RESULT([$xsi_shell]) _LT_CONFIG_LIBTOOL_INIT([xsi_shell='$xsi_shell']) AC_MSG_CHECKING([whether the shell understands "+="]) lt_shell_append=no ( foo=bar; set foo baz; eval "$[1]+=\$[2]" && test "$foo" = barbaz ) \ >/dev/null 2>&1 \ && lt_shell_append=yes AC_MSG_RESULT([$lt_shell_append]) _LT_CONFIG_LIBTOOL_INIT([lt_shell_append='$lt_shell_append']) if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then lt_unset=unset else lt_unset=false fi _LT_DECL([], [lt_unset], [0], [whether the shell understands "unset"])dnl # test EBCDIC or ASCII case `echo X|tr X '\101'` in A) # ASCII based system # \n is not interpreted correctly by Solaris 8 /usr/ucb/tr lt_SP2NL='tr \040 \012' lt_NL2SP='tr \015\012 \040\040' ;; *) # EBCDIC based system lt_SP2NL='tr \100 \n' lt_NL2SP='tr \r\n \100\100' ;; esac _LT_DECL([SP2NL], [lt_SP2NL], [1], [turn spaces into newlines])dnl _LT_DECL([NL2SP], [lt_NL2SP], [1], [turn newlines into spaces])dnl ])# _LT_CHECK_SHELL_FEATURES # _LT_PROG_XSI_SHELLFNS # --------------------- # Bourne and XSI compatible variants of some useful shell functions. m4_defun([_LT_PROG_XSI_SHELLFNS], [case $xsi_shell in yes) cat << \_LT_EOF >> "$cfgfile" # func_dirname file append nondir_replacement # Compute the dirname of FILE. If nonempty, add APPEND to the result, # otherwise set result to NONDIR_REPLACEMENT. func_dirname () { case ${1} in */*) func_dirname_result="${1%/*}${2}" ;; * ) func_dirname_result="${3}" ;; esac } # func_basename file func_basename () { func_basename_result="${1##*/}" } # func_dirname_and_basename file append nondir_replacement # perform func_basename and func_dirname in a single function # call: # dirname: Compute the dirname of FILE. If nonempty, # add APPEND to the result, otherwise set result # to NONDIR_REPLACEMENT. # value returned in "$func_dirname_result" # basename: Compute filename of FILE. # value retuned in "$func_basename_result" # Implementation must be kept synchronized with func_dirname # and func_basename. For efficiency, we do not delegate to # those functions but instead duplicate the functionality here. func_dirname_and_basename () { case ${1} in */*) func_dirname_result="${1%/*}${2}" ;; * ) func_dirname_result="${3}" ;; esac func_basename_result="${1##*/}" } # func_stripname prefix suffix name # strip PREFIX and SUFFIX off of NAME. # PREFIX and SUFFIX must not contain globbing or regex special # characters, hashes, percent signs, but SUFFIX may contain a leading # dot (in which case that matches only a dot). func_stripname () { # pdksh 5.2.14 does not do ${X%$Y} correctly if both X and Y are # positional parameters, so assign one to ordinary parameter first. func_stripname_result=${3} func_stripname_result=${func_stripname_result#"${1}"} func_stripname_result=${func_stripname_result%"${2}"} } # func_opt_split func_opt_split () { func_opt_split_opt=${1%%=*} func_opt_split_arg=${1#*=} } # func_lo2o object func_lo2o () { case ${1} in *.lo) func_lo2o_result=${1%.lo}.${objext} ;; *) func_lo2o_result=${1} ;; esac } # func_xform libobj-or-source func_xform () { func_xform_result=${1%.*}.lo } # func_arith arithmetic-term... func_arith () { func_arith_result=$(( $[*] )) } # func_len string # STRING may not start with a hyphen. func_len () { func_len_result=${#1} } _LT_EOF ;; *) # Bourne compatible functions. cat << \_LT_EOF >> "$cfgfile" # func_dirname file append nondir_replacement # Compute the dirname of FILE. If nonempty, add APPEND to the result, # otherwise set result to NONDIR_REPLACEMENT. func_dirname () { # Extract subdirectory from the argument. func_dirname_result=`$ECHO "X${1}" | $Xsed -e "$dirname"` if test "X$func_dirname_result" = "X${1}"; then func_dirname_result="${3}" else func_dirname_result="$func_dirname_result${2}" fi } # func_basename file func_basename () { func_basename_result=`$ECHO "X${1}" | $Xsed -e "$basename"` } dnl func_dirname_and_basename dnl A portable version of this function is already defined in general.m4sh dnl so there is no need for it here. # func_stripname prefix suffix name # strip PREFIX and SUFFIX off of NAME. # PREFIX and SUFFIX must not contain globbing or regex special # characters, hashes, percent signs, but SUFFIX may contain a leading # dot (in which case that matches only a dot). # func_strip_suffix prefix name func_stripname () { case ${2} in .*) func_stripname_result=`$ECHO "X${3}" \ | $Xsed -e "s%^${1}%%" -e "s%\\\\${2}\$%%"`;; *) func_stripname_result=`$ECHO "X${3}" \ | $Xsed -e "s%^${1}%%" -e "s%${2}\$%%"`;; esac } # sed scripts: my_sed_long_opt='1s/^\(-[[^=]]*\)=.*/\1/;q' my_sed_long_arg='1s/^-[[^=]]*=//' # func_opt_split func_opt_split () { func_opt_split_opt=`$ECHO "X${1}" | $Xsed -e "$my_sed_long_opt"` func_opt_split_arg=`$ECHO "X${1}" | $Xsed -e "$my_sed_long_arg"` } # func_lo2o object func_lo2o () { func_lo2o_result=`$ECHO "X${1}" | $Xsed -e "$lo2o"` } # func_xform libobj-or-source func_xform () { func_xform_result=`$ECHO "X${1}" | $Xsed -e 's/\.[[^.]]*$/.lo/'` } # func_arith arithmetic-term... func_arith () { func_arith_result=`expr "$[@]"` } # func_len string # STRING may not start with a hyphen. func_len () { func_len_result=`expr "$[1]" : ".*" 2>/dev/null || echo $max_cmd_len` } _LT_EOF esac case $lt_shell_append in yes) cat << \_LT_EOF >> "$cfgfile" # func_append var value # Append VALUE to the end of shell variable VAR. func_append () { eval "$[1]+=\$[2]" } _LT_EOF ;; *) cat << \_LT_EOF >> "$cfgfile" # func_append var value # Append VALUE to the end of shell variable VAR. func_append () { eval "$[1]=\$$[1]\$[2]" } _LT_EOF ;; esac ]) librep-0.90.2/man/repl.texi0000644000175200017520000001302711245011153014471 0ustar chrischris@c The REPL -*-Texinfo-*- @chapter The REPL @cindex The REPL @cindex Read-eval-print loop When you invoke the stand-alone librep interpreter without giving it a script to execute the system is started in interactive mode. This means that the @dfn{REPL} is entered---the read-eval-print loop. The REPL works as its name suggests. It reads Lisp forms from the console, evaluates them, and then prints the result back to the console. Here is an example REPL session: @lisp user> (+ 1 1) 2 user> (cons 'a 'b) (a . b) @end lisp @noindent The @samp{user>} string is the prompt that the REPL prints when it is waiting for an input form. This form may span several lines, e.g.: @lisp user> (cons 'a 'b) (a . b) @end lisp @noindent The prompt above contains the string @samp{user}. This is the name of the module that the form will be evaluated in (@pxref{Modules}). As well as allowing arbitrary Lisp forms to be entered and evaluated, the REPL provides a rich set of meta-commands, these are used to configure and inspect the state of the system, as well as providing convenient shortcuts for common operations. A meta-command is differentiated from a normal Lisp form by preceding it with a comma (@samp{,}) character. The name of the command should follow the comma, with any argument forms after that. Note that unlike normal Lisp forms, no parentheses are used to mark the command application. For example the @code{whereis} meta-command searches all loaded modules for those exporting a particular symbol. It might be used as follows: @example user> ,whereis string-match string-match is exported by: rep.regexp @end example @noindent The following table lists all currently supported meta-commands: @table @code @item access @var{struct} @dots{} Add the modules named @var{struct} @dots{} to the list of structures whose exported definitions may be accessed by the current module (using the @code{structure-ref} special form). @item accessible Print the names of the modules whose contents may be accessed using the @code{structure-ref} form from the current module. @item apropos "@var{regexp}" Print the definitions in the scope of the current module whose names match the regular expression @var{regexp}. @item bindings Print all bindings in the current module. @item collect Run the garbage collector. @item compile [@var{struct} @dots{}] Compile any uncompiled functions in the modules named @var{struct} @dots{}. If no named modules are given, use the current module. @item compile-proc @var{procedure} @dots{} Compile the functions called @var{procedure} @dots{} in the current module. @item describe @var{symbol} Look for documentation describing the current meaning of @var{symbol}, if any is found, print it. @item dis @var{form} Disassemble the bytecode form or compiled function that is the result of evaluating @var{form}. @item expand @var{form} Print @var{form} with any outermost macro calls recursively expanded. @item exports Print the names of the variables exported from the current module. @item help List all REPL commands. @item imports Print the names of the modules imported by the current module. @item in @var{struct} [@var{form}] If @var{form} is given, temporarily switch to the module called @var{struct}, evaluate @var{form} printing the result, then switch back to the original module. If @var{form} isn't given, simply switch the current module to be @var{struct}. @item interfaces Print all defined module interfaces, and their definitions. @item load @var{struct} @dots{} Attempt to load the module called @var{struct}. @item load-file "@var{filename}" @dots{} Load the file of Lisp forms called @var{filename}. @item locate @var{symbol} Recursively scan from the current module for the module providing the binding of @var{symbol}. @item new @var{struct} Create a new module called @var{struct}, and set it as the current module. It will import the @code{rep.module-system} module, but nothing else (i.e. no actual language). @item open @var{struct} @dots{} Import the modules called @var{struct} @dots{} to the current module. This is analogous to the @code{open} clause in the configuration form of the module's definition. @item profile @var{form} Evaluate @var{form}, recording information about the frequency and duration of the calls it makes to subroutines (and the calls they make, and so on). This information is tabulated and printed after the evaluation has finished. @item quit Terminate the Lisp interpreter. @item reload @var{struct} @dots{} Reload the modules called @var{struct} @dots{}. If modules of these names had previously been loaded, they will be deallocated when there are no remaining references to them. Note that importing the interface of one module into another does not create object references between the two modules (the references are purely symbolic). However, each closure (i.e. function) created in a module does contain a reference to the module it was created in. @item step @var{form} Evaluate @var{form} in single-step mode (using the debugger). @item structures Print the names of all currently defined modules. @item time @var{form} Evaluate the form @var{form}, print the result and the time it took to perform the evaluation. @item unload @var{struct} @dots{} Attempt to unload the modules called @var{struct} @dots{}. As with reloading, unloading a module only removes the link between the module name and the module body. Only once no more references exist to the module body will it be freed. @item whereis @var{symbol} Scan all loaded modules for those that export a binding of @var{symbol}, and print the results. @end table librep-0.90.2/man/news.texi0000644000175200017520000011464311245011153014511 0ustar chrischris@c -*-Texinfo-*- @appendix News @cindex News @heading 0.90.2 @itemize @bullet @item Fixed a major defunct with prin1 + utf8 [Timo Korvola] @item Fixed descriptions of formats %s and %S in streams.c @end itemize @heading 0.90.1 @itemize @bullet @item Properly terminate the rep interpreter [Jürgen Hötzel] @item Use readline history in interactive mode [Jürgen Hötzel] @item Tar file-handler does now support XZ compressed tarballs @item Tar file-handler does now support LZMA compressed tarballs @item Improved regex for parsing tar output in the file-handler [Alexey I. Froloff] @item We do now correctly check for libffi @item Improved libffi-binding [Alexey I. Froloff] @item Updated librep.sym for missing entries [Alexey I. Froloff] @item Fixed an incomplete definition @item Added -L$prefix to libs section of the .pc file @item No C++ style comments in C code @end itemize @heading 0.90.0 @itemize @bullet @item Added UTF-8 Support! [Wang Diancheng] @item Remove scheme and unscheme modules @item Going on with code-cleanup @end itemize @heading 0.17.4 @itemize @bullet @item Don't ignore datarootdir setting @item Fixed an aclocal warning from configure.in @item Improved configures ending message @item Doc update in 'Numbers' section. Lacking description on machine dependence is added. [Teika] @item Remove tar target from Makefile [Ritz] @end itemize @heading 0.17.3 @itemize @bullet @item Updated MAINTAINERS @item Dropped rep.m4 - use librep.pc instead @item Improved librep.pc @item Updated librep.spec @item Add -L/lib$libsuff to READLINE_LIBS [T2 Patch] @item Fix compilation on PPC64 [Marcus Comstedt] @item Small fixup in src/fake-libexec [SuSE] @item No rpath in src/rep-config.sh [Fedora] @item Added ebuild [Harald van Dijk] @item Improved Makefile's distclean rule @item Reworked autogen.sh @item Reworked configure.in @item Major rework of the spec-file @item Improved configure's ending message @item Fixed configure.in's templates for autoheader @item BSD-Tar is not supported by librep, give users a usefull warning message [Mark Diekhans] @end itemize @heading 0.17.2 @itemize @bullet @item fixups for configure.in @item updated BUGS, HACKING and README @item define inline if undefined (fixes compiler warnings) @item create the destination directory for the .pc file before installing it @item fixed in issue with FreeBSD in numbers.c [FreeBSD patch] @item improved a function of numbers.c [FreeBSD patch] @item rep_file_fdopen has not been listed in librep.sym @item added --tag=CC to libtool in several places @item don't ignore $LDFLAGS upon build @item dropped some useless code in sdbm.c @item make sure inline is defined @end itemize @heading 0.17.1 @itemize @bullet @item started code-cleanup @item added a .pc file @item added --no-split to makeinfo [FreeBSD patch] @item added --enable-paranoia to configure [compile with CFLAGS+="-Wall -ansi"] @item updated the spec file @item replaced a static void by a void in main.c [Debian patch] @item use correct shebang in rep-xgettext.jl [ALT-Linux patch] @item trim trailing / to mkdir(2) [NetBSD patch] @end itemize @heading 0.17 @itemize @bullet @item Added @code{rep.ffi} module (Foreign Function Interface). Uses gcc's libffi. Very untested. @item Partial implementation of guile's @code{GH} interface. @item Bug fixes: @itemize @minus @item Don't hang in select for a second when starting processes via the @code{system} function (race condition that only seems to show up on Linux 2.6 kernels) @item Miscellaneous fixes for Mac OS X. @item Don't return a reversed list of items from the XML parser. (Alexander V. Nikolaev) @item Fixes to string capitalization functions. (Charles Stewart) @end itemize @end itemize @heading 0.16 @itemize @bullet @item New modules @code{rep.data.trie}, @code{rep.threads.proxy} @item Also added @code{rep.xml.reader} and @code{rep.xml.printer}, though these should probably be used with extreme caution @item Appending to queues is now O(1) not O(n) @item Many changes to @code{rep.net.rpc} module, protocol is incompatible with previous version. Should be more robust @item @code{rep.i18n.gettext} module exports the @code{bindtextdomaincodeset} function (Christophe Fergeau) @item Slightly more secure way of seeding the rng @item @code{inexact->exact} can now convert floating point numbers to rationals (though not optimally). This means that @code{numerator} and @code{denominator} also work better with floats now @item New function @code{file-ttyp} @item Some random bug fixes @end itemize @heading 0.15 @itemize @bullet @item Parser can now associate lexical location (file name and line number) with parsed objects. Added @code{call-with-lexical-origins} and @code{lexical-origin} functions. This adds memory overhead but is only enabled in interpreted mode, or other times it could be useful (e.g. when compiling) @item The compiler enables line-numbering, and uses the information when it prints errors. It also prints errors in a more standard format (intended to mimic GCC), and distinguishes warnings from errors @item Debugger is much improved, and supports emacs-style emission of line number tokens. Use the included @file{rep-debugger.el} elisp code to source-debug rep programs in Emacs! @item New command line option @samp{--debug}. When given, rep starts up in the debugger @item Reformatted backtrace output. Also backtraces only ever include evaluated argument lists now. They also include lexical information when possible @item Syntax errors include error description and line number @item Now supports weak reference objects. New functions @code{make-weak-ref}, @code{weak-ref}, @code{weak-ref-set}. A weak reference is a pointer to another object. When that object is garbage collected, the pointer in the weak reference is set to false. @item New `error helper' module. When an error is handled, this module is called and tries to print a human-understandable message explaining why the error may have occurred @item REPL commands may now be specified by their shortest unique set of leading characters, e.g. @samp{,o} instead of @samp{,open} @item Added an @code{#undefined} value. Returned by @code{%define} and the macros using it (@code{defun}, @code{defmacro}, etc@dots{}) @item New function @code{table-size} in module @code{rep.data.tables} @item @code{thread-suspend} returns true iff the timeout was reached (i.e. return false if @code{thread-wake} was used to unsuspend the thread) @item Objects defined using the @code{object} macro now have an implicit @code{self} binding -- the object representing their self (or their most derived self) @item Added @var{timeout} parameter to @code{condition-variable-wait} and @code{obtain-mutex} functions @item New @code{rep.threads.message-port} module, implements a simple message queue for threads @item @code{log} function now optionally accepts a second argument, the base of the logarithm @item Use gmp to generate random numbers when possible (if at least version 3 of gmp is found) [disabled in librep 0.15.1 -- gmp seems to be buggy?] @item The @code{string-replace} function may now be given a function as its @var{template} parameter @item Bug fixes: @itemize @minus @item Signal an error if writes don't write all characters they were asked to. Also, some functions could write fewer characters than they were supposed to even if no errors occurred @item Remembered that file sizes may not fit in fixnums @item Don't preserve trailing slashes in results of canonical-file-name (to make the path canonical) @item Don't signal an error when end of file is encountered immediately after reading @samp{#\X} syntax @item @code{current-thread} and @code{all-threads} will create a thread object for the implicit thread if there isn't one already @item In C subrs that take optional integer arguments, signal an error if the given value isn't an integer or undefined (false). Also, accept all types of numbers where it makes sense to do so @item Signal an error if end of file is read while parsing a block comment @item Don't ever return a null object from @code{current-time-string} @item Catch errors signalled during command line option processing, and pass them to the standard error handler @item Right hand side of @code{letrec} bindings may now have more than one form @item The @code{object} macro now evaluates its @var{base-object} parameter exactly once @item Finally removed @code{define-value} @item Ignore null lines (or lines which only have comments) in the repl @item In the compiler, don't expand macros which have have been shadowed by local bindings @item Don't print some compiler errors/warnings twice @item Fixes for @code{mips-compaq-nonstopux} architecture (Tom Bates) @item Fixed @code{,reload} and @code{,unload} repl commands not to try to remove non-existent structures @end itemize @end itemize @heading 0.14 @itemize @bullet @item New module @code{rep.util.md5}, has two functions for generating MD5 message digests (of files or strings) @item Changes to the @code{rep.io.sockets} function: In the @code{socket-server} function the @var{host} and/or @var{port} arguments may be false, meaning to listen on all addresses and to choose a random unused port. New functions @code{socket-peer-address} and @code{socket-peer-port}, these always returns the details of the far end of the connetion. @code{socket-address} and @code{socket-port} have been changed to always return the details of the local connection point. @item New function in @code{rep.system} module, @code{crypt}. A wrapper for the system's @code{crypt} function (if it has one) @item New function in @code{rep.threads} mdoule, @code{make-suspended-thread} @item New module @code{rep.net.rpc}, provides a text-stream based RPC mechanism for Lisp programs. Similar in some ways to untyped CORBA. (This is still in the experimental stage -- its interface may change in forthcoming releases) @item New functions in @code{rep.data} module, @code{list->vector} and @code{vector->list} @item New macro @code{define-special-variable}. A combination of @code{defvar} and @code{setq} -- it always makes the variable special and it always sets it to the given value @item New module @code{rep.test.framework} implementing @code{assert}, @code{check} and @code{test} macros. This provides a framework for implementing unit tests in Lisp modules (such that running the interpreter with the @samp{--check} option will run all tests that have been set up to be autoloaded @item Bug fixes: @itemize @minus @item When reading from strings, don't choke on zero bytes @item When writing into sockets, be aware that the socket is in non-blocking mode @item SDBM and GDBM modules now close any open databases before the interpreter exits @item Fixed the @code{rep_parse_number} function not to require a terminating null character in the string when parsing bignums @item Only define @code{Qrep_lang_interpreter} once @item Don't assign vm registers to physical registers on 68000 architectures -- it's been reported to crash @item When running asynchronous subprocesses, open and initialize the pty slave before forking to avoid a race condition with the child process @item Flush symbols from the module cache at another point @item Fixes for Unixware @item When compiling non-top-level @code{defvar} forms, add any doc string they have to the database @end itemize @end itemize @heading 0.13.5 @itemize @bullet @item Tar file handling no longer requires GNU tar @item The @code{defvar} special form can now take only a single argument @item The reader now treats @code{#\return} characters as white space @item Other miscellaneous bug fixes@dots{} @end itemize @heading 0.13.4 @itemize @bullet @item Don't restrict symbols exported from plugin libraries, some need to export symbols to work properly (this bug only seemed to appear on Solaris systems) @item Added @code{rep_file_type} and @code{rep_guardian_type} to the list of symbols exported from librep @item Fixed the @code{install-aliases} script (Peter Teichman) @item New module @code{rep.threads.condition-variable} @item Added @code{string-split} and @code{string-replace} to the gaol @end itemize @heading 0.13.3 @itemize @bullet @item Try to only export public symbols from @file{librep.so} and modules @item When expanding file names translate @samp{/..} to @samp{/} @item Set an upper bound on the allowed recursion depth when regexp matching, prevents the stack from overflowing in pathological cases @item Added optional second arg to @code{readline} function, a function to call to generate completions. The @code{rl-completion-generator} method of supplying this function is deprecated @item Fixed bugs when handling character-case in regexp module (Andrew Rodionoff) @item Added an @code{premature-end-of-stream} error. This is signalled instead of @code{end-of-stream} when reading characters in the middle of a syntax form. The @code{end-of-stream} error is only signalled when the end of the stream is reached before encountering anything other than whitespace characters @item Fixed bug of expanding declarations in the @code{define} macro expansion @end itemize @heading 0.13.2 @itemize @bullet @item Fix @code{define} so that it tracks bound variables and ignores shadowed keywords when traversing code @item Added checks to compilation process for the kind of missing shared-library problems that many people see @item Fixed the @code{install-aliases} shell script @item New configure option: @code{--enable-full-name-terminator} @end itemize @heading 0.13.1 @itemize @bullet @item Added functions @code{remove-if} and @code{remove-if-not} @item Various bug-fixes for non-linux or solaris systems (John H. Palmieri, Philippe Defert) @item @code{#f}, @code{#t}, @code{#!optional}, @code{#!key} and @code{#!rest} are now uninterned symbols. Keywords are interned in a separate obarray @item Fixed bug of caching regexps even when their string has been modified @item Fixed some bugs in the ftp remote file handler and the @code{pwd-prompt} function @item Fixed @code{define} to ignore @code{structure} and @code{define-structure} forms @end itemize @heading 0.13 @itemize @bullet @item The end-of-list / boolean-false object is no longer the symbol @code{nil}. Instead there is a special object @code{()} fulfulling these two roles. For modules importing the @code{rep} module, the symbol @code{nil} evaluates to @code{()}. This allows the @code{scheme} module to be more compliant with the Scheme standard @item Parameter list changes: @itemize @minus @item Deprecated @code{&optional} and @code{&rest}, in favour of @code{#!optional} and @code{#!rest}. @item Added keyword parameters. Use @code{#!key} to declare them. Keyword syntax is @samp{#:@var{param}}. For example: @lisp ((lambda (#!key a b) (list a b)) #:b 2 #:a 1) @result{} (1 2) @end lisp @item @code{#!optional} and @code{#!key} parameters may now have default values, syntax is @code{(@var{var} @var{default})}. For example: @lisp ((lambda (#!optional (a 1)) a)) @result{} 1 @end lisp @end itemize @item The module namespace is now hierarchical. @samp{.} characters in module names denote directory separators, e.g. @samp{foo.bar} translates to the file @file{foo/bar} All module names prefixed with @samp{rep.} are reserved for librep, other top-level names should be picked to be as unique as possible The existing modules have been renamed to fit this scheme (see the file @file{TREE} in the distribution for the hierarchy details). However, old module names will still work for the time being @item The @code{rep} module no longer includes the @code{rep.regexp}, @code{rep.system}, @code{rep.io.files}, @code{rep.io.processes} or @code{rep.io.file-handlers} modules. These need to be imported explicitly @item Doc strings are now indexed by module name as well as symbol name. The @code{define} macro now takes a doc string as its optional third parameter @item Record constructors may include all lambda-list keywords (e.g. keywords and/or default values) @item Incompatible virtual machine changes, hence bytecode files will need to be recompiled. Improvements include: @itemize @minus @item Only heap-allocate variables when absolutely necessary @item Closure analysis to allow inlining of some types of @code{letrec} expressions @item Added a `safe' virtual machine, which makes no assumptions regarding validity of bytecode, so is safe for untrusted code @end itemize @item Added an @code{unscheme} module. Another Scheme implementation, but the goal of this one is to integrate cleanly with the librep runtime environment, even if this is at the expense of R4RS compliance For example, in @code{unscheme} code, @code{#f @result{} ()} and @code{#t @result{} t}. This allows rep and unscheme functions to call each other without needing to convert any data @item By default, it is now illegal to modify top-level variables that have not previously been defined @item New macro @code{define-structures} to export multiple views of a single underlying environment @item The librep runtime no longer handles the @samp{--help} option itself, this should be done by scripts @item Don't search @code{$LD_LIBRARY_PATH} for plugins, but prepend all directories in colon-separated @code{$REP_DL_LOAD_PATH} to @code{dl-load-path}. Similarly, the contents of @code{$REP_LOAD_PATH} is prepended to @code{rep-load-path} @item @code{(/ @var{x}) @result{} (/ 1 @var{x})} @item Extra string-manipulation functions: @code{string-replace}, @code{string-split} (in the @code{rep.regexp} module) @item @code{#f} and @code{#t} are now primitive symbols, not special objects @item Special case tail-recursive calls to @code{apply}, to ensure they get eliminated @item The @samp{0x123} and @samp{0123} read syntaxes have been deprecated, use @samp{#x123} and @samp{#o123} instead @item @samp{#| @dots{} |#} comments now nest correctly @item New modules: @code{rep.i18n.gettext}, @code{rep.vm.safe-interpreter}, @code{rep.vm.assembler}, @code{unscheme}, @code{rep.data.objects}, @code{rep.www.quote-url}, @code{rep.www.fetch-url}, @code{rep.util.ispell}, @code{rep.util.base64}, @code{rep.util.autoloader}, @code{rep.io.sockets}, @code{rep.util.time}, @code{rep.net.domain-name} @item Bug fixes, including: @itemize @minus @item Find size of @code{long long} type on AIX, IRIX and Solaris (Dan McNichol, Albert Chin-A-Young) @item Never allow macros to be called as functions @item Make bitfields unsigned (Albert Chin-A-Young) @item Fixed bounds-checking when parsing non-base-10 fixnums @item Thread fixes (and much lower thread-switch latency in many cases) @item Fixed @code{DEFUN} macro for C++ (Matt Tucker); also fixed header files to avoid C++ keywords @item Make error message for bytecode version mismatches more meaningful @item Fixed: @code{default-boundp}, @code{continuation-callable-p} @item Only the evaluate the value of @code{defvar} forms if the symbol isn't already bound @item Compile else-less @code{case} expressions correctly; eliminate tail-recursion in @code{cond} forms when possible @item Various fixes in @code{scheme} module @end itemize @end itemize @heading 0.12.4 @itemize @bullet @item Support building without GNU MP, @samp{--without-gmp} option to configure. Use @code{long long} for non-fixnum integers (promote to floats when out of range); no exact rationals. There's also an option to disable continuations/threading (@samp{--disable-continuations}) @item Sanitized function inlining: @itemize @minus @item Use @code{(declare (inline @var{names}@dots{}))} to tell the compiler that it might be useful to inline the named functions @item Don't even think about inlining across module/file boundaries (for now anyway) @end itemize @item Cleaned up the @code{gaol} module. Interface is essentially: @code{gaol-define}, @code{gaol-define-special}, @code{gaol-define-file-handler}. Added @code{gaol-open} to import complete modules. Still supports old interface @item Be a lot more efficient when printing quoted strings and symbol names (for some streams there used to be a system-call per character!) Also, when quoting weird symbol names, be more intelligent @item Removed code to autoload from modules (which didn't really work anyway) @item Be more intelligent about deciding when to flush the module cache @item Build fixes for IRIX (David Kaelbling) @item Other miscellaneous bug-fixes and performance tweaks @end itemize @heading 0.12.3 @itemize @bullet @item New function @code{thread-join}, waits for a specified thread to exit, then returns the value of the last form it evaluated @item Added a rudimentary profiler (@samp{,profile @var{form}} command in repl) @item Reorganized @code{ring} module, sanitized the interface (preserving compatibility with old functions), also added a @code{ring->list} function @item @code{rplaca} and @code{rplacd} (but not @code{setcar} and @code{setcdr}) functions now return the cell being modified, not the value being stored into it, for compatibility with CL (Karl Hegbloom) @item @code{unwind-protect}, @code{catch}, @code{condition-case}: these special forms are now macros @item When signalling @code{bad-arg} or @code{missing-arg} errors, try to include the function as the first element of the error data @item @code{load} function now @emph{only} loads files without suffixes if @var{no-suffix} arg is non-@code{nil} (prevents picking up un-suffixed files by mistake, e.g. from the current directory) @item Fixed some bugs when reading rationals @item Fixed bug of @code{gettext} module not redefining @code{_} binding in @code{rep} module @item Fixed bug when building @code{rep-config} script (Mark Hewitt, Dan Winship) @item Fixed bug of @code{rep_INTERN_SPECIAL} macro not looking for default values of special variables @item Fixed interpreted versions of @code{min} and @code{max} when operating on non-numeric values @item If unable to allocate heap space, just print an error and terminate the program (the low-memory handling doesn't currently work properly) @item Fixed bug when extracting doc strings from @code{define} forms @item Fixed bug when compiling structure definitions in non-top-level environments @item Fixed bug of being unable to @code{load} empty files @item When recursively macro-expanding, dereference identifiers in the correct module @end itemize @heading 0.12.2 @itemize @bullet @item The tar file-handler now caches the unpacked archive (wins big when loading sawfish themes) @item The @code{gaol} module can now create multiple gaols, each with it's own namespace @item More performance tweaks @item Miscellaneous bug-fixes (more vm stack smashing, @code{defconst} never evaluates its constant) @end itemize @heading 0.12.1 @itemize @bullet @item Some virtual machine performance tweaks @item Fixed nasty stack smashing bug (when using compiler declarations) @item Some 64-bit cleanups (George Lebl) @item Fixed non-ANSI C syntax (Sam Falkner) @end itemize @heading 0.12 @itemize @bullet @item Added a basic module system. Modelled after the Scheme48 system, but simpler. At its simplest, include a @code{define-structure} form in each file representing a module: @lisp (define-structure @var{name} @var{interface} @var{config} @var{body}@dots{}) @end lisp @noindent The external definitions of this module can then be imported by other modules through their @var{config} statements, e.g. @code{(open @var{NAMES}@dots{})}. Most modules will open @code{rep} to get the standard language definitions. @code{foo#bar} reads as @code{(structure-ref foo bar)} The @code{timers}, @code{tables}, @code{sdbm}, @code{gdbm}, @code{readline}, @code{gettext}, @code{ring}, @code{mutex}, @code{memoize}, @code{lisp-doc}, @code{disassembler}, @code{compiler}, @code{date}, @code{cgi-get}, @code{gaol} features are all now modules (this is backwards compatible, since modules may be imported using @code{require}) See the ``Modules'' section of the manual for more details. @item The repl now contains meta-commands for inspecting and configuring the module system (amongst other things) @item Added a facility for creating new primitive types: @code{make-datum}, @code{datum-ref}, @code{datum-set}, @code{has-type-p}, @code{define-datum-printer} @item Added an SRFI 9 compatible @code{define-record-type} macro for defining data structures (the @code{records} module) @item Added fluid variables---a method of creating dynamically scoped bindings that fit well with lexically scoped definitions (@code{make-fluid}, @code{fluid}, @code{fluid-set}, @code{with-fluids}, @code{let-fluids}) @item Added a @code{queues} module providing a basic queue type @item Added stream functions: @code{peek-char}, @code{input-stream-p}, @code{output-stream-p} @item Interpreter now also eliminates tail-calls @item Changed handling of inexact numbers to be compatible with the Scheme standard: @itemize @minus @item Many operations now produce inexact outputs if any of their inputs are inexact (e.g. @code{min}, @code{max}, @code{floor}, @code{ceiling}, @code{round}, @code{truncate}) @item @code{eql} and @code{equal} no longer ignore exactness when comparing numbers. @code{=}, @code{/=}, @code{<}, @code{>}, @code{<=} and @code{>=} @emph{do} ignore inexactness. E.g. @lisp (eql 2 2.) @result{} nil (= 2 2.) @result{} t @end lisp @end itemize @item Support most of Scheme's read-syntax for numbers (i.e. @samp{#b}, @samp{#o}, @samp{#d}, @samp{#x} radix prefixes, and @samp{#e}, @samp{#i} exactness prefixes). @item Implemented Scheme's @code{string->number} and @code{number->string} functions @item Included a basic R4RS Scheme implementation (module: @code{scheme}). Do @kbd{,new foo @key{RET} ,open scheme} to test it in the repl, use @code{(open scheme)} instead of @code{(open rep)} to use it within modules. The compiler also knows enough about Scheme to be able to compile it. Also, use the @samp{-s} or @samp{--scheme} options to load a file of Scheme code. @item The debugger works better (and can be used to walk the stack history somewhat) @item Last arg of @code{append} and @code{nconc} may be a non-proper-list now @item Implemented the Scheme @code{do} macro for iteration @item @code{define} supports curried functions. E.g. @code{(define ((plus a) b) (+ a b))}, then @code{(plus 1)} evaluates to the function that adds one to its argument. @item Many performance improvements: @itemize @minus @item Allocates less memory (so garbage collects less often) @item Much faster at bytecode-to-bytecode function calling @item Much reduced VM overhead (when compiled with GCC) @end itemize @item Compiler improvements: @itemize @minus @item Supports the @code{(declare @var{clauses}@dots{})} form. See the ``Compiler Declarations'' section of the manual for details on the actual declarations supported. @item Is cleverer about detecting when to create new bindings when tail recursing, and when the old bindings can just be overwritten @item Groks the module system, and the language of the module being compiled (so that it can compile both rep and Scheme code) @item Splices bodies of top-level @code{progn} and @code{begin} forms themselves into the top-level (for when macros expand into multiple definitions) @item Compiling already defined functions (or whole modules of functions) now (mostly) works @item Coalesce and compile non-defining top-level forms @end itemize @item Many bug fixes (see ChangeLog files for details) @end itemize @heading 0.11.3 @itemize @bullet @item Fixed bug of throwing uninitialized errors when autoloading @item Fixed bug of interpreting @code{(let () @dots{})} as a named let @end itemize @heading 0.11.2 @itemize @bullet @item Replaced many special forms by macros---@code{let}, @code{let*}, @code{function}, @code{if}, @code{and}, @code{or}, @code{prog2}, @code{defmacro}, @code{defun}, @code{defconst}, @code{define-value}, @code{setq-default} @item @code{let} now supports Scheme's named-let construct for iteration via tail recursion @item Parse some standard Common Lisp and Scheme syntax: @samp{#| @dots{} |#} block comments, @samp{#\@var{c}} or @samp{#\@var{name}} characters (where @var{name} may be one of: @code{space}, @code{newline}, @code{backspace}, @code{tab}, @code{linefeed}, @code{return}, @code{page}, @code{rubout}), and @samp{#(@dots{})} vectors @item When comparing symbols, compare their names as strings @item Implemented Scheme's @code{dynamic-wind} function @item Fixed bug of sometimes evaluating function arguments in the environment of the callee not the caller @item Fixed bug when calculating how long to sleep for when no threads are available @item Fixed bugs in mutex implementation (Damon Anderson) @item Work around bugs in Tru64 @code{RTLD_GLOBAL}; everything should work on Tru64 now (Aron Griffis) @item Fixed bug of not saving current regexp state across continuations @end itemize @heading 0.11.1 @itemize @bullet @item The compiler now eliminates single-function tail calls (instead of leaving it to the virtual machine) @item Updated to use libtool-1.3.4 @item Miscellaneous bug fixes and minor changes @end itemize @heading 0.11 @itemize @bullet @item Better support for numerical computing. Now supports bignums, rational numbers (numerator and denominator are bignums), and floating point values as well as the original fixnums. Many new numerical functions supporting these types. Promotes and demotes hopefully as you'd expect (never demotes an inexact number to an exact number). Tries to follow the Scheme numeric system as much as possible @item Supports @dfn{guardian} objects through the @code{make-guardian} function (as described in Dybvig's paper). These are a clean mechanism for allowing the programmer to control when arbitrary lisp objects are finally deallocated. Also added a new hook: @code{after-gc-hook} @item The default error handler can now be redefined. If the variable @code{error-handler-function} contains a function then it will be called to handle the error, with arguments @code{(@var{error} @var{data})}. @item New special form @code{case}, switches on a key value and sets of constants @item New function @code{call/cc} (also available through the alias @code{call-with-current-continuation}). Provides scheme-like continuation functions. Special variables are now deep-bound to support this correctly @item Supports ``soft'' preemptive threads using continuations and a general ``barrier'' mechanism (used either for restricting control flow, or for receiving notification when control passes across a barrier) @item Parameter lists in lambda expressions now support improper lists, as in scheme. E.g. @code{(lambda (x . y) @dots{})} @item Implements the scheme @code{define} syntax, with support for inner definitions @item The @code{tables} plugin implements hash tables, with extensible hashing and comparison methods; supports both strongly and weakly keyed tables @item Included a GDBM binding; DOC files are now stored in GDBM files (SDBM has limits on datum sizes) @item @code{put} and @code{get} functions now use @code{equal} to compare property names @item Virtual machine / compiler improvements: @itemize @minus @item Variable references and mutations are classified by type: lexical bindings use (one-dimensional) lexically addressed instructions, global non-special bindings have their own instructions, everything else uses the original instructions. Similar classification when creating new bindings @item Eliminate tail-recursive function calls wherever possible in compiled code (when the calling function has no dynamic state) @end itemize @noindent Compiled lisp code will need to be rebuilt to run on the modified virtual machine. @item When expanding macros, bind @code{macro-environment} to the macro environment it was called with. This allows macros to reliably expand inner macro uses @item New hook @code{before-exit-hook}. Called immediately before exiting @item @code{rep-xgettext} now has an option @samp{--c}. This makes it output pseudo C code containing the string constants found @item Fixed misfeature of interpreting filenames @file{@var{foo}//@var{bar}} as @file{/@var{bar}}. Contiguous path separators are now merged (i.e. @file{@var{foo}/@var{bar}}) @end itemize @heading 0.10 @itemize @bullet @item Updated support for dumping (freezing) lisp definitions to handle lisp-1 nature with closures. Also now generates C code instead of assembler for portability; creates a plugin that may be loaded through the REP_DUMP_FILE environment variable @item Plugin @file{.la} files may now contain rep-specific settings: @samp{rep_open_globally=yes} and @samp{rep_requires='@var{FEATURES}@dots{}'} @item New function @code{define-value}. A combination of @code{set} and @code{defvar}, but without implying dynamic scope @item @code{load} scans @var{after-load-alist} for plugins as well as lisp libraries @item @code{(if t)} now evaluates to @code{nil} not @code{t} @item Fix regexp bug in matching simple non-greedy operators (Matt Krai) @item Borrowed guile's bouncing parentheses for readline (Ceri Storey) @item New C functions @code{rep_load_environment} and @code{rep_top_level_exit} @item @code{defvar} allows symbols to be redefined in protected environments if they haven't also been defined by unprotected environments @item Detect GCC's with broken @code{__builtin_return_address} functions (George Lebl) @item Try to use libc @code{gettext} implementation, but only if it looks like it's the GNU implementation @end itemize @heading 0.9 @itemize @bullet @item Support for using GNU readline (give configure the @samp{--with-readline} option) @item New functions: @code{letrec}, @code{caar}, @dots{}, @code{cddr}, @code{caaar}, @dots{}, @code{cdddr}, @code{in-hook-p}, @code{make-variable-special} @item Changed @code{unless} to have the Common Lisp semantics---return @code{nil} when the condition evaluates true, not the value of the condition @item Fixed/added some compiler optimisations @item Fixed @code{rep-xgettext} script to remove duplicated strings and to search exhaustively @item @code{add-hook} forces the hook variable to be special (in case it wasn't declared using @code{defvar}) @end itemize @heading 0.8.1 Fixed some documentation bugs; fixed some build problems @heading 0.8 @itemize @bullet @item Default scoping is now lexical, only variables declared using @code{defvar} are dynamically scoped. @item There is now only a single namespace for symbols (excepting property lists), this means that the @code{fset}, @code{symbol-function} and @code{fboundp} functions have been removed This allows all elements in procedure-call forms to be evaluated equally (as in scheme), so things like: @lisp ((if t + -) 1 2) @end lisp @noindent now work. Related to this, function names (i.e. symbols and lambda expressions) are no longer dereferenced by any operations taking functions as arguments. Only built-in subroutines and closures are considered functions. This means that where before you'd write something like: @lisp (mapcar '+ '(1 2 3)) @end lisp @noindent this is now illegal; the @code{+} function must be evaluated: @lisp (mapcar + '(1 2 3)) @end lisp @item @code{lambda} is now a special form evaluating to a closure (as in scheme); this means that the following are exactly equivalent: @lisp (lambda (x) x) @equiv{} (function (lambda (x) x)) @equiv{} #'(lambda (x) x) @end lisp An alternative method of enclosing a lambda expression is to use the @code{make-closure} function. @item @code{gaol} module providing semi-safe environment for untrusted code to evaluate in @item Support for i18n through @code{gettext} module; also support for @samp{%1$s} type format specifiers @item New functions @code{string-equal} and @code{string-lessp} @end itemize @heading 0.7.1 @itemize @bullet @item Added @samp{--with-rep-prefix} option to autoconf AM_PATH_REP macro @item Fixed bug when inserting a new timer before an existing timer @item Fix the malloc tracking code @item Fix dlmalloc for FreeBSD @item Use install when installing, not cp @item Some fixes for compiling with SUN's C compiler on Solaris @end itemize @heading 0.7 @itemize @bullet @item Added file handler for read-only access to the contents of tar archives, access files like @file{foo.tar.gz#tar/bar} @item @code{process-id} function now returns pid of lisp interpreter when called with zero arguments @item Added (untested) support for loading dynamic objects via @code{shl_load} (HP-UX) @item Added (untested) support for systems that prefix symbol names in dynamic objects with underscores @item Fix bug when compiling @code{last} function @item Fix bug of not closing files in the @code{load} function @end itemize @heading 0.6.2 @itemize @bullet @item Added @code{autoload-verbose} variable; set it to @code{nil} to turn off the messages when autoloading @item Fix problems when @samp{--prefix} option has a trailing slash @item Updated libtool files to version 1.3.3 @item Initial (incomplete) support for building under Tru64, from Aron Griffis @end itemize @heading 0.6.1 No new features; minor portability tweaks and build changes. Fix bug of trying to load directories as Lisp scripts @heading 0.6 @itemize @bullet @item Add @code{unsetenv} function @item @code{system} now uses @code{process-environment} @item Workaround compiler bug with GCC 2.95 on sparc @item Fix build problem where libsdbm.la can't be located @end itemize @heading 0.5 @itemize @bullet @item New function @code{set-input-handler}, registers an asynchronous input handler for a local file @item Don't abort on receipt of unexpected @code{SIGCHLD} signals @item Upgrade libtool to version 1.2f @item The @code{rep} binary by default always loads a script named @file{rep}, not named by it's @code{argv[0]} (this breaks under the newer libtool) @end itemize @heading 0.4 @itemize @bullet @item Sending a rep process a @code{SIGUSR2} prints all debug buffers @item Added @samp{--with-value-type}, and @samp{--with-malloc-alignment} configure options. Also added code to automatically detect the first of these options. @item Fixed some 64-bit problems @item Removed the difference between static and dynamic strings @end itemize @heading 0.3 @itemize @bullet @item New compiler command line option @samp{--write-docs} @end itemize @heading 0.2 @itemize @bullet @item The variables @code{error-mode} and @code{interrupt-mode} control where errors and user-interrupts (i.e. @code{SIGINT} signals) are handled. The three possible values are: @code{top-level}, @code{exit} and @code{nil} (denotes the current event loop). @item Fixed bug where all dynamic types were erroneously @code{symbolp}. @item @code{SIGINT}, @code{SIGHUP} and @code{SIGTERM} signals should now be caught more successfully. @item Added a new directory to @code{dl-load-path}: @samp{@var{libexecdir}/rep/@var{arch}} to contain third-party shared libraries. @end itemize @heading 0.1 First public release. librep-0.90.2/man/librep.texi0000644000175200017520000002431411245011153015005 0ustar chrischris\input texinfo @c -*-Texinfo-*- @setfilename librep.info @settitle librep Manual @footnotestyle end @set EDITION 1.2 @set VERSION 0.13 @set UPDATED 2 May 2009 @set UPDATE-MONTH May 2009 @ifinfo @dircategory Programming Languages @direntry * librep: (librep). A flexible Lisp environment @end direntry This is Edition @value{EDITION}, last updated @value{UPDATED}, of @cite{The librep Manual}, for librep, Version @value{VERSION}. Copyright 1999--2000 John Harper. Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. @ignore Permission is granted to process this file through TeX and print the results, provided the printed document carries copying permission notice identical to this one except for the removal of this paragraph (this paragraph not being relevant to the printed manual). @end ignore Permission is granted to copy and distribute modified versions of this manual under the conditions for verbatim copying, provided that the entire resulting derived work is distributed under the terms of a permission notice identical to this one. @end ifinfo @titlepage @title librep @subtitle A LISP extension language @subtitle Edition @value{EDITION} @subtitle @value{UPDATE-MONTH} @author John Harper @page @vskip 0pt plus 1filll Copyright @copyright{} 1999--2000 John Harper. Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. Permission is granted to copy and distribute modified versions of this manual under the conditions for verbatim copying, provided that the entire resulting derived work is distributed under the terms of a permission notice identical to this one. @end titlepage @node Top, Copying, (dir), (dir) @ifinfo This document describes @code{librep}, a simple, but powerful, Lisp dialect intended both as an embedded extension language, and as a stand-alone programming language. This is Edition @value{EDITION} of its documentation, last updated @value{UPDATED} for librep version @value{VERSION}. @end ifinfo @menu * Copying:: Distribution conditions * Introduction:: Brief introduction to librep * Invocation:: How to start the interpreter * The language:: The Lisp dialect implemented * The REPL:: The interactive environment * librep Internals:: Embedding librep in other programs * Reporting bugs:: How to contact the maintainers * News:: History of user-visible changes * Function index:: Menu of all documented functions * Variable index:: All variables which have been mentioned * Concept index:: Main index, references to all sections @end menu @node Copying, Introduction, Top, Top @chapter Copying @cindex Copying @cindex Distribution conditions @cindex Licence @code{librep} is distributed under the terms of the GNU General Public License, this basically means that you can give it to anyone for any price as long as full source code is included; you also have the right to distribute modified copies in the same way. For the actual legalese see the file @file{COPYING} in the distribution (or @pxref{(emacs)Copying}). In case it isn't obvious, scripts written to use librep are not considered derived works, and therefore may be licensed however the author wishes. However, the ability of scripts to dynamically load external libraries may complicate this situation. The distribution includes the following code from other packages: @itemize @bullet @item Henry Spencer's @code{regexp} implementation, with many modifications. This is distributed under the terms of his copyright, see the file @file{src/README.regexp} in the distribution. @item The public domain @code{sdbm} database library by Ozan Yigit. @item The backquote package from Emacs version 19, written by Rick Sladkey. @item The GNU @code{gettext} implementation for internationalized message catalogues. @end itemize Be aware that there is absolutely NO WARRANTY for this program, you use it at your own risk. Obviously I hope there are no bugs, but I make no promises regarding the reliability of this software. @node Introduction, Invocation, Copying, Top @chapter Introduction @cindex Introduction @code{librep} is a dialect of Lisp, designed to be used both as an extension language for applications and as a general purpose programming language. It was originally written to be mostly-compatible with Emacs Lisp, but has subsequently diverged markedly. Its aim is to combine the best features of Scheme and Common Lisp and provide an environment that is comfortable for implementing both small and large scale systems. It tries to be a ``pragmatic'' programming language. The author has used @code{librep} in its various forms in many projects since 1993. This includes two large programs which use it as an extension language, and many stand-alone programs. @code{rep} stands for ``Read, Eval, Print'', the three main components of any Lisp system. Some of the features of @code{librep} are: @itemize @bullet @item Lexically scoped (with special variables from CL) @item Clean module system @item Tail-call elimination @item Compiles to byte-code @item First-class continuations @item Uses GNU MP for fast bignums/rationals @item Most Emacs Lisp functions, with others inspired by Common Lisp and various Scheme implementations @item Mostly-Perl-like regular expressions @item Spawn and control subprocesses @item Dynamically loads shared libraries (a.k.a. ``plugins'') @item Extensible type, I/O, and file handling @end itemize @node Invocation, The language, Introduction, Top @chapter Invocation @cindex Invocation The @code{rep} program may be used to launch the stand-alone @code{librep} environment: @example usage: rep [@var{rep-options}@dots{}] [@var{script} [@var{script-options}@dots{]}] @end example @noindent Where @var{rep-options} may be any of the following: @table @samp @item --init @var{file} Use @var{file} to boot the Lisp system from, instead of @file{init.jl}. @item --version Print the current version number and exit @item --batch Tell the interpreter that it is running non-interactively, this reduces the number of messages output to the console @item --interp Interpreted mode. Never load compiled Lisp files: this can be useful when using the debugger. @item --no-rc Don't load the user's @file{~/.reprc} script, or the @file{site-init.jl} script @item -f @var{function} Invoke the Lisp function @var{function} (with no arguments) @item -l @var{script} Try to load the Lisp file @var{script}, this is equivalent to evaluating the form @samp{(load "@var{script}")}. @item -q Terminate the Lisp process and exit. @end table @vindex command-line-args If @var{script} is given, it names the Lisp file to load, equivalent to the @samp{-l} option, except that @samp{--batch-mode} is implied. Any @var{script-options} will be made available to the script (in the @code{command-line-args} variable). After any arguments have been processed a banner message will be displayed before entering an interactive read-eval-print loop, unless @samp{--batch-mode} was specified, in which case the interpreter exits. The read-eval-print loop simply reads complete Lisp forms (@pxref{The Lisp Reader}), evaluates them, before printing the result back to the console; this continues ad infinitum, or until you force an EOF (i.e. enter @kbd{C-d}). @subsubheading Implicitly Interpreting @code{rep} Scripts @cindex Implicitly Interpreting @code{rep} scripts @cindex Executing @code{rep} scripts @cindex Scripts, executing implicitly The @code{rep} interpreter also supports automatic invocation of scripts, using the oeprating system's support for @samp{#!} interpreter invocation (i.e. if the first line of an executable text file contains @samp{#! @var{prog}}, the program @var{prog} is used to execute the script. However there is a problem with this method, in that the @code{PATH} environment variable is not searched for the location of the interpreter, and thus the full file name of the interpreter program must be hard-coded into the script. To work around this problem @code{rep} supports a slightly different method of invocation. If the first two characters of a loaded Lisp file are @samp{#!}, then everything is treated as a comment until the first occurrence of the string @samp{!#}. This allows the first part of the script to be executed as a shell script invoking the @code{rep} interpreter. What this means, is that you want to put something like the following at the start of any scripts you want to execute implicitly (and @kbd{chmod +x} the file as well): @example #!/bin/sh exec rep "$0" "$@@" !# ;; Lisp code follows@dots{} @end example @node The language, The REPL, Invocation, Top @include lang.texi @node The REPL, librep Internals, The language, Top @include repl.texi @node librep Internals, Reporting bugs, The REPL, Top @include interface.texi @node Reporting bugs, News, librep Internals, Top @chapter Reporting bugs @cindex Reporting bugs @cindex Bugs, reporting If the @code{librep} interpreter crashes it's probably a bug (unless you're using the @code{rep-gtk} binding, in which case creating invalid GTK widget hierarchies can easily crash the Lisp system). If the interpreter hangs such that sending it interrupt signals doesn't fix the problem, that's probably also a bug. To help me fix any bugs found please try to collect as much meaningful information as possible. This will hopefully include stack backtraces (of both the C and Lisp stacks if possible), what features are loaded, what you did immediately before triggering the bug, a description of your the system, etc@dots{} Please send any bug reports to the mailing list: @email{librep-list@@lists.sourceforge.net}. Alternatively, the author may be contacted at: @email{jsh@@users.sourceforge.net}. @node News, Function index, Reporting bugs, Top @include news.texi @node Function index, Variable index, News, Top @unnumbered Function index @printindex fn @node Variable index, Concept index, Function index, Top @unnumbered Variable index @printindex vr @node Concept index, , Variable index, Top @unnumbered Concept index @printindex cp @contents @bye librep-0.90.2/man/lang.texi0000644000175200017520000112416211245011153014454 0ustar chrischris@c The Programmer's Manual -*-Texinfo-*- @chapter The language @cindex The language @cindex Lisp, the rep dialect @cindex rep, the Lisp dialect This chapter of the manual is a full guide to the librep Lisp programming language, including documentation for most of the built-in functions. @menu * Intro:: Introduction and Lisp conventions Fundamental data types. * Data Types:: Data types and values in Lisp * Numbers:: Numeric representations and functions * Sequences:: Ordered sequences of data values * Symbols:: Symbols are uniquely named objects The core language. * Evaluation:: Evaluating expressions * Variables:: Symbols represent named variables * Functions:: The building blocks of Lisp programs * Macros:: User-defined control structures * Definitions:: Block-structured definitions * Modules:: Scoping for "global" definitions * Control Structures:: Conditionals, loops, etc@dots{} * Threads:: Multi-threaded programs * Loading:: Programs are stored in files * Compiled Lisp:: Making programs run faster Data structures and I/O. * Datums:: Low-level data type definition * Queues:: FIFO queue type * Records:: Defining structured data types * Hash Tables:: Efficient table lookups * Guardians:: Protecting objects from GC * Streams:: Data sinks and sources; character streams * Hooks:: Hooks promote extensibility * Files:: Manipulating files in the filing system * Processes:: launch and control subprocesses when running under Unix Miscellaneous features. * Regular Expressions:: Matching regular expressions * Time and Date:: Manipulating time and date * i18n:: Internationalisation * System Information:: Getting details about the host * User Information:: The name of the user * Environment Variables:: Reading and writing the environment * String Functions:: Misc string manipulation * utf-8:: utf-8 functions * Sleeping:: Waiting for a period of time * Beeping:: Making a ding! sound * Messages:: Writing to the console * Command Line Options:: Retrieving command line arguments * Shell Commands:: Executing shell commands * Timers:: Asynchronous timers * Debugging:: How to debug Lisp programs * Tips:: General ideas for @code{librep} programming @end menu This manual still fails to document the following functions: default-boundp, default-value, recursive-edit, regexp-cache-control, sdbm-close, sdbm-delete, sdbm-error, sdbm-fetch, sdbm-firstkey, sdbm-nextkey, sdbm-open, sdbm-rdonly, sdbm-store, sdbmp, set-default, setq-default, @node Intro, Data Types, , The language @section Introduction @cindex Introduction, Lisp As you have probably gathered by now, @code{librep} provides a dialect of the Lisp programming language---a dialect originally inspired by Emacs Lisp, but later adapted to include many features from various Scheme implementations and Common Lisp. The language dialect aims to be convenient for both extending applications and writing large stand-alone programs. All programs written using only the information in this manual should be compatible with future revisions of @code{librep}. This following sections explain some of the most important Lisp concepts and the conventions I've used in this manual. @menu * nil and t:: Boolean values in Lisp * The Lisp Reader:: Basic program structure * Notation:: Special glyphs used * Descriptions:: How functions and variables are documented @end menu @node nil and t, The Lisp Reader, , Intro @subsection nil and t @cindex nil and t @cindex t @cindex Boolean values In the rep Lisp dialect there is a single data value representing boolean ``false''---the empty list, written as @code{()}. All other values are considered ``not-false'', i.e. ``true''. By convention the constants @code{nil} and @code{t} are used to represent the canonical boolean values. The constant variable @code{nil} evaluates to the empty list (i.e. ``false''), while @code{t} evaluates to itself (i.e. not-``false'', therefore ``true''). Reiterating, all of the conditional operations regard @emph{anything} which is not @code{()} as being true (i.e. non-false). The actual symbol @code{t} should be used where a true boolean value is explicitly stated, to increase the clarity of the code. So, @code{()}, and its alias @code{nil}, represent both the empty list and boolean falsehood. Most Lisp programmers write @code{()} where its value as a list should be emphasized, and @code{nil} where its value as boolean false is intended. Although neither of these values need be quoted (@pxref{Quoting}), most programmers will quote the empty list to emphasize that it is a constant value. However @code{nil} should not be quoted, doing so would produce the @emph{symbol} @code{nil}, not boolean falsehood. For example: @lisp (append '() '()) @result{} () ;Emphasize use of empty lists (not nil) @result{} t ;Emphasize use as boolean false (get 'nil 'color) ;Use the symbol @code{nil} @end lisp When a function is said to ``return false'', it means that it returns the false boolean value, i.e. the empty list. When a function is said to ``return true'', this means that any non-false value is returned. @node The Lisp Reader, Notation, nil and t, Intro @subsection The Lisp Reader @cindex The Lisp reader @cindex Reader, the Lisp Lisp programs and functions are stored internally as Lisp data objects, the Lisp Reader is the mechanism that translates from textual descriptions of Lisp objects to the internal data structures representing them. @findex read The Lisp Reader is the collection of internal functions accessed by the @code{read} Lisp function. It reads a character at a time from an input stream until a whole Lisp object has been parsed. @xref{Data Types}. @node Notation, Descriptions, The Lisp Reader, Intro @subsection Notation @cindex Notation @cindex Manual notation Wherever an example of evaluating a Lisp form is shown it will be formatted like this, @lisp (+ 1 2) @result{} 3 @end lisp @noindent The glyph @samp{@result{}} is used to show the computed value of a form. @footnote{In this case the list @samp{(+ 1 2)} (i.e. the list containing three elements, the symbol @code{+} and, the numbers 1 and 2), represents a function application. The first element in the list is the name of the function to be called, all other elements are the arguments to apply to it. Since the @code{+} function adds a series of numbers, the above function call is actually performing the computation @samp{1 + 2}.} When two forms are shown as being exactly equivalent to one another the glyph @samp{@equiv{}} is used, for example, @lisp (car some-variable) @equiv{} (nth 0 some-variable) @end lisp Evaluating some forms result in an error being signalled, this is denoted by the @samp{@error{}} glyph. @lisp (open-file "/tmp/foo" 'read) @error{} File error: No such file or directory, /tmp/foo @end lisp @node Descriptions, , Notation, Intro @subsection Descriptions @cindex Descriptions @cindex Functions, descriptions of @cindex Variables, descriptions of In this document the simplest type of descriptions are those defining variables (@pxref{Variables}), they look something like: @defvar grains-of-sand This imaginary variable contains the number of grains of sand in a one-mile long stretch of an averagely sandy beach. @end defvar Hooks (@pxref{Hooks}) are also described in this format, the only difference is that @samp{Variable:} is replaced by @samp{Hook:}. Functions (@pxref{Functions}) and macros (@pxref{Macros}) have more complex descriptions; as well as the name of the object being described, they also have a list of parameters which the object will accept. Each parameter in the list is named and may be referred to in the body of the description. Three keyword parameters may also be used: @code{#!optional}, @code{#!key} and @code{#!rest}. They have the same meaning as when used in the lambda-list of a function definition (@pxref{Lambda Expressions}). That is, @code{#!optional} means that all further parameters are optional, and @code{#!rest} means that the following parameter actually receives a list of any unused argument values. An example function definition follows. @defun useless-function first @code{#!optional} second @code{#!rest} tail This function returns a list consisting of the values @var{second} (when undefined the number 42 is used), all the items in the list @var{tail} and @var{first}. @lisp (useless-function 'foo 'bar 'xyz 20) @result{} (bar xyz 20 foo) (useless-function '50) @result{} (42 50) @end lisp @end defun Macros and interactive commands are defined in the same way with @samp{Macro:} or @samp{Command:} replacing @samp{Function:}. Special forms (@pxref{Special Forms}) are described similarly to functions except that the argument list is formatted differently, since special forms are, by definition, more flexible in how they treat their arguments. Optional values are enclosed in square brackets (@samp{[@var{optional-arg}]}) and three dots (@samp{@var{repeated-arg}@dots{}}) indicate where zero or more arguments are allowed. @node Data Types, Numbers, Intro, The language @section Data Types @cindex Data types The way that data is represented in Lisp is fundamentally different to languages such as C or Fortran. In Lisp each piece of data (or @dfn{value}) has two basic attributes: the data and the @emph{type} of the data. This means that type checking is performed at run-time on the actual data itself, not at compile-time on the ``variable'' holding the data. Also, there are no ``pointers'' in Lisp. As in the Java programming language, all values are references to data structures, with each actual data structure (or @dfn{Lisp Object}) being able to have as many values referring to it concurrently as necessary. Because of this lack of pointers, there can be no memory-leakage in Lisp---when an object has no more extant references, it is automatically deallocated (@pxref{Garbage Collection}). Most Lisp objects are a member of one of the primitive types; these are types built into the Lisp system and can represent things like strings, numbers, cons cells, vectors, etc@dots{} Other primitive types may be defined at run-time. More complex objects may be constructed from these primitive types, for example a vector of three elements could be regarded as a type @code{triple} if necessary. In general, each separate type provides a predicate function which returns true when applied to an object of its own type. Finally, one of the most important differences between Lisp and other languages is that there is no distinction between programs and data. But this will be explained later. @menu * Types Summary:: List of the most common types * Read Syntax:: Some types can be made from source code * Printed Representation:: All types can be printed * Equality Predicates:: How to test two objects for equality * Comparison Predicates:: Comparing two objects as scalars * Type Predicates:: Each type has a predicate defining it * Garbage Collection:: Reusing memory from stale objects @end menu @node Types Summary, Read Syntax, , Data Types @subsection Types Summary @cindex Types summary @cindex Data types, summary of Each separate data type is documented in its own section, this is a just a summary of the more common types. @table @dfn @item Numbers Numbers: fixnums, bignums, rationals and floats. @xref{Numbers}. @item Cons cell An object referring to two other Lisp objects. @xref{Cons Cells}. @item List A sequence of objects, in Lisp lists are not primitive types, instead they are made by chaining together Cons cells. @xref{Lists}. @item Vector A one-dimensional array of objects. @xref{Vectors}. @item String A vector of characters. @xref{Strings}. @item Array An ordered sequence of objects which can be accessed in constant time, either a vector or a string. @xref{Sequences}. @item Sequence An ordered sequence of objects, either a list or an array. @xref{Sequences}. @item Symbol A symbol is a named object; they are used to provide named variables and functions. @xref{Symbols}. @item File A link to a notional file in the filing system. This file may be in the local filing system, or on a FTP server, or wherever. @xref{Files}. @item Process An object through which processes may be created and controlled. @xref{Processes}. @item Stream Serial data sinks and sources. These may include files, functions, and processes. @xref{Streams}. @item Void The empty type, only used in symbols to represent an undefined value. Note that this is not the same as @code{()}, which is the empty list, or false truth value. @end table @node Read Syntax, Printed Representation, Types Summary, Data Types @subsection Read Syntax @cindex Read syntax @cindex Syntax of objects As previously noted the Lisp reader translates textual descriptions of Lisp objects into the object they describe (source files are simply descriptions of objects). However, not all data types can be created in this way: in fact the only types which can are numbers, strings, symbols, cons cells (or lists) and vectors, all others have to be created by calling functions. @cindex Comments Single line comments are introduced by a semi-colon character (@samp{;}). Whenever the Lisp reader encounters a semi-colon where it's looking for the read syntax of a new Lisp object it will discard the rest of the line of input. Block comments are also supported, introduced by the string @samp{#|} and terminated by @samp{|#}. @xref{Comment Styles}. The @dfn{read syntax} of an object is the string which when given to the reader as input will produce the object. The read syntax of each type of object is documented in that type's main section of this manual but here is a small summary of how to write each type. @table @asis @item Numbers A number is number written as an integer---decimal, octal (when the number is preceded by @samp{#o}) or hexadecimal (when the number is preceded by @samp{#x})---or a decimal rational or floating point value. An optional minus sign may be the first character in a number. Some examples are, @lisp 42 @result{} 42 #o177 @result{} 127 #x-ff @result{} -255 3/2 @result{} 3/2 1.23 @result{} 1.23 @end lisp @item Strings The read syntax of a string is simply the string with a double-quote character (@samp{"}) at each end, for more details see @ref{Strings}. @lisp "This is a string" @end lisp @item Cons cells A cons cell is written in what is known as @dfn{dotted pair notation}, an opening left-parenthesis, followed by the read syntax of the first object, followed by a dot, then the second object, and finally a closing right-parenthesis. For example: @lisp ("car" . "cdr") @end lisp @item Lists The syntax of a list is similar to a cons cell, but the dot is removed and zero or more objects may be written: @lisp (0 1 2 3) ("foo" ("bar" "baz") 100) @end lisp @noindent The second example is a list of three elements, a string, an inner list and a number. @item Vectors The read syntax of a vector is similar to that of a list, but with square brackets instead of parentheses, @lisp [0 1 2 3] @end lisp @item Symbols The read syntax of a symbol is its name, for example the read syntax of the symbol called @samp{my-symbol} is, @lisp my-symbol @end lisp @end table @node Printed Representation, Equality Predicates, Read Syntax, Data Types @subsection Printed Representation @cindex Printed representation As well as translating textual descriptions to Lisp objects, the process may be reversed, converting a value back to a textual description. The resulting text is known as the @dfn{printed representation} of the object, and will usually be very similar to the read syntax of the object (@pxref{Read Syntax}). Objects which do not have a read syntax @emph{do} have a printed representation, it will normally be of the form, @lisp #<@var{relevant-text}> @end lisp @noindent where the @var{relevant-text} is object-dependent and usually describes the object and its contents. The reader will signal an error if it encounters a description of an object in the format @samp{#<@dots{}>}. @node Equality Predicates, Comparison Predicates, Printed Representation, Data Types @subsection Equality Predicates @cindex Equality predicates @cindex Predicates, equality @defun eq arg1 arg2 Returns true when @var{arg1} and @var{arg2} refer to the same object. Two objects are the same when they occupy the same place in memory and hence modifying one object would alter the other. The following Lisp fragments may illustrate this, @lisp (eq "foo" "foo") ;the objects are distinct @result{} () (eq t t) ;the same object -- the symbol @code{t} @result{} t @end lisp Note that the result of @code{eq} is @emph{undefined} when called on two integer objects with the same value, see @code{eql}. @end defun @defun equal arg1 arg2 The function @code{equal} compares the structure of the two objects @var{arg1} and @var{arg2}. If they are considered to be equivalent then returns true, otherwise returns false. @lisp (equal "foo" "foo") @result{} t (equal 42 42) @result{} t (equal 42 0) @result{} () (equal '(x . y) '(x . y)) @result{} t @end lisp @end defun @defun eql arg1 arg2 This function is a cross between @code{eq} and @code{equal}: if @var{arg1} and @var{arg2} are both numbers then the value of these numbers are compared. Otherwise it behaves in exactly the same manner as @code{eq} does. See also the document of @code{=}. (@pxref{Comparison Predicates}.) @lisp (eql 3 3) @result{} t (eql 1 2) @result{} () (eql "foo" "foo") @result{} () (eql 'x 'x) @result{} t @end lisp @end defun @node Comparison Predicates, Type Predicates, Equality Predicates, Data Types @subsection Comparison Predicates @cindex Comparison predicates @cindex Predicates, comparison These functions compare their two arguments in a scalar fashion, the arguments may be of any type but the results are only meaningful for numbers, strings (ASCII values of each byte compared until a non-matching pair is found then those two values are compared as numbers) and cons cells (cars compared before cdrs). Unlike the @code{eql} function, inexact and exact numbers will be compared by first coercing the exact number to be inexact. @defun = arg1 arg2 arg3 @dots{} argn Returns true if all arguments represent the same value. @end defun @defun /= arg1 arg2 arg3 @dots{} argn Returns true if no two arguments represent the same value. @end defun @defun > arg1 arg2 arg3 @dots{} argn Returns true when @var{arg1} is `greater than' @var{arg2}, and @var{arg2} is greater than @var{arg3}, and so on, upto @var{argn}. @end defun @defun >= arg1 arg2 arg3 @dots{} argn Similar to @code{>}, but for the ``greater than or equal to'' relation. @end defun @defun < arg1 arg2 arg3 @dots{} argn Similar to @code{>}, but for the ``less than'' relation. @end defun @defun <= arg1 arg2 arg3 @dots{} argn Similar to @code{>}, but for the ``less than or equal to'' relation. @end defun There are two related functions for finding the maximum or minimum of a sequence of values. @defun max @t{#!rest} args Return the maximum value from the list of @var{args}. When comparing numbers, any inexact arguments cause the result to be inexact. @end defun @defun min @t{#!rest} args Return the minimum value from the list of @var{args}. When comparing numbers, any inexact arguments cause the result to be inexact. @end defun @node Type Predicates, Garbage Collection, Comparison Predicates, Data Types @subsection Type Predicates @cindex Type predicates @cindex Predicates, type Each type has a corresponding predicate which defines the objects which are members of that type. Each predicate function has a single parameter, if that parameter is of the correct type it returns true. @noindent @code{integerp}, @code{numberp}, @code{null}, @code{consp}, @code{listp}, @code{vectorp}, @code{subrp}, @code{functionp}, @code{sequencep}, @code{stringp}, @code{symbolp}, @code{processp}, @code{filep}. The documentation for these functions is with the documentation for the relevant type. @node Garbage Collection, , Type Predicates, Data Types @subsection Garbage Collection @cindex Garbage collection In Lisp, data objects are used very freely; a side effect of this is that it is not possible to (easily) know when an object is @dfn{stale}, that is, no references to it exist and it can therefore be reused. The @dfn{garbage collector} is used to overcome this problem; whenever enough memory has been allocated to make it worthwhile, evaluation stops and the garbage collector works its way through memory deciding which objects may still be referenced, and which are stale. The stale objects are then recorded as being available for reuse and evaluation continues. (But @pxref{Guardians}) @defun garbage-collect Runs the garbage collector, usually this function doesn't need to be called manually. @end defun @defvar garbage-threshold The number of bytes of data that must have been allocated since the last garbage collection before evaluation pauses and the garbage collector is invoked. Its default value is about 100K. @end defvar @defvar idle-garbage-threshold When the input loop is idle (due to a lack of input), this is the number of bytes of data that must have been allocated since the garbage collection, for another collection to be triggered. This is usually set to a lot less than @code{garbage-threshold} since the small delay caused by garbage collection is unnoticeable if the system is already idle. @end defvar @defvar after-gc-hook A hook (@pxref{Normal Hooks}) called immediately after each invocation of the garbage collector. @end defvar @node Numbers, Sequences, Data Types, The language @section Numbers @cindex Numbers @cindex Integers @code{Librep} lacks exact number specification. The behavior depends on if it is compiled with gmp support or not. Of course, some feautures are not available without gmp@footnote{GMP, or GNU MP is a library which supports arbitrary precision arithmetic.}. If it is compiled without gmp, then the size of integer type also depends on the platform. Size of integer is 30-bit signed at minimum. If portability is important, like sawfish, then you should expect the minimum. For more information, @xref{Types of Numbers}. For conversion of number from / to string, see @xref{String Functions}. @defun numberp object Returns true if @var{object} is a number. @end defun @menu * Types of Numbers:: * Numeric Predicates:: * Number Read Syntax:: * Arithmetic Functions:: * Integer Functions:: * Rational Functions:: * Real Number Functions:: * Mathematical Functions:: * Bitwise Functions:: * Random Numbers:: * Characters:: @end menu @node Types of Numbers, Numeric Predicates, , Numbers @subsection Types of Numbers @cindex Types of Numbers @cindex Numbers, types @cindex Portability in Number First understand that librep distinguishes @code{exact} and @code{inexact} numbers. This is similar to the Scheme dialect of Lisp. Quoting from the Scheme standard: @quotation @dots{} numbers are either @emph{exact} or @emph{inexact}. A number is exact if it was written as an exact constant or was derived from exact numbers using only exact operations. A number is inexact if it was written as an inexact constant, if it was derived using inexact ingredients, or if it was derived using inexact operations. Thus inexactness is a contagious property of a number. @end quotation @code{Librep} has three types of numbers: integer, rational, and float. With gmp, exact numbers include both integers and rational numbers. There is no theoretical limit to the range of the values that may be represented @footnote{However, depending on implementation restrictions, very large integers may be coerced to an inexact representation.}. Without gmp, only integer is exact. Rational numbers get approximated with float. On 32-bit system, integer is signed 30-bit (@emph{not} 32 bits), and 62-bit on 64-bit system. Inexact numbers are currently implemented using double precision floating point values. When exact arguments are passed to functions which take float arguments, then they are automatically converted to float. Note that rep often handles integer overflow by converting the result from integer to float. @node Numeric Predicates, Number Read Syntax, Types of Numbers, Numbers @subsection Numeric Predicates @cindex Numeric predicates @cindex Numbers, predicates on @cindex Predicates on numbers Don't use @code{eq} for equality test of numbers. Instead, use @code{eql} or @code{equal}. See @ref{Equality Predicates}. For the documentation of the functions @code{=}, @code{/=}, @code{>}, @code{<}, @code{>=}, @code{<=}, @code{max} and @code{min}, see @ref{Comparison Predicates}. @defun exactp object Returns true when @var{object} is an exact number. @end defun @defun inexactp object Returns true when @var{object} is an inexact number. @end defun @defun integerp object Returns true when @var{object} is an integer. @end defun @defun rationalp object Returns true when @var{object} is a rational number (including integers). @end defun @defun realp object Returns true when @var{object} is a real number. @end defun @defun oddp x Return true if @var{x} is an odd number. @end defun @defun evenp x Return true if @var{x} is an even number. @end defun @defun positivep x Return true if @var{x} is a number greater than zero. @end defun @defun negativep x Return true if @var{x} is a number less than zero. @end defun @defun zerop x Returns true if @var{x} is equal to zero. @end defun @node Number Read Syntax, Arithmetic Functions, Numeric Predicates, Numbers @subsection Number Read Syntax @cindex Number, Read Syntax @cindex Read Syntax of Numbers The read syntax of any number is: @code{[@var{prefix}@dots{}][@var{sgn}]@var{data}@dots{}}, where the optional @var{sgn} is one of the characters @samp{-} or @samp{+}, @var{data} is the representation of the number, and @var{prefix} is zero or more of the following prefix strings: @table @code @item #b @itemx #B Integers are described in binary, @item #o @itemx #O Integers are in octal, @item #d @itemx #D Integers are in decimal (the default), @item #x @itemx #X Integers are in hexadecimal, @item #e @itemx #E Coerce the number to an exact representation after parsing it, @item #i @itemx #I Coerce to an inexact representation. @end table @noindent The representation of an integer is simply the digits representing that integer, in the radix chosen by any given prefix (defaults to decimal). Examples of valid integer read syntaxes for the number 42 could be @samp{42}, @samp{#x2a}, @samp{#o52}, @samp{#o+52}, @dots{} The representation of a rational number is two sequences of digits, separated by a @samp{/} character. For example, @samp{3/2} represents the rational number three divided by two. It is supported without gmp too, but the read value is converted to float. Inexact numbers are parsed from one of two representations: decimal point form, which is simply a decimal number containing a decimal point, and exponential form, which is a decimal number followed by the letter @samp{e} and a decimal exponent multiplying the first part of the number by that power of ten. For example, @samp{10.0}, @samp{10.} and @samp{1e1} all read as the inexact number ten. Note that the radix prefixes currently have no effect when parsing inexact numbers, decimal is used exclusively. An integer's printed representation is simply the number printed in decimal with a preceding minus sign if it is negative. Rational numbers are printed as two integers separated by a @samp{/} character. Inexact numbers are printed in their decimal form. @node Arithmetic Functions, Integer Functions, Number Read Syntax, Numbers @subsection Arithmetic Functions @cindex Arithmetic Functions @cindex Numbers, arithmetic functions There are a number of functions which perform arithmetic operations on numbers, they take a varying number of values as their arguments returning a new number as their result. When given only exact arguments, an exact result will be returned. @defun + number1 @t{#!rest} numbers This functions adds its arguments then returns their sum. @end defun @defun - number1 @t{#!rest} numbers If this function is just given one argument (@var{number1}) that number is negated and returned. Otherwise each of @var{numbers} is subtracted from a running total starting with the value of @var{number1}. @lisp (- 20) @result{} -20 (- 20 10 5) @result{} 5 @end lisp @end defun @defun * number1 @t{#!rest} numbers This function multiplies its arguments then returns the result. @end defun @defun / number1 @t{#!rest} numbers This function performs division, a running-total (initialised from @var{number1} is successively divided by each of @var{numbers} then the result is returned. @lisp (/ 100 2) @result{} 50 (/ 200 2 5) @result{} 20 (/ 3 2) @result{} 3/2 (/ 3.0 2) @result{} 1.5 @end lisp @end defun @defun 1+ number This function returns the result of adding one to @var{number}. @lisp (1+ 42) @result{} 43 @end lisp @end defun @defun 1- number Returns @var{number} minus one. @end defun @node Integer Functions, Rational Functions, Arithmetic Functions, Numbers @subsection Integer Functions @cindex Integer functions @cindex Numbers, integer functions The functions described in this section all operate on, and return, integer values. @defun quotient dividend divisor Return the integer part of dividing @var{dividend} by @var{divisor}. @end defun @defun remainder dividend divisor Returns the integer remainder from dividing the @var{dividend} by @var{divisor}. The remainder is either zero or has the same sign as @var{dividend}. @end defun @defun modulo dividend divisor @defunx mod dividend divisor Return the value of @var{dividend} modulo @var{divisor}. Unlike the @code{remainder} function the @code{modulo} function always has the sign of the @var{divisor}, not of the @var{dividend} @end defun @defun gcd args@dots{} Returns the greatest common divisor of the integers @var{args}@dots{} If no arguments are given, returns zero. @end defun @defun lcm args@dots{} Return the lowest common multiple of the integers @var{args}@dots{} If no arguments are given, returns one. @end defun @node Rational Functions, Real Number Functions, Integer Functions, Numbers @subsection Rational Functions @cindex Rational functions @cindex Numbers, rational functions These functions operate on rational numbers. @defun numerator x Returns the exact numerator of @var{x}. @end defun @defun denominator x Returns the exact denominator of @var{x}. @end defun @defun exact->inexact x Returns an inexact version of rational number @var{x}. @end defun @node Real Number Functions, Mathematical Functions, Rational Functions, Numbers @subsection Real Number Functions @cindex Real number functions @cindex Numbers, real number functions @defun inexact->exact x Returns an exact representation of @var{x}. This may involve a loss of accuracy. @end defun @defun abs x Returns the magnitude of @var{x}. @end defun @defun floor x Round @var{x} downwards to the nearest integer less than or equal to @var{x}. @end defun Four rounding functions are provided. With gmp, they return integer. Without gmp, they return float type, just like libc counterparts, to avoid overflow. You can convert it to integer with @code{inexact->exact}. @defun ceiling x Round @var{x} upwards to the nearest integer less than or equal to @var{x}. @end defun @defun truncate x Round @var{x} to the nearest integer between @var{x} and zero. @end defun @defun round x Round @var{x} to the nearest integer. Halfway cases are rounded to the nearest even integer. @end defun @node Mathematical Functions, Bitwise Functions, Real Number Functions, Numbers @subsection Mathematical Functions @cindex Mathematical functions @cindex Numbers, mathematical functions Functions below returns float type number. @defun exp x Return `e' (the base of natural logarithms) raised to the power @var{x}. @end defun @defun log x Return the natural logarithm of @var{x}. An arithmetic error is signalled if @var{x} is less than zero. @end defun @defun sin x Return the sine of angle @var{x}; x is in terms of radians. @end defun @defun cos x Return the cosine of angle @var{x}. @end defun @defun tan x Return the tangent of angle @var{x}. @end defun @defun asin x Return the arc sine of @var{x} (the value whose sine is @var{x}), in radians. @end defun @defun acos x Return the arc cosine of @var{x}. @end defun @defun atan x Return the arc tangent of @var{x}. @end defun @defun sqrt x Return the non-negative square root of @var{x}. Currently, if @var{x} is negative, an arithmetic error is signalled. @end defun @defun expt x y Returns @var{x} raised to the power @var{y}. If @var{x} is negative and @var{y} is a non-integer, then an arithmetic error is signalled (mathematically should return a complex number). @end defun @node Bitwise Functions, Random Numbers, Mathematical Functions, Numbers @subsection Bitwise Functions @cindex Bitwise functions @cindex Numbers, bitwise functions These functions operate on the bit string which an integer represents, assuming a two's complement representation. @defun lsh number count This function shifts the integer @var{number} @var{count} bits to the left, if @var{count} is negative @var{number} is shifted to the right instead. @lisp (lsh 1 8) @result{} 256 (lsh 256 -8) @result{} 1 @end lisp @end defun @defun logand number1 @t{#!rest} numbers This function uses a bit-wise logical `and' operation to combine all its arguments (there must be at least one argument). @lisp (logand 15 8) @result{} 8 (logand 15 7 20) @result{} 4 @end lisp @end defun @defun logior number1 @t{#!rest} numbers Uses a bit-wise logical `inclusive-or' to combine all its arguments (there must always be at least one argument). @lisp (logior 1 2 4) @result{} 7 @end lisp @end defun @defun logxor number1 @t{#!rest} numbers Uses a bitwise logical `exclusive-or' to combine all its arguments (there must be at least one). @lisp (logxor 7 3) @result{} 4 @end lisp @end defun @defun lognot number This function inverts all the bits in @var{number}. @lisp (lognot 0) @result{} -1 (lognot 2) @result{} -3 (lognot -1) @result{} 0 @end lisp @end defun @node Random Numbers, Characters, Bitwise Functions, Numbers @subsection Pseudo-Random Numbers @cindex Pseudo-random numbers @cindex Random numbers @cindex Numbers, pseudo random The @code{random} function allows pseudo-random numbers to be generated. @defun random @t{#!optional} limit Return a pseudo-random number between zero and @var{limit}-1 inclusive. If @var{limit} is undefined, it is taken as being the largest positive integer representable in a fixnum. Calling @code{random} with @var{limit} equal to the symbol @code{t} seeds the generator with the current time of day. @end defun @node Characters, , Random Numbers, Numbers @subsection Characters @cindex Characters In @code{librep} characters are stored in integers. Their read syntax is a question mark followed by the character itself, which may be an escape sequence introduced by a backslash. For details of the available escape sequences see @ref{Strings}. @lisp ?a @result{} 97 ?\n @result{} 10 ?\177 @result{} 127 @end lisp Functions below makes sence for ascii characters only. @defun alpha-char-p character This function returns true when @var{character} is one of the alphabetic characters. @lisp (alpha-char-p ?a) @result{} t @end lisp @end defun @defun upper-case-p character When @var{character} is one of the upper-case characters this function returns true. @end defun @defun lower-case-p character Returns true when @var{character} is lower-case. @end defun @defun digit-char-p character This function returns true when @var{character} is one of the decimal digit characters. @end defun @defun alphanumericp character This function returns true when @var{character} is either an alphabetic character or a decimal digit character. @end defun @defun space-char-p character Returns true when @var{character} is a white-space character (space, tab, newline or form feed). @end defun @defun char-upcase character This function returns the upper-case equivalent of @var{character}. If @var{character} is already upper-case or has no upper-case equivalent it is returned unchanged. @lisp (char-upcase ?a) @result{} 65 ;`A' (char-upcase ?A) @result{} 65 ;`A' (char-upcase ?!) @result{} 33 ;`!' @end lisp @end defun @defun char-downcase character Returns the lower-case equivalent of the character @var{character}. @end defun @node Sequences, Symbols, Numbers, The language @section Sequences @cindex Sequences @cindex Arrays Sequences are ordered groups of objects, there are several primitive types which can be considered sequences, each with their pros and cons. A sequence is either an array or a list, where an array is either a vector or a string. @defun sequencep object This function returns true if @var{object} is a sequence. @end defun @menu * Cons Cells:: An ordered pair of two objects * Lists:: Chains of cons cells * Vectors:: A chunk of memory holding a number of objects * Strings:: Strings are efficiently-stored vectors * Array Functions:: Accessing elements in vectors and strings * Sequence Functions:: These work on any type of sequence @end menu @node Cons Cells, Lists, , Sequences @subsection Cons Cells @cindex Cons cells @cindex Sequences, cons cells A @dfn{cons cell} is an ordered pair of two objects, the @dfn{car} and the @dfn{cdr}. The read syntax of a cons cell is an opening parenthesis followed by the read syntax of the car, a dot, the read syntax of the cdr and a closing parenthesis. For example a cons cell with a car of 10 and a cdr of the string @samp{foo} would be written as, @lisp (10 . "foo") @end lisp @defun cons car cdr This function creates a new cons cell. It will have a car of @var{car} and a cdr of @var{cdr}. @lisp (cons 10 "foo") @result{} (10 . "foo") @end lisp @end defun @defun consp object This function returns true if @var{object} is a cons cell. @lisp (consp '(1 . 2)) @result{} t (consp '()) @result{} () (consp (cons 1 2)) @result{} t @end lisp @end defun The strange syntax @samp{'(1 . 2)} is known as @dfn{quoting} (@pxref{Quoting}), it tells the evaluator that the object following the quote-mark is a constant, and therefore should not be evaluated. This will be explained in more detail later. @cindex Atom In Lisp an @dfn{atom} is any object which is not a cons cell (and is, therefore, atomic). @defun atom object Returns true if @var{object} is an atom (not a cons cell). @end defun Given a cons cell there are a number of operations which can be performed on it. @defun car cons-cell This function returns the object which is the car (first element) of the cons cell @var{cons-cell}. @lisp (car (cons 1 2)) @result{} 1 (car '(1 . 2)) @result{} 1 @end lisp @end defun @defun cdr cons-cell This function returns the cdr (second element) of the cons cell @var{cons-cell}. @lisp (cdr (cons 1 2)) @result{} 2 (cdr '(1 . 2)) @result{} 2 @end lisp @end defun @defun rplaca cons-cell new-car This function sets the value of the car (first element) in the cons cell @var{cons-cell} to @var{new-car}. The value returned is @var{cons-cell}. @lisp (setq x (cons 1 2)) @result{} (1 . 2) (rplaca x 3) @result{} (3 . 2) x @result{} (3 . 2) @end lisp @end defun @defun rplacd cons-cell new-cdr This function is similar to @code{rplacd} except that the cdr slot (second element) of @var{cons-cell} is modified. @end defun @node Lists, Vectors, Cons Cells, Sequences @subsection Lists @cindex Lists A list is a sequence of zero or more objects, the main difference between lists and vectors is that lists are more dynamic: they can change size, be split, reversed, concatenated, etc@dots{} very easily. In Lisp lists are not a primitive type; instead singly-linked lists are formed by chaining cons cells together (@pxref{Cons Cells}). The empty list is represented by the special value @code{()}. @defun listp arg This functions returns true when its argument, @var{arg}, is a list (i.e. either a cons cell or @code{()}). @end defun @defun null arg Returns a true value if @var{arg} is the empty list. @end defun @menu * List Structure:: How lists are built from cons cells * Building Lists:: Dynamically creating lists * Accessing List Elements:: Getting at the elements which make the list * Modifying Lists:: How to alter the contents of a list * Association Lists:: Lists can represent relations * Infinite Lists:: Circular data structures in Lisp @end menu @node List Structure, Building Lists, , Lists @subsubsection List Structure @cindex List structure Each element in a list is given its own cons cell and stored in the car of that cell. The list is then constructed by having the cdr of a cell point to the cons cell containing the next element (and hence the entire rest of the list). The cdr of the cell containing the last element in the list is @code{()}. A list of zero elements is represented by @code{()}. The read syntax of a list is an opening parenthesis, followed by the read syntax of zero or more space-separated objects, followed by a closing parenthesis. Alternatively, lists can be constructed `manually' using dotted-pair notation. All of the following examples result in the same list of five elements: the numbers from zero to four. @lisp (0 1 2 3 4) (0 . (1 . (2 . (3 . (4 . ()))))) (0 1 2 . (3 4)) @end lisp An easy way to visualise lists and how they are constructed is to see each cons cell in the list as a separate @dfn{box} with pointers to its car and cdr, @example +-----+-----+ | o | o----> cdr +--|--+-----+ | --> car @end example Complex box-diagrams can now be drawn to represent lists. For example the following diagram represents the list @code{(1 2 3 4)}. @example +-----+-----+ +-----+-----+ +-----+-----+ +-----+-----+ | o | o----> | o | o----> | o | o----> | o | o----> () +--|--+-----+ +--|--+-----+ +--|--+-----+ +--|--+-----+ | | | | --> 1 --> 2 --> 3 --> 4 @end example A more complex example, the list @code{((1 2) (foo bar))} can be drawn as, @example +-----+-----+ +-----+-----+ | o | o---------------------------> | o | o----> () +--|--+-----+ +--|--+-----+ | | +-----+-----+ +-----+-----+ +-----+-----+ +-----+-----+ | o | o----> | o | o----> () | o | o----> | o | o----> () +--|--+-----+ +--|--+-----+ +--|--+-----+ +--|--+-----+ | | | | --> 1 --> 2 --> foo --> bar @end example @node Building Lists, Accessing List Elements, List Structure, Lists @subsubsection Building Lists @cindex Building lists @cindex Lists, building It has already been described how you can create lists using the Lisp reader; this method does have a drawback though: the list created is effectively static. If you modify the contents of the list and that list was created when a function was defined the list will remain modified for all future invocations of that function. This is not usually a good idea, consider the following function definition, @lisp (defun bogus-function (x) "Return a list whose first element is nil and whose second element is X." (let ((result '(nil nil))) ;Static list which is filled in each time (rplaca (cdr result) x) ; the function is called result)) @end lisp @noindent This function does in fact do what its documentation claims, but a problem arises when it is called more than once, @lisp (setq x (bogus-function 'foo)) @result{} (nil foo) (setq y (bogus-function 'bar)) @result{} (nil bar) ;The first result has been destroyed x @result{} (nil bar) ;See! @end lisp This example is totally contrived---no one would ever write a function like the one in the example but it does demonstrate the need for a dynamic method of creating lists. @defun list @t{#!rest} elements This function creates a list out of its arguments, if zero arguments are given the empty list, @code{()}, is returned. @lisp (list 1 2 3) @result{} (1 2 3) (list (major-version-number) (minor-version-number)) @result{} (3 2) (list) @result{} () @end lisp @end defun @defun list* arg1 arg2 @dots{} argn-1 argn Creates a new list @code{(@var{arg1} @var{arg2} @dots{} @var{argn-1} . @var{argn})}. @lisp (list* 1 2 '(3 4)) @result{} (1 2 3 4) @end lisp @end defun @defun make-list length @t{#!optional} initial-value This function creates a list @var{length} elements long. If the @var{initial-value} argument is given it defines the value of all elements in the list, if it is not defined they are all @code{()}. @lisp (make-list 2) @result{} (() ()) (make-list 3 t) @result{} (t t t) (make-list 0) @result{} () @end lisp @end defun @defun append @t{#!rest} lists This function creates a new list with the elements of each of its arguments (which must be lists). Unlike the function @code{nconc} this function preserves the structure of all its arguments. @lisp (append '(1 2 3) '(4 5)) @result{} (1 2 3 4 5) (append) @result{} () @end lisp What actually happens is that all arguments but the last are copied, then the last argument is linked on to the end of the list (uncopied). @lisp (setq foo '(1 2)) @result{} (1 2) (setq bar '(3 4)) @result{} (3 4) (setq baz (append foo bar)) @result{} (1 2 3 4) (eq (nthcdr 2 baz) bar) @result{} t @end lisp The following diagram shows the final state of the three variables more clearly, @example foo--> +-----+-----+ +-----+-----+ | o | o----> | o | | +--|--+-----+ +--|--+-----+ | | o--> 1 o--> 2 bar | | -> baz--> +--|--+-----+ +--|--+-----+ +-----+-----+ +-----+-----+ | o | o----> | o | o----> | o | o----> | o | | +-----+-----+ +-----+-----+ +--|--+-----+ +--|--+-----+ | | --> 3 --> 4 @end example Note how @code{foo} and the first half of @code{baz} use the @emph{same} objects for their elements---copying a list only copies its cons cells, its elements are reused. Also note how the variable @code{bar} actually references the mid-point of @code{baz} since the last list in an @code{append} call is not copied. @end defun @defun remove elt list Return a copy of @var{list}, with all elements the same as @var{elt} discarded (using the @code{equal} function to compare). @end defun @defun remq elt list Similar to the @code{remove} function, except that comparisons are made using @code{eq}. @end defun @defun reverse list This function returns a new list; it is made from the elements of the list @var{list} in reverse order. Note that this function does not alter its argument. @lisp (reverse '(1 2 3 4)) @result{} (4 3 2 1) @end lisp @end defun As a postscript to this section, the function used as an example at the beginning could now be written as, @lisp (defun not-so-bogus-function (x) (list nil x)) @end lisp Also note that the @code{cons} function can be used to create lists by hand and to add new elements onto the front of a list. For example: @lisp (setq x (list 1 2 3)) @result{} (1 2 3) (setq x (cons 0 x)) @result{} (0 1 2 3) @end lisp @node Accessing List Elements, Modifying Lists, Building Lists, Lists @subsubsection Accessing List Elements @cindex Accessing list elements @cindex Lists, accessing elements The most flexible method of accessing an element in a list is via a combination of the @code{car} and @code{cdr} functions. There are other functions which provide an easier way to get at the elements in a flat list. These will usually be faster than a string of @code{car} and @code{cdr} operations. @defun nth count list This function returns the element @var{count} elements down the list, therefore to access the first element use a @var{count} of zero (or even better the @code{car} function). If there are too few elements in the list and no element number @var{count} can be found @code{()} is returned. @lisp (nth 3 '(0 1 2 3 4 5)) @result{} 3 (nth 0 '(foo bar) @result{} foo @end lisp @end defun @defun nthcdr count list This function takes the cdr of the list @var{list} @var{count} times, returning the last cdr taken. @lisp (nthcdr 3 '(0 1 2 3 4 5)) @result{} (3 4 5) (nthcdr 0 '(foo bar)) @result{} (foo bar) @end lisp @end defun @defun last list This function returns the last element in the list @var{list}. If the list has zero elements @code{()} is returned. @lisp (last '(1 2 3)) @result{} 3 (last '()) @result{} () @end lisp @end defun @defun member object list This function scans through the list @var{list} until it finds an element which is @code{equal} to @var{object}. The tail of the list (the cons cell whose car is the matched object) is then returned. If no elements match @var{object} then the empty list @code{()} is returned. @lisp (member 'c '(a b c d e)) @result{} (c d e) (member 20 '(1 2)) @result{} () @end lisp @end defun @defun memq object list This function is similar to @code{member} except that comparisons are performed by the @code{eq} function not @code{equal}. @end defun @node Modifying Lists, Association Lists, Accessing List Elements, Lists @subsubsection Modifying Lists @cindex Modifying lists @cindex Lists, modifying The @code{nthcdr} function can be used in conjunction with the @code{rplaca} function to modify an arbitrary element in a list. For example, @lisp (rplaca (nthcdr 2 '(0 1 2 3 4 5)) 'foo) @result{} foo @end lisp @noindent sets the third element of the list @code{(0 1 2 3 4 5)} to the symbol called @code{foo}. There are also functions which modify the structure of a whole list. These are called @dfn{destructive} operations because they modify the actual structure of a list---no copy is made. This can lead to unpleasant side effects if care is not taken. @defun nconc @t{#!rest} lists This function is the destructive equivalent of the function @code{append}, it modifies its arguments so that it can return a list which is the concatenation of the elements in its arguments lists. Like all the destructive functions this means that the lists given as arguments are modified (specifically, the cdr of their last cons cell is made to point to the next list). This can be seen with the following example (similar to the example in the @code{append} documentation). @lisp (setq foo '(1 2)) @result{} (1 2) (setq bar '(3 4)) @result{} (3 4) (setq baz (nconc foo bar)) @result{} (1 2 3 4) foo @result{} (1 2 3 4) ;`foo' has been altered! (eq (nthcdr 2 baz) bar) @result{} t @end lisp The following diagram shows the final state of the three variables more clearly, @example foo--> bar--> baz--> +-----+-----+ +-----+-----+ +-----+-----+ +-----+-----+ | o | o----> | o | o----> | o | o----> | o | | +--|--+-----+ +--|--+-----+ +--|--+-----+ +--|--+-----+ | | | | --> 1 --> 2 --> 3 --> 4 @end example @end defun @defun nreverse list This function rearranges the cons cells constituting the list @var{list} so that the elements are in the reverse order to what they were. @lisp (setq foo '(1 2 3)) @result{} (1 2 3) (nreverse foo) @result{} (3 2 1) foo @result{} (1) ;`foo' wasn't updated when the list ; was altered. @end lisp @end defun @defun delete object list This function destructively removes all elements of the list @var{list} which are @code{equal} to @var{object} then returns the modified list. @lisp (delete 1 '(0 1 0 1 0)) @result{} (0 0 0) @end lisp When this function is used to remove an element from a list which is stored in a variable that variable must be set to the return value of the @code{delete} function. Otherwise, if the first element of the list has to be deleted (because it is @code{equal} to @var{object}) the value of the variable will not change. @lisp (setq foo '(1 2 3)) @result{} (1 2 3) (delete 1 foo) @result{} (2 3) foo @result{} (1 2 3) (setq foo (delete 1 foo)) @result{} (2 3) @end lisp @end defun @defun delq object list This function is similar to the @code{delete} function, the only difference is that the @code{eq} function is used to compare @var{object} with each of the elements in @var{list}, instead of the @code{equal} function which is used by @code{delete}. @end defun @defun sort list @t{#!optional} predicate Destructively sorts (i.e. by modifying cdrs) the list of values @var{list}, to satisfy the function @var{predicate}, returning the sorted list. If @var{predicate} is undefined, the @code{<} function is used, sorting the list into ascending order. @var{predicate} is called with two values, it should return true if the first is considered less than the second. @lisp (sort '(5 3 7 4)) @result{} (3 4 5 7) @end lisp The sort is stable, in that elements in the list which are equal will preserve their original positions in relation to each other. @end defun @node Association Lists, Infinite Lists, Modifying Lists, Lists @subsubsection Association Lists @cindex Association lists @cindex Alists @cindex Lists, association An @dfn{association list} (or @dfn{alist}) is a list mapping keys to to. Each element of the alist is a cons cell, the car of which is the @dfn{key}, the cdr the value that it associates to. For example an alist could look like, @lisp ((fred . 20) (bill . 30)) @end lisp @noindent this alist has two keys, @code{fred} and @code{bill} which both associate to an integer (20 and 30 respectively). It is possible to make the associated values lists, this looks like, @lisp ((fred 20 male) (bill 30 male) (sue 25 female)) @end lisp @noindent in this alist the symbol @code{fred} is associated with the list @code{(20 male)}. There are a number of functions which let you interrogate an alist with a given key for its association. @defun assoc key alist This function scans the association list @var{alist} for the first element whose car is @code{equal} to @var{key}, this element is then returned. If no match of @var{key} is found false is returned. @lisp (assoc 'two '((one . 1) (two . 2) (three . 3))) @result{} (two . 2) @end lisp @end defun @defun assq key alist Similar to the function @code{assoc} except that the function @code{eq} is used to compare elements instead of @code{equal}. It is not usually wise to use @code{assq} when the keys of the alist may not be symbols---@code{eq} won't think two objects are equivalent unless they are the @emph{same} object! @lisp (assq "foo" '(("bar" . 1) ("foo" . 2))) @result{} () (assoc "foo" '(("bar" . 1) ("foo" . 2))) @result{} ("foo" . 2) @end lisp @end defun @defun rassoc association alist This function searches through @var{alist} until it finds an element whose cdr is @code{equal} to @var{association}, that element is then returned. false will be returned if no elements match. @lisp (rassoc 2 '((one . 1) (two . 2) (three . 3))) @result{} (two . 2) @end lisp @end defun @defun rassq association alist This function is equivalent to @code{rassoc} except that it uses @code{eq} to make comparisons. @end defun @node Infinite Lists, , Association Lists, Lists @subsubsection Infinite Lists @cindex Infinite lists @cindex Circular lists @cindex Lists, circular Sometimes it is useful to be able to create `infinite' lists---that is, lists which appear to have no last element---this can easily be done in Lisp by linking the cdr of the last cons cell in the list structure back to the beginning of the list. @example ----------------------------------- | | --> +-----+-----+ +-----+-----+ | | o | o----> | o | o----- +--|--+-----+ +--|--+-----+ | | --> 1 --> 2 @end example The diagram above represents the infinite list @code{(1 2 1 2 1 2 @dots{})}. Infinite lists have a major drawback though, many of the standard list manipulation functions can not be used on them. These functions work by moving through the list until they reach the end. If the list has @emph{no} end the function may never terminate and the only option is to send the interpreter an interrupt signal. The only functions which may be used on circular lists are: the cons cell primitives (@code{cons}, @code{car}, @code{cdr}, @code{rplaca}, @code{rplacd}), @code{nth} and @code{nthcdr}. Also note that infinite lists can't be printed. But note the @code{print-length} and @code{print-level} variables, see @ref{Output Functions}. @node Vectors, Strings, Lists, Sequences @subsection Vectors A vector is a fixed-size sequence of Lisp objects, each element may be accessed in constant time---unlike lists where the time taken to access an element is proportional to the position of the element. The read syntax of a vector is an opening square bracket, followed by zero or more space-separated objects, followed by a closing square bracket. For example, @lisp [zero one two three] @end lisp In general it is best to use vectors when the number of elements to be stored is known and lists when the sequence may grow or shrink. @defun vectorp object This function returns true if its argument, @var{object}, is a vector. @end defun @defun vector @t{#!rest} elements This function creates a new vector containing the arguments given to the function. @lisp (vector 1 2 3) @result{} [1 2 3] (vector) @result{} [] @end lisp @end defun @defun make-vector size @t{#!optional} initial-value Returns a new vector, @var{size} elements big. If @var{initial-value} is defined each element of the new vector is set to @var{initial-value}, otherwise they are all @code{()}. @lisp (make-vector 4) @result{} [() () () ()] (make-vector 2 t) @result{} [t t] @end lisp @end defun @node Strings, Array Functions, Vectors, Sequences @subsection Strings A string is a vector of characters (@pxref{Characters}). It is generally used for storing and manipulating pieces of text. @code{librep} puts no restrictions on the values which may be stored in a string---specifically, the null character (@samp{^@@}) may be stored with no problems. In librep, a string is a sequcene of raw bytes, and no encoding is assumed. Some special functions for utf-8 encoded strings are provided. See @xref{utf-8}. The read syntax of a string is a double quote character, followed by the contents of the string, the object is terminated by a second double quote character. For example, @code{"abc"} is the read syntax of the string @samp{abc}. @cindex Escape sequences in strings @cindex Strings, escape sequences Any backslash characters in the string's read syntax introduce an escape sequence; one or more of the following characters are treated specially to produce the next @emph{actual} character in the string. The following escape sequences are supported (all are shown without their leading backslash @samp{\} character). @table @samp @item n A newline character. @item r A carriage return character. @item f A form feed character. @item t A TAB character. @item a A `bell' character (this is Ctrl-g). @item \ A backslash character. @item ^@var{c} The `control' code of the character @var{c}. This is calculated by toggling the seventh bit of the @emph{upper-case} version of @var{c}. For example, @lisp \^C ;A Ctrl-c character (ASCII value 3) \^@@ ;The NUL character (ASCII value 0) @end lisp @item 012 The character whose ASCII value is the octal value @samp{012}. After the backslash character the Lisp reader reads up to three octal digits and combines them into one character. @item x12 The character whose ASCII value is the hexadecimal value @samp{12}, i.e. an @samp{x} character followed by one or two hex digits. @end table @defun stringp object This function returns true if its argument is a string. @end defun @defun make-string length @t{#!optional} initial-character Creates a new string containing @var{length} characters, each character is initialised to @var{initial-character} (or to spaces if @var{initial-character} is not defined). @lisp (make-string 3) @result{} " " (make-string 2 ?$) @result{} "$$" @end lisp @end defun @defun concat @t{#!rest} args This function concatenates all of its arguments, @var{args}, into a single string which is returned. If no arguments are given then the null string (@samp{}) results. Each of the @var{args} may be a string, a character or a list or vector of characters. Characters are stored in strings modulo 256. @lisp (concat "foo" "bar") @result{} "foobar" (concat "a" ?b) @result{} "ab" (concat "foo" [?b ?a ?r]) @result{} "foobar" (concat) @result{} "" @end lisp @end defun @defun substring string start @t{#!optional} end This function creates a new string which is a partial copy of the string @var{string}. The first character copied is @var{start} characters from the beginning of the string. If the @var{end} argument is defined it is the index of the character to stop copying at, if it is not defined all characters until the end of the string are copied. @lisp (substring "xxyfoozwx" 3 6) @result{} "foo" (substring "xyzfoobar" 3) @result{} "foobar" @end lisp For utf-8 encoded strings, use @code{utf8-substring} instead (@pxref{utf-8}). @end defun @defun string= string1 string2 This function compares the two strings @var{string1} and @var{string2}---if they are made from the same characters in the same order then true is returned. @lisp (string= "one" "one") @result{} t (string= "one" "two") @result{} () @end lisp Note that an alternate way to compare strings (or anything!) is to use the @code{equal} function. @end defun @defun string-equal string1 string2 Returns true if @var{string1} and @var{string2} are the same, ignoring differences in character case. @end defun @defun string< string1 string2 This function returns true if @var{string1} is `less' than @code{string2}. This is determined by comparing the two strings a character at a time, the first pair of characters which do not match each other are then compared with a normal `less-than' function. In @code{librep} the standard @code{<} function understands strings so @code{string<} is just a macro calling that function. @lisp (string< "abc" "abd") @result{} t (string< "abc" "abb") @result{} () @end lisp @end defun @defun string-lessp string1 string2 Similar to @code{string<} but ignores character case in comparisons. @end defun See @ref{String Functions} for a few more string manipulating functions, and @ref{Regular Expressions} for a method of pattern matching in strings. @node Array Functions, Sequence Functions, Strings, Sequences @subsection Array Functions @cindex Array functions @defun arrayp object This function returns true if @var{object} is an array. @end defun @defun aref array position Returns the element of the array (vector or string) @var{array} @var{position} elements from the first element (i.e. the first element is numbered zero). If no element exists at @var{position} in @var{array}, false is returned. @lisp (aref [0 1 2 3] 2) @result{} 2 (aref "abcdef" 3) @result{} 100 ;`d' @end lisp @end defun @defun aset array position value This function sets the element of the array @var{array} with an index of @var{position} (counting from zero) to @var{value}. An error is signalled if element @var{position} does not exist. The result of the function is @var{value}. @lisp (setq x [0 1 2 3]) @result{} [0 1 2 3] (aset x 2 'foo) @result{} foo x @result{} [0 1 foo 3] @end lisp @end defun @node Sequence Functions, , Array Functions, Sequences @subsection Sequence Functions @cindex Sequence functions @defun sequencep arg Returns true if @var{arg} is a sequence, i.e. a list or an array. @end defun @defun length sequence This function returns the length (an integer) of the sequence @var{sequence}. @lisp (length "abc") @result{} 3 (length '(1 2 3 4)) @result{} 4 (length [x y]) @result{} 2 @end lisp For utf-8 encoded strings, use @code{utf8-string-length} (@pxref{utf-8}). @end defun @defun copy-sequence sequence Returns a new copy of the sequence @var{sequence}. Where possible (in lists and vectors) only the `structure' of the sequence is newly allocated: the same objects are used for the elements in both sequences. @lisp (copy-sequence "xy") @result{} "xy" (setq x '("one" "two")) @result{} ("one" "two") (setq y (copy-sequence x)) @result{} ("one" "two") (eq x y) @result{} () (eq (car x) (car y)) @result{} t @end lisp @end defun @defun elt sequence position This function returns the element of @var{sequence} @var{position} elements from the beginning of the sequence. This function is a combination of the @code{nth} and @code{aref} functions. @lisp (elt [0 1 2 3] 1) @result{} 1 (elt '(foo bar) 0) @result{} foo @end lisp @end defun @node Symbols, Evaluation, Sequences, The language @section Symbols @cindex Symbols Symbols are objects with a name (almost always a unique name). They are one of the most important data types in Lisp since they are used to provided named variables (@pxref{Variables}) and functions (@pxref{Functions}). @defun symbolp arg This function returns true when its argument is a symbol. @end defun @menu * Symbol Syntax:: The read syntax of symbols * Symbol Attributes:: The objects stored in a symbol * Obarrays:: Vectors used to store symbols * Creating Symbols:: Allocating new symbols * Interning:: Putting a symbol into an obarray * Property Lists:: Each symbol has a set of properties * Keyword Symbols:: Self-evaluating keywords @end menu @node Symbol Syntax, Symbol Attributes, , Symbols @subsection Symbol Syntax @cindex Symbol syntax The read syntax of a symbol is usually its name; however, if the name contains any meta-characters (whitespace or any from @samp{()[]'";|\}) they will have to be entered specially. There are two ways to tell the reader that a meta-character is actually part of the symbol's name: @enumerate @item Precede the meta-character by a backslash character (@samp{\}), for example: @lisp xy\(z\) ;the symbol whose name is @samp{xy(z)} @end lisp @item Enclose part of the name in vertical bars (two @samp{|} characters). All characters after the starting vertical line are copied as-is until the closing vertical line is encountered. For example: @lisp xy|(z)| ;the symbol @samp{xy(z)} @end lisp @end enumerate Here are some example read syntaxes. @lisp setq ; @samp{setq} |setq| ; @samp{setq} \s\e\t\q ; @samp{setq} 1 ; the @emph{number} 1 \1 ; the @emph{symbol} @samp{1} |!$%zf78&| ; @samp{!$%zf78&} foo|(bar)| ; @samp{foo(bar)} foo\(bar\) ; @samp{foo(bar)} @end lisp @node Symbol Attributes, Obarrays, Symbol Syntax, Symbols @subsection Symbol Attributes @cindex Symbol attributes All symbols have two basic attributes: print name and property list. Most important is the @dfn{print name} of the symbol. This is a string naming the symbol, after it has been defined (when the symbol is first created) it may not be changed. @defun symbol-name symbol This function returns the print name of the symbol @var{symbol}. @lisp (symbol-name 'unwind-protect) @result{} "unwind-protect" @end lisp @end defun The symbol's @dfn{property list} (or plist) is similar to an alist (@pxref{Association Lists}), though stored differently, and provides a method of storing arbitrary extra values in each symbol. @xref{Property Lists}. Although not strictly an attribute of the symbol, symbols also provide a means of associating values with names (i.e. variables). Within a defined context, a symbol may have a @dfn{binding}, this binding associates the symbol with a memory location within which a value may be stored. When writing Lisp programs, the value of a symbol's current binding is accessed by writing the print name of the symbol. Similarly the binding may be modified by using the @code{setq} special form. @xref{Variables}. @node Obarrays, Creating Symbols, Symbol Attributes, Symbols @subsection Obarrays @cindex Obarrays @cindex Symbols, obarrays An @dfn{obarray} is the structure used to ensure that no two symbols have the same name and to provide quick access to a symbol given its name. An obarray is a vector, each element of the vector is a chain of symbols whose names share the same hash-code (a @dfn{bucket}). These symbols are chained together through links which are invisible to Lisp programs: if you examine an obarray you will see that each bucket looks as though it has at most one symbol stored in it. The normal way to reference a symbol is simply to type its name in the program, when the Lisp reader encounters a name of a symbol it looks in the default obarray for a symbol of that name. If the named symbol doesn't exist it is created and hashed into the obarray---this process is known as @dfn{interning} the symbol, for more details see @ref{Interning}. @defvar obarray This variable contains the obarray that the @code{read} function uses when interning symbols. @end defvar @defun make-obarray size This function creates a new obarray with @var{size} hash buckets (this should probably be a prime number for the fewest hash collisions). This is the only way of creating an obarray. @code{make-vector} is @emph{not suitable}. @end defun @defun find-symbol symbol-name @t{#!optional} obarray This function scans the specified obarray (@var{obarray} or the value of the variable @code{obarray} if @var{obarray} is undefined) for a symbol whose name is the string @var{symbol-name}. The value returned is the symbol if it can be found or false otherwise. @lisp (find-symbol "setq") @result{} setq @end lisp @end defun @defun apropos regexp @t{#!optional} predicate obarray Returns a list of symbols from the obarray @var{obarray} (or the default) whose print name matches the regular expression @var{regexp} (@pxref{Regular Expressions}). If @var{predicate} is true, each symbol which matches @var{regexp} is applied to the function @var{predicate}, if the value is true it is considered a match. The @var{predicate} argument is useful for restricting matches to a certain type of symbol, for example only commands. @lisp (apropos "^yank" 'commandp) @result{} (yank-rectangle yank yank-to-mouse) @end lisp @end defun @node Creating Symbols, Interning, Obarrays, Symbols @subsection Creating Symbols @cindex Creating symbols @cindex Symbols, creating It is possible to allocate symbols dynamically, this is normally only necessary when the symbol is to be interned in a non-default obarray or the symbol is a temporary object which should not be interned (for example: labels in a compiler). @defun make-symbol print-name This function creates and returns a new, uninterned, symbol whose print name is the string @var{print-name}. Its value cell is void (undefined) and it will have an empty property list. @lisp (make-symbol "foo") @result{} foo @end lisp @end defun @defun gensym This function returns a new, uninterned, symbol that has a unique print name. @lisp (gensym) @result{} G0001 (gensym) @result{} G0002 @end lisp @end defun @node Interning, Property Lists, Creating Symbols, Symbols @subsection Interning @cindex Interning @cindex Symbols, interning @dfn{Interning} a symbol means to store it in an obarray so that it can be found in the future: all variables and named-functions are found through interned symbols. When a symbol is interned a hash function is applied to its print name to determine which bucket in the obarray it should be stored in. Then it is simply pushed onto the front of that bucket's chain of symbols. Normally all interning is done automatically by the Lisp reader. When it encounters the name of a symbol which it can't find in the default obarray (the value of the variable @code{obarray}) it creates a new symbol of that name and interns it. This means that no two symbols can have the same print name, and that the read syntax of a particular symbol always produces the same object (unless the value of @code{obarray} is altered). @lisp (eq 'some-symbol 'some-symbol) @result{} t @end lisp @defun intern symbol-name @t{#!optional} obarray This function uses @code{find-symbol} to search the @var{obarray} (or the standard obarray) for a symbol called @var{symbol-name}. If a symbol of that name is found it is returned, otherwise a new symbol of that name is created, interned into the obarray, and returned. @lisp (intern "setq") @result{} setq (intern "my-symbol" my-obarray) @result{} my-symbol @end lisp @end defun @defun intern-symbol symbol @t{#!optional} obarray Interns the symbol @var{symbol} into the obarray @var{obarray} (or the standard one) then returns the symbol. If @var{symbol} is currently interned in an obarray an error is signalled. @lisp (intern-symbol (make-symbol "foo")) @result{} foo (intern-symbol 'foo) @error{} Error: Symbol is already interned, foo @end lisp @end defun @defun unintern symbol @t{#!optional} obarray This function removes the symbol @var{symbol} from the obarray @var{obarray} then returns the symbol. Beware! this function should be used with @emph{extreme} caution---once you unintern a symbol there may be no way to recover it. @lisp (unintern 'setq) ;This is extremely stupid @result{} setq @end lisp @end defun @node Property Lists, Keyword Symbols, Interning, Symbols @subsection Property Lists @cindex Property lists @cindex Symbols, property lists Each symbol has a property list (or @dfn{plist}), this is a structure which associates an arbitrary Lisp object with a key (usually a symbol). The keys in a plist may not have any duplications (so that each property is only defined once). The concept of a property list is very similar to an association list (@pxref{Association Lists}) but there are two main differences: @enumerate @item Structure; each element of an alist represents one key/association pair. In a plist each pair of elements represents an association: the first is the key, the second the property. For example, where an alist may be, @lisp ((one . 1) (two . 2) (three . 3)) @end lisp @noindent a property list would be, @lisp (one 1 two 2 three 3) @end lisp @item Plists have their own set of functions to modify the list. This is done destructively, altering the property list (since the plist is stored in only one location, the symbol, this is quite safe). @end enumerate @defun get symbol property This function searches the property list of the symbol @var{symbol} for a property @code{equal} to @var{property}. If such a property is found it is returned, otherwise false is returned. @lisp (get 'if 'lisp-indent) @result{} 2 (get 'set 'lisp-indent) @result{} () @end lisp @end defun @defun put symbol property new-value @code{put} sets the value of the property @var{property} to @var{new-value} in the property list of the symbol @var{symbol}. If there is an existing value for this property (using @code{equal} to compare keys) it is overwritten. The value returned is @var{new-value}. @lisp (put 'foo 'prop 200) @result{} 200 @end lisp @end defun @defun symbol-plist symbol Returns the property list of the symbol @var{symbol}. @lisp (symbol-plist 'if) @result{} (lisp-indent 2) @end lisp @end defun @defun setplist symbol plist This function sets the property list of the symbol @var{symbol} to @var{plist}. @lisp (setplist 'foo '(zombie yes)) @result{} (zombie yes) @end lisp @end defun @node Keyword Symbols, , Property Lists, Symbols @subsection Keyword Symbols @cindex Keyword symbols @cindex Symbols, keywords Keywords are a special class of symbols. They evaluate to themselves, and have the read syntax @samp{#:@var{symbol}}, where @var{symbol} is anything satisfying the usual symbol syntax. These objects are normally used to mark keyword parameters in function applications (@pxref{Lambda Expressions}). @defun make-keyword symbol Return the keyword symbol that could be used to mark an argument value for the keyword parameter @var{symbol}. @lisp (make-keyword 'x) @result{} #:x @end lisp @end defun @defun keywordp arg Returns true if @var{arg} is a keyword symbol. @end defun @node Evaluation, Variables, Symbols, The language @section Evaluation @cindex Evaluation @cindex Evaluating Lisp forms @cindex Lisp forms, evaluating So far only the primitive data types have been discussed, and how the Lisp reader converts textual descriptions of these types into Lisp objects. Obviously there has to be a way of actually computing something---it would be difficult to write a useful program otherwise. What sets Lisp apart from other languages is that in Lisp there is no difference between programs and data: a Lisp program is just a sequence of Lisp objects which will be evaluated as a program when required. The subsystem which does this evaluation is called the @dfn{Lisp evaluator} and each expression to be evaluated is called a @dfn{form}. The evaluator (the function @code{eval}) examines the structure of the form that is applied to it and computes the value of that form within the current Lisp environment. A form can be any type of data object; the only types which the evaluator treats specially are symbols (which describe variables) and lists (subroutine applications), anything else is returned as-is (and is called a @dfn{self-evaluating form}). @defun eval form This function computes and returns the value of @var{form} within the current module and dynamic environment, and a null lexical environment. @end defun However, @code{eval} is rarely explicitly invoked, except in the read-eval-print loop. Lisp provides many other methods of evaluation that are usually much more suitable within a program. @defvar max-lisp-depth This variable limits the number of nested calls to @code{eval}. If more than this many nested calls to @code{eval} exist, an error is signalled. The intention is to detect infinite recursion before hitting the stack size limit (causing a segmentation fault). @end defvar @menu * Symbol Forms:: How variables are accessed * List Forms:: Subroutine calls * Self-Evaluating Forms:: Forms which don't get evaluated * Quoting:: How to prevent evaluation of forms @end menu @node Symbol Forms, List Forms, , Evaluation @subsection Symbol Forms @cindex Symbol forms @cindex Forms, symbol @cindex Forms, variable When the evaluator is applied to a symbol the computed value of the form is the value associated with the symbol in the current environment. Basically this means that to get the value of a variable you simply write its name. For example, @lisp rep-version @result{} "1.0" @end lisp @noindent this extract from a Lisp session shows the read syntax of a form to get the value of the variable @code{rep-version} and the result when this form is evaluated. Since forms are evaluated within the current environment the value of a variable is its most-recent extant binding (with slight differences for lexical and special variables). @xref{Variables}. If an evaluated symbol has no current binding, an error is signalled. @node List Forms, Self-Evaluating Forms, Symbol Forms, Evaluation @subsection List Forms @cindex List forms Forms which are lists are used to invoke a subroutine. The first element of the list defines the subroutine to be called; all further elements are arguments to be applied to that subroutine invocation. There are several different types of subroutines available: functions, macros, special forms and autoloads. When the evaluator finds a form which is a list it tries to classify the form into one of these four types. First of all it evaluates the first element of the list; the computed value of this element decides how the rest of the elements in the list are treated. For example, if the first element is a symbol whose value is a function, then that function is called with the other values in the list. @menu * Function Call Forms:: `Normal' subroutines * Macro Call Forms:: Source code expansions * Special Forms:: Abnormal control structures * Autoload Forms:: Loading subroutines from files on the fly @end menu @node Function Call Forms, Macro Call Forms, , List Forms @subsubsection Function Call Forms @cindex Function call forms @cindex Forms, function call When the first element of a list form evaluates to a function object (either a primitive subroutine or a closure), all other elements in the list are evaluated sequentially from left-to-right, then these values are applied to the function definition. The result returned by the function is then taken as the value of the whole list form. For example, consider the form @code{(/ 100 (1+ 4))}. This is a function call to the function stored in the variable @code{/}. First the @code{/} form is evaluated, it is a variable containing a data value representing the primitive subroutine for integer division. Then the @code{100} form is evaluated: it is a number, so self-evaluates to the value @code{100}. Next the form @code{(1+ 4)} is evaluated. This is also a function call and computes to a value of @code{5} which becomes the second argument to the @code{/} function. Now the @code{/} function is applied to its evaluated arguments of @code{100} and @code{5}, and returns the value @code{20}. This then becomes the value of the form @code{(/ 100 (1+ 4))}. @lisp (/ 100 (1+ 4)) @equiv{} (/ 100 5) @result{} 20 @end lisp Or another example, @lisp (+ (- 10 (1- 7)) (* (1+ 2) 4) @equiv{} (+ (- 10 6) (* (1+ 2) 4) @equiv{} (+ 4 (* (1+ 2) 4) @equiv{} (+ 4 (* 3 4)) @equiv{} (+ 4 12) @result{} 16 @end lisp The system is also capable of eliminating tail calls where possible, allowing tail-recursive function definitions to run with bounded space requirements. A @dfn{tail-call} is a function call that occurs immediately before exiting the containing function. Since the containing function need not receive the result of the function call, it is possible to, in effect, exit from the containing function before invoking the called function. Note however, that this is only possible where none of the dynamic features of the language (i.e. bindings to special variables, @code{unwind-protect}, @code{condition-case}, @code{catch}, etc@dots{}) are currently active in the containing function. Consider, for example, the following function: @lisp (defun print-list (l) (unless (null l) (format standard-output "%s\n" (car l)) (print-list (cdr l)))) @end lisp @noindent the call to @code{print-list} occurs in the @dfn{tail-position} of the function. This means that the call may be made after removing the previous call to @code{print-list} from the interpreter's stack of active functions. [ XXX currently the interpreter is incapable of eliminating tail calls to subrs, i.e. Lisp functions implemented in C ] @node Macro Call Forms, Special Forms, Function Call Forms, List Forms @subsubsection Macro Call Forms @cindex Macro call forms @cindex Forms, macro call Macros are source code expansions, the general idea is that a macro is a function which using the unevaluated arguments applied to it, computes another form (the expansion of the macro and its arguments) which is then evaluated to provide the value of the form. Macros are generally used to implement control-flow operations, where not all arguments may be evaluated, or evaluated in an unusual order. For more details see @ref{Macros}. @node Special Forms, Autoload Forms, Macro Call Forms, List Forms @subsubsection Special Forms @cindex Special forms @cindex Forms, special Special forms are built-in subroutines which the evaluator knows must be handled specially. The main difference between a special form and a function is that the arguments applied to a special form are @emph{not} automatically evaluated---if necessary the special form will evaluate arguments itself. This will be noted in the documentation of the special form. Special forms are generally used to provide control structures, for example, the primitive conditional constructs are special forms (if all of their arguments, including the forms to be conditionally evaluated, were evaluated automatically this would defeat the object of being conditional!). The special forms supported by @code{librep} are: @code{cond}, @code{defvar}, @code{progn}, @code{quote}, @code{setq}. @defun special-form-p arg Returns true if @var{arg} is a special form. @lisp (special-form-p quote) @result{} t @end lisp @end defun @node Autoload Forms, , Special Forms, List Forms @subsubsection Autoload Forms @cindex Autoload forms @cindex Forms, autoload Not all parts of @code{librep} are needed at once, autoload forms provide a means of marking that a function (or macro) is contained by a specific Lisp library. The first time that the function is accessed the autoload form will be evaluated; this loads the file containing the function, then re-evaluates the original form. By then the autoload form will have been overwritten in the symbol's function slot by the true function (when it was loaded) so the form will execute properly. For more details see @ref{Autoloading}. @node Self-Evaluating Forms, Quoting, List Forms, Evaluation @subsection Self-Evaluating Forms @cindex Self-evaluating forms @cindex Forms, self-evaluating @cindex Forms, constant The computed value of any form which is not a symbol or a list will simply be the form itself and the form is said to be a @dfn{self-evaluating form}. Usually the only forms to be evaluated in this way will be numbers, strings and vectors (since they are the only other data types which have read syntaxes) but the effect is the same for other types of data. This means that forms you know are self-evaluating do not have to be quoted to be used as constants (like lists and symbols do). @lisp "foo" @result{} "foo" @end lisp @node Quoting, , Self-Evaluating Forms, Evaluation @subsection Quoting @cindex Quoting As the above sections explain some types of Lisp object have special meaning to the Lisp evaluator (namely the symbol and list types) this means that if you want to refer to a symbol or a list in a program you can't because the evaluator will treat the form as either a variable reference or a function call respectively. To get around this Lisp uses an idea called @dfn{quoting}. The special form @code{quote} simply returns its argument without evaluating it. For example, @lisp (quote my-symbol) @result{} my-symbol @end lisp @noindent the @code{quote} form prevents the @code{my-symbol} being treated as a variable---it is effectively `hidden' from the evaluator. Writing @samp{quote} all the time would be a bit time-consuming so there is a shortcut: the Lisp reader treats any form @var{x} preceded by a single quote character (@samp{'}) as the form @code{(quote @var{x})}. So the example above would normally be written as, @lisp 'my-symbol @result{} my-symbol @end lisp The general way to prevent evaluation of a form is to simply precede it by a single quote-mark. @defspec quote form This special form returns its single argument without evaluating it. This is used to @dfn{quote} constant objects to prevent them from being evaluated. @end defspec For another form of quoting, see @ref{Backquoting}. @node Variables, Functions, Evaluation, The language @section Variables @cindex Variables In Lisp, symbols are used to represent variables. Each symbol contains a @dfn{value} slot that is used to contain the value of the symbol when it used as a variable. The normal way to obtain the current value of a variable is simply to evaluate the symbol of the same name (i.e. write the name of the variable in your program). The @code{symbol-value} function can be used to evaluate variables whose names not known statically. @defun symbol-value variable This function returns the value of the symbol @var{variable} in the current environment. @end defun @menu * Local Variables:: Creating temporary variables * Setting Variables:: Altering a variable's value * Scope and Extent:: Technical jargon * Void Variables:: Some variables have no values * Defining Variables:: How to define a variable before using it * Fluid Variables:: Another dynamic bindingd methodb @end menu @node Local Variables, Setting Variables, , Variables @subsection Local Variables @cindex Local variables @cindex Variables, local A @dfn{local variable} is a variable which has a temporary value. For example, when a function is called the variables which are the names of its arguments are temporarily bound to the values of the arguments passed to the function. When the function call exits its arguments are unbound and the previous definitions of the variables come back into view. A @dfn{binding} is a particular instance of a local variable. Even if a variable has more than one binding currently in place, only the most recent is available---there is no way the previous binding can be accessed until the previous binding is removed. One way of visualising variable binding is to think of each variable as a stack. When the variable is bound to, a new value is pushed onto the stack, when it is unbound the top of the stack is popped. Similarly when the stack is empty the value of the variable is void (@pxref{Void Variables}). Assigning a value to the variable (@pxref{Setting Variables}) overwrites the top value on the stack with a new value. When the value of the variable is required it is simply read from the top of the stack. Apart from function applications there are two special forms which perform variable binding (i.e. creating local variables), @code{let} and @code{let*}. @defmac let bindings body-forms@dots{} @code{let} creates new variable bindings as specified by the @var{bindings} argument, then evaluates the @var{body-forms} in order. The bindings are then removed, returning all variables to their state before the @code{let} statement was entered. The value of the statement is the value of the implicit @code{progn}. The @var{bindings} argument is a list of the bindings to perform. Each binding is either a symbol, in which case that variable is bound to @code{()}, or a list whose car is a symbol. The cdr of this list is a list of forms which, when evaluated as a @code{progn}, gives the value to bind to that variable. @lisp (setq foo 42) @result{} 42 (let ((foo (+ 1 2)) bar) ;; Body forms (setq foo (1+ foo)) ;This sets the new binding (cons foo bar)) @result{} (4 . ()) foo @result{} 42 ;The original values is back @end lisp No bindings are made until all new values have been computed. For example: @lisp (setq foo 42) @result{} 42 (let ((foo 100) (bar foo)) (cons foo bar)) @result{} (100 . 42) @end lisp @noindent Although @code{foo} is given a new binding this is not actually done until all the new values have been computed, hence @code{bar} is bound to the @emph{old} value of @code{foo}. @end defmac @defmac let* bindings body-forms@dots{} This special form is exactly the same as @code{let} except for one important difference: the new bindings are installed @emph{as they are computed}. You can see the difference by comparing the following example with the last example in the @code{let} documentation (above), @lisp (setq foo 42) @result{} 42 (let* ;Using @code{let*} this time ((foo 100) (bar foo)) (cons foo bar)) @result{} (100 . 100) @end lisp @noindent By the time the new value of @code{bar} is computed the new binding of @code{foo} is already active. @end defmac @defmac letrec bindings body-forms@dots{} @code{letrec} is similar to @code{let} and @code{let*}, with the differerence being that the values of bindings are evaluated with all other bindings in scope. This means that recursive functions may be defined with @code{letrec}. For example, a local factorial function (from SICP): @lisp (letrec ((fact (lambda (n) (if (= n 1) 1 (* n (fact (1- n))))))) (fact 10)) @end lisp @noindent Note also that letrec allows groups of mutually recursive functions to be defined, as in the following example (also from SICP): @lisp (defun f (x) (letrec ((evenp (lambda (n) (if (= n 0) t (oddp (1- n))))) (oddp (lambda (n) (if (= n 0) nil (evenp (1- n)))))) @dots{} @end lisp @end defmac @node Setting Variables, Scope and Extent, Local Variables, Variables @subsection Setting Variables @cindex Setting variables @cindex Variables, setting @dfn{Setting} a variable means to overwrite its current value (that is, the value of its most recent active binding) with a new one. In the variable-as-stack analogy, this is analogous to overwriting the top of the stack. The old value is irretrievably lost (unlike when a new value is bound to a variable, @pxref{Local Variables}). The @code{setq} special form is the usual method of altering the value of a variable. @defspec setq variable form @dots{} Each @var{variable} is set to the result of evaluating its corresponding @var{form}. The last value assigned becomes the value of the @code{setq} form. @lisp (setq x 20 y (+ 2 3)) @result{} 5 @end lisp @noindent In the above example the variable @code{x} is set to @code{20} and @code{y} is set to the value of the form @code{(+ 2 3)} (5). @end defspec @defun set variable new-value The value of the variable @var{variable} (a symbol) is set to @var{new-value} and the @var{new-value} is returned. This function is used when the @var{variable} is unknown until run-time, and therefore has to be computed from a form. @lisp (set 'foo 20) @equiv{} (setq foo 20) ;@code{setq} means `set-quoted' @result{} 20 @end lisp @emph{Note:} currently the @code{set} function may be used to set any type of variable (i.e. lexical or special). However this likely to change in the future, such that only special variables will be allowed to be modified using the @code{set} function. It is strongly advised to avoid using this function on lexical bindings! (Moreover the compiler may generate incorrect code in certain circumstances.) @end defun @node Scope and Extent, Void Variables, Setting Variables, Variables @subsection Scope and Extent @cindex Scope and extent @cindex Variables, scope and extent of In the @code{librep} dialect of Lisp by default variables have @dfn{lexical scope}. This means that bindings are associated with textual regions of programs, and may be accessed by any forms within this associated textual region. Moreover, the bindings are persistent, even when the flow of control is currently outside the associated region. Consider the following example: @lisp (let ((counter 0)) (defun count () (setq counter (1+ counter)) counter)) @end lisp @noindent the value of the @code{counter} variable persists, and is incremented each time the @code{count} function is called. The @code{counter} variable is accessible from nowhere but the forms written inside the @code{let} statement declaring it. @lisp (count) @result{} 1 (count) @result{} 2 @end lisp An alternative method of scoping variables is also available. Any variables declared using the @code{defvar} special form are said to be @dfn{special} variables, they have @dfn{indefinite scope} and @dfn{dynamic extent}, often simplified to @dfn{dynamic scope}. What this means is that references to these variables may occur anywhere in a program (i.e. bindings established in one function are visible within functions called from the original function) and that references may occur at any point in time between the binding being created and it being unbound. Dynamic scoping is easy to abuse, making programs hard to understand and debug. A quick example of the use of dynamic scope, @lisp (defvar *foo-var* nil) (defun foo (x) (let ;; a dynamically-scoped binding ((*foo-var* (* x 20))) (bar x) @dots{} (defun bar (y) ;; Since this function is called from ;; the function @code{foo} it can refer ;; to @code{*foo-var*} (setq y (+ y *foo-var*)) @dots{} @end lisp @noindent As shown in the previous example, a common convention is to mark special variables by enclosing their names within asterisks. @node Void Variables, Defining Variables, Scope and Extent, Variables @subsection Void Variables @cindex Void variables @cindex Variables, void A variable which has no value is said to be @dfn{void}, attempting to reference the value of such a symbol will result in an error. It is possible for the most recent binding of a variable to be void even though the inactive bindings may have values. @defun boundp variable Returns true if the symbol @var{variable} has a value. @end defun @defun makunbound variable This function makes the current binding of the symbol @var{variable} be void, then returns @var{variable}. @lisp (setq foo 42) @result{} 42 foo @result{} 42 (boundp 'foo) @result{} t (makunbound 'foo) @result{} foo (boundp 'foo) @result{} () foo @error{} Value as variable is void: foo @end lisp @end defun @node Defining Variables, Fluid Variables, Void Variables, Variables @subsection Defining Variables @cindex Defining variables @cindex Variables, defining The special forms @code{define}, @code{defvar} and @code{defconst} allow you to define the global variables that will be used by a program. @defmac define variable form Defines a lexically scoped global variable called @var{variable}. It will have the result of evaluating @var{form} assigned to it. Note that the @code{define} special form may also be used to declare block-structured functions, @ref{Definitions}. @end defmac @defspec defvar variable [form [doc-string]] This special form defines a special (i.e. dynamically scoped) variable, the symbol @var{variable}. If the value of @var{variable} is void the @var{form} is evaluated and its value is stored as the value of @var{variable} (note that only the default value is modified, never a buffer-local value). If no @var{form} is given the assigned value defaults to false. If the @var{doc-string} argument is defined it is a string documenting @var{variable}. This string is then stored as the symbol's @code{variable-documentation} property and can be accessed by the @code{describe-variable} function. @lisp (defvar *my-variable* '(x y) "This variable is an example showing the usage of the @code{defvar} special form.") @result{} *my-variable* @end lisp @end defspec @defmac defconst constant form [doc-string] @code{defconst} defines a global constant, the symbol @var{constant}. Its value is set to the result of evaluating @var{form}. Note that unlike @code{defvar} the value of the symbol is @emph{always} set, even if it already has a value. The @var{doc-string} argument, if defined, is the documentation string for the constant. @lisp (defconst the-answer 42 "An example constant.") @result{} the-answer @end lisp @end defmac @node Fluid Variables, , Defining Variables, Variables @subsection Fluid Variables @cindex Fluid variables @cindex Variables, fluid Special variables have a number of drawbacks, especially when used in conjunction with the module system (@pxref{Modules and Special Variables}). As a consequence of these drawbacks, @code{rep} provides a second method of implementing dynamically scoped variables, known as @dfn{fluid variables}, or just @dfn{fluids}. A fluid is a first class Lisp object that may be passed around like any other Lisp object. Its sole function is to provide a location from which dynamic bindings may be created. Fluids are anonymous objects, they are usually named by being stored in lexically scoped variables. @defun make-fluid @t{#!optional} value Create and return a new fluid, it will have an initial binding of @var{value} (or false if @var{value} is undefined). @end defun @defun fluid fluid Return the value of the most recently created binding of the fluid variable object @var{fluid}. @end defun @defun fluid-set fluid value Set the value of the most recently created binding of the fluid variable object @var{fluid} to @var{value}. @end defun @defun with-fluids fluids values thunk Call the zero parameter function @var{thunk} (and return the value that it returns) with new bindings created for each of the fluid variables specified in the list @var{fluids}. For each member of @var{fluids} the corresponding member of the @var{values} list provides the initial value of the new binding. If the lists @var{fluids} and @var{values} are not of the same length, an error is signalled. @end defun @defmac let-fluids bindings body @dots{} A convenient wrapper around @code{with-fluids}, similar to the @code{let} syntax. The list @var{bindings} associates the names of lexical variables containing fluid objects, with the values to bind to those fluid objects. Once the bindings have been installed, the @var{body @dots{}} forms are evaluated, and the bindings removed. The value of the last of the @var{body @dots{}} forms is returned. @end defmac Here is an example code fragment using fluid variables and @code{let-fluids}: @lisp (define a (make-fluid)) (define b (make-fluid)) (let-fluids ((a 1) (b 2)) (+ (fluid a) (fluid b))) @result{} 3 @end lisp @node Functions, Macros, Variables, The language @section Functions @cindex Functions A @dfn{function} is a Lisp object which, when applied to a sequence of argument values, produces another value---the function's @dfn{result}. It may also induce side-effects (e.g. changing the environment of the calling function). All Lisp functions return results --- there is nothing like a procedure in Pascal. Note that special forms (@pxref{Special Forms}) and macros (@pxref{Macros}) are @emph{not} functions since they do not guarantee to evaluate all of their arguments. Functions are the main building-block in Lisp programs, each program is usually a system of interrelated functions. There are two types of function: @dfn{primitive functions} are functions written in the C language, these are sometimes called built-in functions, the object containing the C code itself is called a @dfn{subr}. All other functions are defined in Lisp. @defun functionp object Returns true if @var{object} is a function (i.e. it can be used as the function argument of @code{funcall}. @lisp (functionp set) @result{} t (functionp setq) @result{} () (functionp (lambda (x) (+ x 2))) @result{} t @end lisp @end defun @defun subrp arg Returns true is @var{arg} is a primitive subroutine object. @end defun @defun subr-name subr Returns a string naming the primitive subroutine @var{subr}. @end defun @menu * Lambda Expressions:: Structure of a function object * Defining Functions:: How to write a function definition * Anonymous Functions:: Or they can be un-named * Predicate Functions:: Functions which return boolean values * Local Functions:: Binding functions temporarily * Calling Functions:: Functions can be called by hand * Mapping Functions:: Map a function to the elements of a list @end menu @node Lambda Expressions, Defining Functions, , Functions @subsection Lambda Expressions @cindex Lambda expressions @cindex Functions, lambda expressions @dfn{Lambda expressions} are used to create functions from other Lisp objects. A lambda expression is a list whose first element is the symbol @code{lambda}. All functions written in Lisp (as opposed to the primitive functions in C) are defined using lambda expressions. The general format of a lambda expression is: @lisp (lambda @var{lambda-list} [@var{doc}] [@var{interactive-declaration}] @var{body-forms}@dots{} ) @end lisp @noindent Where @var{lambda-list} is a list defining the formal parameters of the function, @var{doc} is an optional documentation string, @var{interactive-declaration} is only required by interactive commands @footnote{Only used when @code{librep} is embedded within another application.} and @var{body-forms} is the sequence of forms making up the function body, evaluated using an implicit @code{progn}. The @var{lambda-list} is a list, it defines how the values applied to the function are bound to local variables which represent the parameters of the function. At its simplest it is simply a list of symbols, each symbol will have the corresponding argument value bound to it. For example, the lambda list @code{(x y)} defines two parameters, @code{x} and @code{y}. When called with two arguments the first will be bound to the variable @code{x}, the second to @code{y}. When used in a full lambda expression this looks like: @lisp (lambda (x y) (+ x y)) @end lisp @noindent this evaluates to an anonymous function with two parameters, @code{x} and @code{y}, which when called evaluates to their sum. Note that a lambda expression itself is @emph{not} a function, it must be associated with a lexical environment, this conjunction is usually called a closure; it is the closure that may be called as a function. However, to confuse matters, a lambda expression @emph{evaluates} to the closure of itself and the current environment. Consider the following example: @lisp (lambda (x) (1+ x)) @result{} # (functionp (lambda (x) (1+ x))) @result{} t (functionp '(lambda (x) (1+ x))) @result{} () @end lisp There are several @dfn{lambda-list keywords} which modify the meaning of symbols in the lambda-list. The syntax of the lambda list is: @lisp ([@var{required-parameters}@dots{}] [#!optional @var{optional-parameters}@dots{}] [#!key @var{keyword-parameters}@dots{}] [#!rest @var{rest-parameter} | . @var{rest-parameter}]) @end lisp @noindent Each lambda list keyword is a symbol whose name begins @samp{#!}, they are interpreted as follows: @table @code @item #!optional All variables following this keyword are considered @dfn{optional} (all variables before the first keyword are @dfn{required}: an error will be signalled if a required argument is undefined in a function call). @var{optional-parameters} may either be of the form @code{@var{symbol}} or of the form @code{(@var{symbol} @var{default})}. If no argument is supplied for this parameter the @var{default} form is evaluated to give the bound value@footnote{The @var{default} form is evaluated in the environment of the closure being called, but without any of the bindings created by the lambda expression.}. If no @var{default} form is given, then the variable is bound to a false value. Note that optional parameters must be specified if a later parameter is also specified. @lisp ((lambda (#!optional a b) (list a b))) @result{} (() ()) ((lambda (#!optional a b) (list a b)) 1) @result{} (1 ()) ((lambda (#!optional a b) (list a b)) nil 1) @result{} (() 1) ((lambda (#!optional (a 1)) (list a))) @result{} (1) ((lambda (#!optional (a 1)) (list a)) 2) @result{} (2) @end lisp @item #!key This object marks that the parameters up to the next lambda list keyword are keyword parameters. The values bound to these parameters when the function is called are determined not by position (as with normal parameters), but by being marked by a preceding keyword symbol. Keyword symbols have the syntax @samp{#:@var{symbol}}. As with optional parameters, default values may be supplied through the use of the @code{(@var{symbol} @var{default})} syntax. If no default value is given and no keyword argument of the specified kind is available, the variable is bound to a false value. For example, the lambda list @code{(a #!key b c)} accepts one required argument, and two optional keyword arguments. The variable @code{a} would be bound to the first supplied argument; the variable @code{b} would be bound to the argument preceded by the keyword @code{#:b}, or @code{()} if no such argument exists. (After extracting required and optional arguments, each remaining pair of values is checked for associating a value with each keyword.) @lisp ((lambda (a #!key b c) (list a b c)) 1 2 3) @result{} (1 () ()) ((lambda (a #!key b c) (list a b c)) 1 #:b 2 3) @result{} (1 2 ()) ((lambda (a #!key b c) (list a b c)) 1 #:b 2 #:c 3) @result{} (1 2 3) ((lambda (a #!key b c) (list a b c)) 1 #:c 3 #:b 2) @result{} (1 2 3) @end lisp @item #!rest The @code{#!rest} keyword allows a variable number of arguments to be applied to a function, all the argument values which have not been bound to argument variables (or used to mark keyword arguments) are made into a list and bound to the variable following the @code{#!rest} keyword. For example, in @lisp (lambda (x #!rest y) @dots{}) @end lisp @noindent the first argument, @code{x}, is required. Any other arguments applied to this function are made into a list and this list is bound to the variable @code{y}. Variable argument functions may also be defined through the Scheme method of using an improper lambda-list. The previous example is exactly equivalent to: @lisp (lambda (x . y) @dots{}) @end lisp @end table When a function represented by a lambda-list is called the first action is to bind the argument values to the formal parameters. The @var{lambda-list} and the list of argument values applied to the function are worked through in parallel. Any required arguments which are left undefined when the end of the argument values has been reached causes an error. After the arguments have been processed the @var{body-forms} are evaluated by an implicit progn, the value of which becomes the value of the function call. Finally, all parameters are unbound and control passes back to the caller. @node Defining Functions, Anonymous Functions, Lambda Expressions, Functions @subsection Defining Functions @cindex Defining functions @cindex Functions, defining Globally accessible functions are usually defined by the @code{defun} special form. @defmac defun name lambda-list body-forms@dots{} @code{defun} initialises the function definition of the symbol @var{name} to the lambda expression resulting from the concatenation of the symbol @code{lambda}, @var{lambda-list} and the @var{body-forms}. The @var{body-forms} may contain a documentation string for the function as its first form and an interactive calling specification as its first (if there is no doc-string) or second form if the function may be called interactively by the user (@pxref{Lambda Expressions}). @end defmac An example function definition taken from the @code{librep} source code is: @lisp (defun load-all (file) "Try to load files called FILE (or FILE.jl, etc) from all directories in the Lisp load path." (mapc (lambda (dir) (let ((full-name (expand-file-name file dir))) (when (or (file-exists-p full-name) (file-exists-p (concat full-name ".jl")) (file-exists-p (concat full-name ".jlc"))) (load full-name nil t)))) load-path)) @end lisp @node Anonymous Functions, Predicate Functions, Defining Functions, Functions @subsection Anonymous Functions @cindex Anonymous functions @cindex Functions, anonymous When supplying functions as arguments to other functions it is often useful to give an actual function @emph{definition} (i.e. an enclosed lambda expression) instead of the name of a function. In Lisp, unlike most other programming languages, functions have no inherent name. As seen in the last section named-functions are created by storing a function object in a variable, if you want, a function can have many different names: simply store the function in many different variables! So, when you want to pass a function as an argument there is the option of just writing down its definition. This is especially useful with functions like @code{mapc} and @code{delete-if}. For example, the following form removes all elements from the @var{list} which are even and greater than 20. @lisp (setq @var{list} (delete-if (lambda (x) (and (zerop (% x 2)) (> x 20))) @var{list})) @end lisp The above lambda expression combines two predicates applied to its argument. In certain cases it may be necessary to create a non-constant function, for example by using backquoting (@pxref{Backquoting}). In these cases the @code{make-closure} function may be used to create a function object from a lambda expression. @defun make-closure arg Return the closure of @var{arg} and the current lexical environment. @end defun @defun closurep arg Returns true if @var{arg} is a closure. @end defun @defun closure-function closure Returns the function object associated with the lexical closure @var{closure}. @end defun @node Predicate Functions, Local Functions, Anonymous Functions, Functions @subsection Predicate Functions @cindex Predicate functions @cindex Boolean values, predicate functions In Lisp, a function which returns a boolean `true' or boolean `false' value is called a @dfn{predicate}. As is the convention in Lisp a value of @code{()} means false, anything else means true. The symbols @code{nil} and @code{t} are often used to represent constant false and true values (@pxref{nil and t}). Another Lisp convention is that the names of predicate functions should name the quality that the predicate is testing followed by either a @samp{p} or @samp{-p} string. The @samp{p} variant is used when the first string does not contain any hyphens. For example, the predicate to test for the quality @dfn{const-variable} (a variable which has a constant value, @pxref{Defining Variables}) is called @code{const-variable-p}. On the other hand the predicate to test for the quality @dfn{cons} (a Cons cell) is called @code{consp}. @node Local Functions, Calling Functions, Predicate Functions, Functions @subsection Local Functions @cindex Local functions @cindex Functions, local The @code{defun} special form allows globally-accessible functions to be defined. It is often desirable to declare functions local to the current lexical environment. The @code{let} and @code{let*} special form that were introduced earlier allow this since named functions are simply functional values stored in variables. For example, @lisp (let ((temporary-function (lambda (x) (+ x 42)))) @dots{} (temporary-function 20) @dots{} @end lisp @node Calling Functions, Mapping Functions, Local Functions, Functions @subsection Calling Functions @cindex Calling functions @cindex Functions, calling Most of the time function applications are made by the evaluator when it finds a functional value after evaluating the first element of a list form. However two functions are available for manually calling functions. @defun funcall function @t{#!rest} args Applies the argument values @var{args} to the function @var{function}, then returns its result. @end defun @defun apply function @t{#!rest} args Similar to @code{funcall} except that the last of its arguments is a @emph{list} of arguments which are appended to the other members of @var{args} to form the list of argument values to apply to the function @var{function}. @lisp (apply + 1 '(2 3)) @result{} 6 (apply + (make-list 1000000 1)) @result{} 1000000 @end lisp @end defun @node Mapping Functions, , Calling Functions, Functions @subsection Mapping Functions @cindex Mapping functions @cindex Functions, mapping @cindex Lists, mapping A @dfn{mapping function} applies a function to each of a collection of objects. @code{librep} currently has two mapping functions, @code{mapcar} and @code{mapc}. @defun mapcar function list Each element of @var{list} is individually applied to the function @var{function}. The values returned are made into a new list which is returned. The @var{function} must accept a single argument value. @lisp (mapcar 1+ '(1 2 3 4 5)) @result{} (2 3 4 5 6) @end lisp @end defun @defun mapc function list Similar to @code{mapcar} except that the values returned when each element is applied to the function @var{function} are discarded. The value returned is undefined. This function is generally used where the side effects of calling the function are the important thing, not the results. It is often the most efficient way of traversing all items in a list, for example: @lisp (mapc (lambda (x) (print x standard-error)) list) @end lisp @end defun The two following functions are also mapping functions of a sort. They are variants of the @code{delete} function (@pxref{Modifying Lists}) and use predicate functions to classify the elements of the list which are to be deleted. @defun delete-if predicate list This function is a variant of the @code{delete} function. Instead of comparing each element of @var{list} with a specified object, each element of @var{list} is applied to the predicate function @var{predicate}. If it returns true then the element is destructively removed from @var{list}. @lisp (delete-if stringp '(1 "foo" 2 "bar" 3 "baz")) @result{} (1 2 3) @end lisp @end defun @defun delete-if-not predicate list This function does the inverse of @code{delete-if}. It applies @var{predicate} to each element of @var{list}, if it returns false then the element is destructively removed from the list. @lisp (delete-if-not stringp '(1 "foo" 2 "bar" 3 "baz")) @result{} ("foo" "bar" "baz") @end lisp @end defun The @code{filter} function is similar to @code{delete-if-not}, except that the original list isn't modified, a new list is created. @defun filter predicate list Return a new list, consisting of the elements in @var{list} which the function @var{predicate} returns true when applied to. This function is equivalent to: @lisp (mapcar nconc (mapcar (lambda (x) (and (@var{predicate} x) (list x))) @var{list})) @end lisp @end defun @node Macros, Definitions, Functions, The language @section Macros @cindex Macros @dfn{Macros} are used to extend the Lisp language. They consist of a function which instead of returning a computed value, transform their unevaluated arguments into a new form that, when evaluated, produces the actual value of the original form. For example, the @code{when} macro (@pxref{Conditional Structures}) implements a new conditional operation by transforming its arguments into a @code{cond} statement. That is, @lisp (when @var{condition} @var{form} @dots{}) @expansion{} (cond (@var{condition} @var{form} @dots{})) @end lisp Since macros do not evaluate their arguments, instead just transforming them, they may be expanded at @emph{compile-time}. The resulting form is then compiled as usual. @defun macrop arg Returns true if @var{arg} is a macro object. @end defun @menu * Defining Macros:: Macros are defined like functions * Backquoting:: Creating macros from templates * Macro Expansion:: How macros are used by the evaluator * Compiling Macros:: The compiler expands macros at compile- time. @end menu @node Defining Macros, Backquoting, , Macros @subsection Defining Macros @cindex Defining macros @cindex Macros, defining Macros are defined in the same style as functions, the only difference is the name of the special form used to define them. A macro object is a list whose car is the symbol @code{macro}, its cdr is the function which creates the expansion of the macro when applied to the macro calls unevaluated arguments. @defmac defmacro name lambda-list body-forms@dots{} Defines the macro stored in the function cell of the symbol @var{name}. @var{lambda-list} is the lambda-list specifying the arguments to the macro (@pxref{Lambda Expressions}) and @var{body-forms} are the forms evaluated when the macro is expanded. The first of @var{body-forms} may be a documentation string describing the macro's use. @end defmac Here is a simple macro definition, it is the definition of the @code{when} macro shown in the previous section. @lisp (defmacro when (condition #!rest body) "Evaluates @var{condition}, if it's true evaluates the @var{body} forms." (list 'cond (list* condition body))) @end lisp @noindent When a form of the type @code{(when @var{c} @var{b} @dots{})} is evaluated the macro definition of @code{when} expands to the form @code{(cond (@var{c} (progn @var{b} @dots{})))} which is then evaluated to perform the @code{when}-construct. When you define a macro ensure that the forms which produce the expansion have no side effects; otherwise undefined effects will occur when programs using the macro are compiled. @node Backquoting, Macro Expansion, Defining Macros, Macros @subsection Backquoting @cindex Backquoting @cindex Macros, backquoting As seen in the previous sections, macros are a very powerful mechanism of defining new control structures. However due to the need to create the expansion, i.e. the form that will be actually evaluated, they can often be complex to write and understand. We have already seen that constants may be produced through the use of the quote-mark (@pxref{Quoting}), here another form of quoting is described, where only some of the quoted object is actually constant. This is known as @dfn{backquoting}, since it is introduced by the backquote character @samp{`}, a shortcut for the @code{backquote} macro. @defmac backquote arg Constructs a new version of @var{arg} (a list). All parts of @var{list} are preserved except for expressions introduced by comma (@samp{,}) characters, which are evaluated and spliced into the list. For example: @lisp `(1 2 ,(+ 1 2)) @result{} (1 2 3) @end lisp Also, the @samp{,@@} prefix will splice the following @emph{list} into the output list, at the same level: @lisp `(1 2 ,@@(list 3)) @result{} (1 2 3) @end lisp @end defmac Backquoting allows macros expansions to be created from static templates. For example the @code{when} macro shown in the previous sections can be rewritten as: @lisp (defmacro when (condition #!rest body) `(cond (,condition ,@@body))) @end lisp @noindent which is easier to read, since it is a lot closer to the actual expansion. @node Macro Expansion, Compiling Macros, Backquoting, Macros @subsection Macro Expansion @cindex Macro expansion @cindex Expansion, of macros When a macro call is detected (@pxref{List Forms}) the function which is the cdr of the macro's definition (@pxref{Defining Macros}) is applied to the macro call's arguments. Unlike in a function call, the arguments are @emph{not evaluated}, the actual forms are the arguments to the macro's expansion function. This is to allow these forms to be rearranged by the macro's expansion function, creating the form that will finally be evaluated. There is a function which performs macro expansion, its main use is to let the Lisp compiler expand macro calls at compile time. @defun macroexpand form @t{#!optional} environment If @var{form} is a macro call @code{macroexpand} will expand that call by calling the macro's expansion function (the cdr of the macro definition). If this expansion is another macro call the process is repeated until an expansion is obtained which is not a macro call, this form is then returned. The optional @var{environment} argument is a function to call to do the actual expansion. @lisp (defmacro when (condition #!rest body) "Evaluates @var{condition}, if it's true evaluates the @var{body} forms." (list 'if condition (cons 'progn body))) @result{} when (macroexpand '(when x (setq foo bar))) @result{} (cond (x (progn (setq foo bar)))) @end lisp While a macro is being expanded, the special variable @code{macro-environment} is bound to value of the @var{environment} parameter in the containing call to @code{macroexpand}. This allows macros to expand inner macros correctly. @end defun @defun macroexpand-1 form @t{#!optional} environment Similar to @code{macroexpand}, but only a single macro expansion is ever performed, i.e. if @var{form} is a macro call the result of expanding that call will be returned, otherwise @var{form} is returned. @lisp (macroexpand-1 '(when x (setq foo bar))) @result{} (if x (progn (setq foo bar))) @end lisp @end defun @node Compiling Macros, , Macro Expansion, Macros @subsection Compiling Macros @cindex Compiling macros @cindex Macros, compiling Although it may seem odd that macros return a form to produce a result and not simply the result itself, this is actually their most important feature. It allows the expansion and the evaluation of the expansion to occur at different times. The Lisp compiler makes use of this; when it comes across a macro call in a form it is compiling it uses the @code{macroexpand} function to produce the expansion of that form. This expansion is then compiled straight into the object code. Obviously this is good for performance (why evaluate the expansion every time it is needed when once will do?). Some rules do need to be observed to make this work properly: @itemize @bullet @item The macro expansion function (i.e. the definition of the macro) should not have any side effects or evaluate its arguments (the value of a symbol at compile-time probably won't be the same as its value at run-time). @item Macros which are defined by another file must be loaded so they can be recognised. Use the @code{require} function, the compiler will evaluate any @code{require} forms it sees loading any macro definitions used. @end itemize Note however, that the @code{librep} compiler does allow macros to be used before they are defined (two passes are made through the source file). @node Definitions, Modules, Macros, The language @section Block-Structured Definitions @cindex Block structured definitions @cindex Definitions, block structured @cindex Functions, block structured Previous sections of this document have described several special forms and macros for defining top-level functions and variables. @code{librep} also provides a higher-level method of creating these definitions, the @code{define} statement. @code{define} originates in the Scheme dialect of Lisp, it allows block-structured programs to be defined intuitively. The most basic use of @code{define} is very similar to @code{defun}, e.g. the two following forms have exactly the same effect: @lisp (defun foo (x) (1+ x)) (define (foo x) (1+ x)) @end lisp @noindent But note the different position of the parentheses. This is because @code{define} may also be used to define (lexical) variables. Hence the following is also equivalent: @lisp (define foo (lambda (x) (1+ x))) @end lisp However this is the most uninteresting aspect of @code{define}. More interesting is that it allows @dfn{internal definitions}. Within a @code{define} form, any inner calls to @code{define} (that occur in a contiguous block at the start of the body of a @code{let}, @code{let*}, @code{letrec}, @code{lambda}, or @code{define} form) are also used to create definitions, but definitions that are local to the containing scope. For example: @lisp (define (foo x) (define (bar) (* x 42)) (1+ (bar))) @end lisp @noindent This defines a top-level function called @code{foo}. However it also contains an inner function named @code{bar}, that is only accessible within @code{foo}. Since @code{bar} is defined inside @code{foo}, and librep uses lexical scope by default, the variable @code{x} defined by @code{foo} may also be accessed by @code{bar}. @defmac define name form @defmacx define (name . args) body-forms@dots{} Define a global lexical variable called @var{name}, whose value will be set to @var{form}. If the first argument to the macro is a list, then a function is defined whose name is @var{name} and whose formal parameters are specified by @var{args}. The body of the function is defined by the @var{body-forms}. The body forms have any macros expanded, and are scanned for internal definitions (at the start of the body of @code{let}, @code{let*}, @code{lambda} special forms) @end defmac @defmac define-macro name form @defmacx define-macro (name . args) body-forms@dots{} Similar to @code{define}, except that it creates a macro definition (@pxref{Macros}). @end defmac @defmac with-internal-definitions body-forms Recursively expand macros in @var{body-forms}, while scanning out any internal definitions into @code{letrec} statements. @end defmac @node Modules, Control Structures, Definitions, The language @section Modules @cindex Modules When creating large programs from many separate components, it is important to be able to encapsulate these components, such that the interfaces they present to other components are well defined, and the implementations of these interfaces may be modified without affecting any other components. To this end @code{rep} provides a @dfn{module system} for managing the scope of global definitions. This module system was inspired by the Scheme48, Xerox Scheme and Standard ML module systems. Modules are known as @dfn{structures} and may be anonymous or named. Each structure specifies and implements an @dfn{interface}, essentially a list of names listing the definitions within that module that may be accessed by other modules. Each structure is a separate global namespace, with a number of variable bindings. Each closure contains a reference to the structure it was instantiated in, for accessing the bindings of any free variables referenced by that closure. As well as specifying its name and interface, each module also lists the other modules whose bindings it may reference. Structures may either @dfn{open} or @dfn{access} other structures; when opening a structure all its exported bindings are immediately referenceable from the importing module. Exported bindings from accessed structures are referenced using the `structure-ref' form. @menu * Module Interfaces:: * Module Definition:: * Module Loading:: * Modules and Special Variables:: @end menu @node Module Interfaces, Module Definition, , Modules @subsection Module Interfaces @cindex Modules, interfaces Each module implements an interface---the set of bindings (i.e. functions, macros or variables) that it exports to other modules. Interfaces may either be defined and then referenced by name, written literally, or combined from a number of sources. The syntax of interface definitions is as follows: @example @var{interface} -> (export @var{id} @dots{}) | @var{name} | (compound-interface @var{interface} @dots{}) | (structure-interface @var{module-name}) @end example @noindent where each @var{id} is the name of a binding to export, and each @var{name} is the name of an interface previously defined using @code{define-interface}. @defmac define-interface name interface Associate the symbol @var{name} with the module interface @var{interface} (using one of the forms listed above. @end defmac Here is an example defining an interface called @code{foo}: @lisp (define-interface foo (compound-interface bar (export baz quux))) @end lisp @noindent It includes the interface called @code{bar} and adds two extra exported symbols: @code{baz} and @code{quux}. @node Module Definition, Module Loading, Module Interfaces, Modules @subsection Module Definition @cindex Modules, definition of Two special forms are used to define modules, one for anonymous modules, one for named modules. When storing modules in files, each file often contains a single instance of one of these forms. @defmac structure interface config body@dots{} @defmacx define-structure name interface config body@dots{} These special forms each create a new module with interface @var{interface} (using the syntax described in the previous section), and configuration @var{config}. After configuring the module as specified, the sequence of forms @var{body@dots{}} is evaluated; it should include the definitions required by the interface that the module has promised to implement. The @var{config} form is either a list of configuration clauses, or a single configuration clause. Each such clause must be of the following syntax: @example @var{clause} -> (open @var{name} @dots{}) | (access @var{name} @dots{}) @end example @noindent Each @var{name} specifies the name of a module, in the case of @code{open} clauses, the named module(s) will be loaded such that their exported bindings may be referenced from within the current module with no qualification (i.e. as if they had been defined within the module itself). Alternatively, if an @code{access} clause was used, the named module(s) will be loaded, but their exported bindings will only be accessible from within the current module using the @code{structure-ref} form. E.g. if a module @code{foo} has been accessed and it exports a binding named @code{bar}, then the following form could be used to access its value: @lisp (structure-ref foo bar) @end lisp @noindent Since this form is used so often, the reader allows the abbreviation @code{foo#bar} to be used instead, it is expanded to the form above when read. Note that no whitespace is allowed between the three tokens. @end defmac Note that to access the standard features of the @code{rep} language described in this manual, modules need to import the @code{rep} module. Alternatively, they may import the @code{scheme} module to load a minimal R4RS Scheme environment. Here is an example module definition, defining a module named @code{test} that exports two functions @code{foo} and @code{bar}. @lisp (define-structure test (export foo bar) (open rep) (define (foo x) (* x 42)) (define (bar x y) (+ (foo x) (1+ y)))) @end lisp It is also possible to export multiple views of a single underlying set of bindings, by using the @code{define-structures} form to create a number of modules. @defmac define-structures ((name interface) @dots{}) config body@dots{} Create a module for each @code{(@var{name} @var{interface})} pair. The module is called @var{name} and exports the interface defined by @var{interface}. The @var{config} and @var{body@dots{}} forms are as in @code{define-structure}. Here is a trivial example: @lisp (define-structures ((foo (export foo both)) (bar (export bar both))) (open rep) (define both 1) (define foo 2) (define bar 3)) @end lisp @noindent the underlying environment has three bindings. Each created module exports two of these. @end defmac @node Module Loading, Modules and Special Variables, Module Definition, Modules @subsection Module Loading @cindex Modules, loading As described above, the common way of loading modules is to use the @code{open} and @code{access} clauses of the configuration language. If the modules named by these clauses are not currently loaded into the interpreter, then the system will attempt to load them from the filing system, using the standard @code{load-path} variable to define the directories to search. To allow modules names to be hierarchical, any dot characters in a module's name are replaced by the operating system's directory separator string (i.e. on unix, all @samp{.} characters are simply replaced by @samp{/} characters). When searching for files to load, the standard filename suffixes are used to differentiate Lisp files from other types of files (@pxref{Load Function}). This file should contain a @code{define-structure} form (as described in the previous section) as the last top-level form in the file. For backwards compatibility, the @code{require} function can also be used to import modules. If a module of the same name as the requested feature has already been loaded, then it is imported into the current module. Otherwise if a file is loaded that contains a module definition as its last top-level form, this module is imported into the current module. @xref{Features}. @node Modules and Special Variables, , Module Loading, Modules @subsection Modules and Special Variables @cindex Modules, and special variables As described earlier, the @code{defvar} special form may be used to create variables that are scoped dynamically, known as special variables, see @ref{Defining Variables}. Due to their dynamic scope, special variables do not fit well with the lexically scoped module system described here. As a result of this mismatch, special variables are stored in a separate namespace. This means that modules defining special variables must take the necessary steps to avoid the names of these variables clashing with those declared in other modules@footnote{The usual convention is to prefix the variable name with a unique string derived from the module name.}. In fact, it is often advisable to avoid using special variables as much as possible, especially when writing modules of Lisp code. An alternative method of creating dynamically scoped variables is to use fluid variable objects. These use first class Lisp objects to represent anonymous dynamically scoped variables. Since they are just Lisp objects, they may be stored in lexically scoped variables---this gives the benefits of both lexical (i.e. encapsulation) and dynamic scoping. @xref{Fluid Variables}. @node Control Structures, Threads, Modules, The language @section Control Structures @cindex Control Structures Control structures are special forms or macros that control @emph{which} forms get evaluated, @emph{when} they get evaluated and the @emph{number} of times to evaluate them. This includes conditional structures, loops, etc@dots{} The simplest control structures are the sequencing structures; they are used to evaluate a list of forms in left to right order. @menu * Sequencing Structures:: Evaluating several forms in sequence * Conditional Structures:: Making decisions based on truth values * Looping Structures:: `while' loops * Non-Local Exits:: Exiting from several levels of evaluation * Continuations:: Capturing the call stack @end menu @node Sequencing Structures, Conditional Structures, , Control Structures @subsection Sequencing Structures @cindex Sequencing structures @cindex Control structures, sequencing Each of the special forms in this section simply evaluates its arguments in left-to-right order. The only difference is the result returned. The most widely used sequencing special form is @code{progn}: it evaluates all its argument forms and returns the computed value of the last one. Many other control structures are said to perform an @dfn{implicit progn}, this means that internally they call @code{progn} with a list of forms. @code{progn} in Lisp is nearly analogous to a @code{begin@dots{}end} block in Pascal; it is used in much the same places---to allow you to evaluate a sequence of form where only one form was allowed (for example the ``true'' clause of an @code{if} structure). @defspec progn forms@dots{} All of the @var{forms} are evaluated sequentially (from left-to-right), the result of the last evaluated @var{form} is the return value of the special form. If no arguments are given to @code{progn} it returns false. @lisp (progn 'one (+ 1 1) "three") @result{} "three" (progn) @result{} () @end lisp @end defspec @defmac prog1 first forms@dots{} This special form evaluates its @var{first} form then performs an implicit progn on the rest of its arguments. The result of this structure is the computed value of the @var{first} form. @lisp (prog1 'one (+ 1 1) "three") @result{} one @end lisp @end defmac @defmac prog2 first second forms@dots{} This is similar to @code{prog1} except that the evaluation of its @var{second} form is returned. The @var{first} form is evaluated, then its @var{second}, then it performs an implicit progn on the remaining arguments. @lisp (prog2 'one (+ 1 1) "three") @result{} 2 @end lisp @end defmac @node Conditional Structures, Looping Structures, Sequencing Structures, Control Structures @subsection Conditional Structures @cindex Conditional structures @cindex Control structures, conditionals Lisp provides a number of conditional constructs, the most complex of which (@code{cond}) takes a list of conditions, the first of which evaluates to true has its associated list of forms evaluated. Theoretically this is the only conditional special form necessary---all others can be implemented as macros. @defmac if condition true-form else-forms@dots{} The @code{if} form is the nearest thing in Lisp to the @dfn{if-then-else} construct found in most programming languages. First the @var{condition} form is evaluated, if it returns true the @var{true-form} is evaluated and its result returned. Otherwise the result of an implicit progn on the @var{else-forms} is returned. If there are no @var{else-forms} false is returned. Note that one of the @var{true-form} or the @var{else-forms} is completely ignored---it is not evaluated. @lisp (if (special-form-p if) "`if' is a special form" "`if' is not a special form") @result{} "`if' is not a special form" @end lisp @end defmac @defmac when condition true-forms@dots{} @var{condition} is evaluated, if it is true the result of an implicit progn on the @var{true-forms} is returned, otherwise false is returned. @lisp (when t (message "Pointless") 'foo) @result{} foo @end lisp @end defmac @defmac unless condition else-forms@dots{} This special form evaluates @var{condition}, if its computed value is true, @code{()} is returned. Otherwise the @var{else-forms} are evaluated sequentially, the value of the last is returned. @end defmac @defspec cond clause@dots{} The @code{cond} special form is used to choose between an arbitrary number of conditions. Each @var{clause} is a list; the car of which is a @var{condition}, the cdr is a list of forms to evaluate (in an implicit @code{progn}) if the @var{condition} evaluates to true. This means that each @var{clause} looks something like: @lisp (@var{condition} @var{body-forms}@dots{}) @end lisp @noindent and a whole @code{cond} form looks like: @lisp (cond (@var{condition-1} @var{body-forms-1}@dots{}) (@var{condition-2} @var{body-forms-2}@dots{}) @dots{}) @end lisp The @var{condition} in each @var{clause} is evaluated in sequence (@var{condition-1}, then @var{condition-2}, @dots{}), the first one which evaluates to a true value has an implicit @code{progn} performed on its @var{body-forms}. The value of this @code{progn} is also the value of the @code{cond} statement. If the true @var{condition} has no @var{body-forms} the value returned is the value of the @var{condition}. If none of the clauses has a true @var{condition} the value of the @code{cond} statement is false. Often you want a @dfn{default} clause which has its @var{body-forms} evaluated when none of the other clauses are true. The way to do this is to add a clause with a @var{condition} of @code{t} and @var{body-forms} of whatever you want the default action to be. @lisp (cond ((stringp buffer-list)) ;Clause with no @var{body-forms} ((consp buffer-list) (setq x buffer-list) ;Two @var{body-forms} t) (t ;Default clause (error "`buffer-list' is corrupted!"))) @result{} t @end lisp @end defspec @defmac case key clauses@dots{} This special form is similar to @code{cond}, but switches on the result of evaluating a single form @var{key}, checking for equality with a number of other values, defined by the @var{clauses}. If any of these other values is the same as the result of evaluating @var{key}, then a sequence of forms associated with the value is evaluated. Each element of the @var{clauses} list has the format: @lisp ((@var{value-1} @var{value-2} @dots{} @var{value-n}) @var{forms}@dots{}) @end lisp @noindent Each of the values in the car of the clause is tested for equality with @var{key}, using the @code{eql} function. If any test positively, then the associated @var{forms} are evaluated and the resulting value becomes the result of the special form. Instead of supplying a list of possible values, it is also possible to just specify the symbol @code{t}. If such a clause is encountered, and no other clauses have matched the value of @var{key}, then this clause is assumed to match by default. If any of the values in the @var{clauses} appear multiply, then the behaviour of the construct is undefined. Here is an example use of @code{case}: @lisp (case foo ((bar baz) (print "It was either bar or baz")) ((quux) (print "It was quux")) (t (print "I've no idea what it was..."))) @end lisp @end defmac There are also a number of special forms which combine conditions together by the normal logical rules. @defmac or forms@dots{} The first of the @var{forms} is evaluated, if it is true its value is the value of the @code{or} form and no more of @code{forms} are evaluated. Otherwise this step is repeated for the next member of @var{forms}. If all of the @var{forms} have been evaluated and none have a true value the @code{or} form evaluates to false. @lisp (or nil 1 nil (beep)) ;@code{(beep)} won't be evaluated @result{} 1 @end lisp @end defmac @defmac and forms@dots{} The first of the @var{forms} is evaluated. If it is false no more of the @var{forms} are evaluated and false is the value of the @code{and} statement. Otherwise the next member of @var{forms} is evaluated and its value tested. If none of the @var{forms} are false the computed value of the last member of @var{forms} is returned from the @code{and} form. @lisp (and 1 2 nil (beep)) ;@code{(beep)} won't be evaluated @result{} () (and 1 2 3) ;All forms are evaluated @result{} 3 @end lisp @end defmac @defun not object This function inverts the truth value of its argument. If @var{object} is true, false is returned, otherwise true is returned. @lisp (not nil) @result{} t (not t) @result{} () (not (not 42)) @result{} t @end lisp @end defun @node Looping Structures, Non-Local Exits, Conditional Structures, Control Structures @subsection Looping Structures @cindex Looping structures @cindex Control structures, looping The @code{librep} Lisp dialect only has one method of creating looping control structures---recursion. Any looping construct found in an imperative language can be represented as a recursive function. For example the common @code{while} statement: @lisp (while @var{condition} @var{body}@dots{}) @equiv{} (letrec ((loop (lambda () (when @var{condition} @var{body} (loop))))) (loop)) @end lisp @noindent Each successive iteration of the loop is simply another call to the function. Also note that the recursive call to the @code{(loop)} function occurs in the tail-position of the function. When combined with the system's ability to eliminate tail-calls (@pxref{Function Call Forms}) the above example loop has bounded space requirements. This is important when loops make a large number of iterations. Although tail-recursion is the only primitive method of looping, the language offers a number of looping forms for convenience. @defmac do vars (test expr@dots{}) body@dots{} @code{do} is an iteration construct; @var{vars} specifies a set of variable bindings to be created, how they are initialized and how they are updated on each iteration. @var{test} specifies the termination condition of the loop, any @var{expr}@dots{} forms are evaluated immediately prior to exiting the `do' construct. The @var{body}@dots{} forms specify the side effecting body of the loop. @var{vars} is a list of variable clauses, each of which has the structure @code{(@var{variable} @var{init} @var{step})} where @var{variable} is the name of a variable, @var{init} defines the initial value of its binding, and @var{step} defines how the next value of the binding is computed. An alternative form is @code{(@var{variable} @var{init})}, in this case the value of the binding does not change across loop iterations. Each iteration begins by evaluating @var{test}, if the result is false, then the @var{body}@dots{} expressions are evaluated, and the variables bound to new locations initialized to the results of evaluating the associated @var{step} forms. If the result of evaluating @var{test} is true then the @var{expr}@dots{} forms are evaluated, and the @code{do} construct returns the value of the last @var{expr} form evaluated. @lisp (do ((vec (make-vector 5)) (i 0 (1+ i))) ((= i 5) vec) (aset vec i i)) @result{} [0 1 2 3 4] @end lisp @end defmac The ``named-let'' variant of the @code{let} form also provides a convenient looping construct. @defmac let variable bindings body@dots{} This is the same as the @code{(let @var{bindings} @var{body}@dots{})} form described in @ref{Local Variables}, but within the @var{body}@dots{} forms, the symbol @var{variable} is bound to a function whose parameters are the bound variables defined by @var{bindings} and whose body is the sequence of forms @var{body}@dots{} This means that the body of the @code{let} may be repeated by invoking the function @var{variable} with suitable parameters. @lisp (let loop ((rest '(1 2 3)) (total 0)) (if (null rest) total (loop (cdr rest) (+ total (car rest))))) @result{} 6 @end lisp @end defmac Finally, the imperative @code{while} form shown at the start of the section is also provided: @defmac while condition body@dots{} The @var{condition} form is evaluated. If it is true an implicit progn is performed on the @var{body} forms and the whole procedure is repeated. This continues until the @var{condition} form evaluates to false. The value of every @code{while} structure that terminates is false. @end defmac @node Non-Local Exits, Continuations, Looping Structures, Control Structures @subsection Non-Local Exits @cindex Non-local exits @cindex Control structures, non-local exits A @dfn{non-local exit} is a transfer of control from the current point of evaluation to a different point (somewhat similar to the much-maligned @code{goto} statement in imperative languages). Non-local exits can either be used explicitly (@code{catch} and @code{throw}) or implicitly (errors). @menu * Catch and Throw:: Programmed non-local exits * Function Exits:: Returning values from a function * Cleanup Forms:: Forms which will always be evaluated * Errors:: Signalling that an error occurred @end menu @node Catch and Throw, Function Exits, , Non-Local Exits @subsubsection Catch and Throw @cindex Catch and throw @cindex Non-local exits, catch and throw The @code{catch} and @code{throw} structures are used to perform explicit transfers of control. First a @code{catch} form is used to setup a @dfn{tag}; this acts like a label for a @code{goto} statement. To transfer control a @code{throw} form is then used to transfer to the named tag. The tag is destroyed and the @code{catch} form exits with the value provided by the @code{throw}. In a program this looks like, @lisp (catch '@var{tag} ;; Forms which may `throw' back to @var{tag} @dots{} (throw '@var{tag} @var{value}) ;; Control has now passed to the `catch', ;; no more forms in this progn will be evaluated. @dots{}) @result{} @var{value} @end lisp @noindent where @var{tag} is the tag to be used (this is normally a symbol) and @var{value} is the result of the @code{catch} form. When a throw actually happens all catches in scope are searched for one with a tag which is @code{eq} to the tag in the throw. If more than one exists the innermost is selected. Now that the catch has been located the environment is `wound-back' to the catch's position (i.e. local variables are unbound, cleanup forms executed, unused catches removed, etc@dots{}) and all Lisp constructs between the current point of control and the catch are immediately exited. For example, @lisp (let ((test 'outer)) (cons (catch 'foo (let ((test 'inner)) (throw 'foo test) (setq test 'unreachable))) ;Never reached test)) @result{} (inner . outer) @end lisp @noindent when the throw executes the second binding of @code{test} is unwound and the first binding comes back into effect. For more details on variable binding see @ref{Local Variables}. Note that catch tags are @emph{dynamically} scoped, the thrower does not have to be within the same lexical scope (this means that you can @code{throw} through functions). @defmac catch tag body-forms@dots{} This special form defines a catch tag which will be accessible while the @var{body-forms} are evaluated. @var{tag} is evaluated and recorded as the tag for this catch. Next the @var{body-forms} are evaluated as an implicit @code{progn}. The value of the @code{catch} form is either the value of the @code{progn}, or, if a @code{throw} happened, the value specified in the @var{throw} form. Before exiting, the tag installed by this form is removed. @end defmac @defun throw tag @t{#!optional} catch-value This function transfers the point of control to the catch form with a tag which is @code{eq} to @var{tag}. The value returned by this catch form is either @var{catch-value} or false if @var{catch-value} is undefined. If there is no catch with a tag of @var{tag} an error is signalled and the interpreter returns to the top-level of evaluation. @end defun There are a number of pre-defined throw tags: @table @code @item quit Terminate the @code{librep} interpreter, returning the value of the throw (if a number). @item exit Exit the innermost event loop, unless currently in the outermost event loop, when control just passes back to the event loop. @item user-interrupt As if a @code{SIGINT} or @kbd{C-c} signal has been received. Control passes back to the top-level event loop. @item term-interrupt Triggered when a @code{SIGTERM} or @code{SIGHUP} signal is received. Tries to clean up any existing state, then terminates the interpreter. @end table Note that it is the event loop that catches these tags. If no event loop is active (i.e. just in read-eval-print on the console mode), any uncaught throws will result in termination. @node Function Exits, Cleanup Forms, Catch and Throw, Non-Local Exits @subsubsection Function Exits @cindex Function exits @cindex Non-local exits, function exits @code{librep} has no explicit @code{return} statement, as found in most other languages. Where a value has to returned from a function before the function would normally exit, a @code{catch}/@code{throw} pair may be used. For example: @lisp (defun foo (x y) (catch 'return (when (= x 2) (throw 'return nil)) @dots{} @end lisp @node Cleanup Forms, Errors, Function Exits, Non-Local Exits @subsubsection Cleanup Forms @cindex Cleanup forms @cindex Non-local exits, cleanup forms It is sometimes necessary ensure that a certain form is @emph{always} evaluated, even when a non-local exit would normally bypass that form. The @code{unwind-protect} special form is used in this case. @defmac unwind-protect body-form cleanup-forms@dots{} The @var{body-form} is evaluated, if it exits normally the @var{cleanup-forms} are evaluated sequentially then the value which the @var{body-form} returned becomes the value of the @code{unwind-protect} form. If the @var{body-form} exits abnormally though (i.e. a non-local exit happened) the @var{cleanup-forms} are evaluated anyway and the non-local exit continues. @end defmac One use of this is to ensure that an opened file is always closed, for example, @lisp (catch 'foo (unwind-protect (let ((temporary-file (open-file (make-temp-name) 'write))) ;; Use @code{temporary-file} (write temporary-file "A test\n") ;; Now force a non-local exit (throw 'foo)) ;; This is the @var{cleanup-form} it will @emph{always} ;; be evaluated, despite the @code{throw}. (close temporary-file))) @result{} () @end lisp @node Errors, , Cleanup Forms, Non-Local Exits @subsubsection Errors @cindex Errors @cindex Non-local exits, errors Errors are a type of non-local exit; when a form can not be evaluated for some reason an error is normally @dfn{signalled}. If an error-handler has been installed for that type of error, control is passed to the handler for that error, and evaluation continues. If there is no suitable handler, control is passed back to the innermost input loop and a suitable error message is printed. @defun signal error-symbol data Signals that an error has happened. @var{error-symbol} is a symbol classifying the type of error, it should have a property @code{error-message} (a string) which is the error message to be printed. @var{data} is a list of objects which are relevant to the error --- they will be made available to any error-handler or printed with the error message otherwise. @lisp (signal 'void-value '(some-symbol)) @error{} Value as variable is void: some-symbol @end lisp @end defun @defvar debug-on-error This variable is consulted by the function @code{signal}. If its value is either @code{t} or a list containing the @var{error-symbol} to @code{signal} as one of its elements, the Lisp debugger is entered. When the debugger exits the error is signalled as normal. @end defvar @defvar backtrace-on-error Similar to @code{debug-on-error}, but if an error is matched, the current backtrace is printed to the standard error stream, and control continues. @end defvar When you expect an error to occur and need to be able to regain control afterwards the @code{condition-case} special form may be used. @defmac condition-case symbol body-form error-handlers@dots{} @code{condition-case} evaluates the @var{body-form} with the @var{error-handlers} in place. If an error occurs and one of the handles matches the error, then it is evaluated with the value of @var{symbol} set to the error information. Each of the @var{error-handlers} is a list whose car is a symbol defining the type of error which this handler catches. The cdr of the list is a list of forms to be evaluated in a @code{progn} if the handler is invoked. While the forms of the error handler are being evaluated the variable @var{symbol} is bound to the value @code{(@var{error-symbol} . @var{data})} (these were the arguments to the @code{signal} form which caused the error). If @var{symbol} is the symbol @code{nil} (or the empty list @code{()}), then the error information is not available to the handler. The special value, the symbol @code{error}, in the car of one of the @var{error-handlers} will catch @emph{all} types of errors. @lisp (condition-case data (signal 'file-error '("File not found" "/tmp/foo")) (file-error data) (error (setq x z))) ;Default handler @result{} (file-error "File not found" "/tmp/foo") @end lisp @end defmac @node Continuations, , Non-Local Exits, Control Structures @section Continuations @cindex Continuations Whenever a function is called, there is a control path waiting to receive the result of the function, e.g. often the form following the function invocation. This waiting control path is called the @dfn{continuation} of the function, since control will continue down this path when the called function exits. These continuations are usually not paid much thought, but in some cases it may be useful to be able to directly manipulate the continuation of a function. For this purpose rep provides the @code{call-with-current-continuation} function (often shortened to @code{call/cc}) that is standard in the Scheme dialect of Lisp. @defun call/cc function @var{function} is a function with a single parameter; it will be immediately invoked with this parameter bound to an object representing the current continuation (i.e. the control path that would be taken after @var{function} exits). The continuation object passed to @var{function} is itself a function accepting a single argument, when called it transfers control to the continuation of @var{function}, as if @var{function} had returned the argument applied to the continuation object. @end defun @defun call-with-current-continuation function This is an alias for @code{call/cc}. @end defun In its simplest form, @code{call/cc} can mimic the @code{catch} and @code{throw} procedures (@pxref{Catch and Throw}), for example: @lisp (defun foo (bar) (call/cc (lambda (esc) (when (null bar) ;; throws out of the call/cc (esc nil)) ;; do something with bar @dots{} @end lisp @noindent this is roughly equivalent to: @lisp (defun foo (bar) (catch 'tag (when (null bar) (throw 'tag nil)) ;; do something with bar @dots{} @end lisp This is only half the story---the most powerful feature of @code{call/cc} is that since continuations have dynamic extent (that is, no object is freed until no references to it exist) it is possible to return control to scopes that have already exited. For example, consider the following fragment of a lisp interaction: @lisp (prog1 (call/cc (lambda (esc) (setq cont esc))) (message "foo!")) @print{} foo! @result{} # cont @result{} # (cont 10) @print{} foo! @result{} 10 @end lisp @noindent The continuation of the @code{prog1} form is saved into the variable @code{cont}. When subsequently called with a single argument, it has exactly the same effect as the first time that the second form in the @code{prog1} construct was evaluated. @subsection Implementation Notes @code{call/cc} works by making a copy of the process' entire call stack. For this reason, it is likely to be less efficient than using the control structures described in the previous parts of this section. Of course, it is much more powerful than the other constructs, so this often outweighs the slight inefficiency. Also note that currently no attempt is made to save or restore the dynamic state of the Lisp system, apart from variable bindings (both lexical and special). This means that any @code{unwind-protect}, @code{condition-case} or @code{catch} forms that are active when invoking a continuation are all ignored. Another restriction is that invoking a continuation may not cause control to pass across a dynamic root (@pxref{Threads}). @node Threads, Loading, Control Structures, The language @section Threads @cindex Threads @code{librep} supports a simple model of multi-threaded programming. Multiple threads of execution may be created, with control preemptively being switched between them. Unless otherwise noted, all definitions described in this section are provided by the @code{rep.threads} module. @menu * Thread Contexts:: * Creating Threads:: * Deleting Threads:: * Manipulating Threads:: * Mutexes:: * Thread Implementation Notes:: @end menu @node Thread Contexts, Creating Threads, , Threads @subsection Thread Contexts @cindex Thread contexts Every thread created by rep is a member of a @dfn{thread context}, this context is defined by the current position in the lisp call stack. At any point in time, only threads which are members of the current context may be executing. @defun call-with-dynamic-root thunk Call the function of zero-parameters @var{thunk} in a new thread context. The new context will contain a single thread, that executing @var{thunk}. The call to @code{call-with-dynamic-root} will only return once all threads in the newly created context have been deleted, or a non-local exit causes control to leave forcibly. @end defun @node Creating Threads, Deleting Threads, Thread Contexts, Threads @subsection Creating Threads @cindex Creating threads @cindex Threads, creating The @code{make-thread} function may be used to create threads that execute within the current thread context (dynamic root). Each thread is represented by a lisp object. @defun threadp arg Return true if lisp object @var{arg} represents a thread of execution in the lisp environment. @end defun @defun make-thread thunk @t{#!optional} name Create and return a new thread of execution; it will initially invoke the zero-parameter function @var{thunk}. If the call to @var{thunk} returns the thread is automatically deleted. If @var{name} is defined, it is a string naming the current thread. @end defun @defun make-suspended-thread @t{#!optional} name Similar to @code{make-thread}, except that the newly created thread will be immediately suspended from running. @end defun @defun current-thread Returns the currently executing thread. If no threads have been created yet in the current dynamic root (i.e. there is a single ``implicit'' thread) then false is returned. @end defun @defun all-threads Returns a newly-created list containing all threads in the current dynamic root. If no threads have been created yet, returns a null list. @end defun @node Deleting Threads, Manipulating Threads, Creating Threads, Threads @subsection Deleting Threads @cindex Deleting threads @cindex Threads, deleting A thread may be deleted by either returning from the function specified when it was created, or by explicit deletion. Also, the implicit thread created by the @code{call-with-dynamic-root} function may be deleted by exiting from the function called in the new context. @defun thread-delete @t{#!optional} thread Mark @var{thread} (or the current thread), as being deleted. It will not be switched to in the future. If the current thread is deleted, control will be passed to the next runnable thread. Deleting the last runnable thread results forces the containing dynamic root to be closed. @end defun @defun thread-deleted-p thread Returns true if @var{thread} has been deleted. @end defun @node Manipulating Threads, Mutexes, Deleting Threads, Threads @subsection Manipulating Threads @cindex Manipulating threads @cindex Threads, manipulating @defun thread-yield This function may be used to pass control away from the current thread if other threads are waiting to run. There is usually no need to call this function since running threads will be preempted after a period of time. @end defun @defun thread-suspend @t{#!optional} thread milliseconds Mark @var{thread} (or the current thread) as being suspended. It will not be selected until either it has had this status removed, or @var{milliseconds} milliseconds time has passed. Suspending the current thread will pass control to the next runnable thread in the same dynamic root. If there are no runnable threads, then the interpreter will sleep until the next thread becomes runnable. @end defun @defun thread-join thread @t{#!optional} timeout default-value Suspends the current thread until either @var{thread} has exited, or @var{timeout} milliseconds have passed. If @var{thread} exits normally, then the value of the last form it evaluated is returned; otherwise @var{default-value} is returned. It is an error to call @code{thread-join} on a @var{thread} that is not a member of the current dynamic root. @end defun @defun thread-wake thread Remove the suspended state from thread @var{thread}. It will then be scheduled for execution sometime subsequently, if its dynamic root is active. @end defun @defun thread-suspended-p thread Returns true if @var{thread} is currently suspended. @end defun Thread preemption may be forbidden at times, to allow atomic operations to take place. Each dynamic root has its own ``forbid counter''. Only when this counter is zero may the current thread be preempted. @defun thread-forbid Increment the forbid count. @end defun @defun thread-permit Decrement the forbid count. @end defun @defmac without-interrupts @t{#!rest} forms Evaluate the list of forms @var{forms} with thread preemption temporarily disabled. @end defmac @node Mutexes, Thread Implementation Notes, Manipulating Threads, Threads @subsection Mutual Exclusion Devices @cindex Mutual exclusion devices @cindex Mutexes @cindex Threads, mutexes @dfn{Mutexes} are lisp objects used to coordinate access to data shared across multiple threads (where interleaved access would be bad). These functions are exported by the @code{rep.threads.mutex} module (@pxref{Modules}). @defun make-mutex Create and return a mutex object. No thread will own the new mutex. @end defun @defun mutexp arg Return true if @var{arg} is a mutex object. @end defun @defun obtain-mutex mutex Obtain the mutex @var{mutex} for the current thread. Will suspend the current thread until the mutex is exclusively available. @end defun @defun maybe-obtain-mutex mutex Attempt to obtain mutex @var{mutex} for the current thread without blocking. Returns true if able to obtain the mutex, false otherwise. @end defun @defun release-mutex mutex Release the mutex object @var{mutex} (which must have previously been obtained by the current thread). Returns true if the mutex has no new owner. @end defun @node Thread Implementation Notes, , Mutexes, Threads @subsection Thread Implementation Notes @cindex Thread implementation notes The threads used by @code{librep} are @emph{software threads}. This means that they are currently implemented by manually switching in and out thread context (i.e. the call stack) as required. There are a number of disadvantages to this method: @itemize @bullet @item blocking I/O blocks @emph{all} threads, not just the thread doing the I/O, @item only a single processor is used, thereby avoiding any true parallelism on multi-processor systems. @end itemize @noindent The main advantage is the ease of implementation, especially when retrofitting threads into the previously single-threaded interpreter. @node Loading, Compiled Lisp, Threads, The language @section Loading @cindex Loading @cindex Loading programs @cindex Programs, loading In Lisp, programs (also called @dfn{modules}, or @dfn{libraries}) are stored in files. Each file is a sequence of Lisp forms (known as @dfn{top-level forms}). Most of the top-level forms in a program will be definitions (i.e. function, macro or variable definitions) since generally each library is a system of related functions and variables. Before the program can be used it has to be @dfn{loaded} into the editor's workspace; this involves reading and evaluating each top-level form in the file, i.e. instantiating all function definitions, or whatever. @menu * Load Function:: The function which loads programs * Autoloading:: Functions can be loaded on reference * Features:: Module management functions @end menu @node Load Function, Autoloading, , Loading @subsection Load Function @cindex Load function @cindex Functions, loading @defun load program @t{#!optional} no-error no-path no-suffix This function loads the file containing the program called @var{program}; first the file is located then each top-level form contained by the file is read and evaluated in order. Each directory named by the variable @code{load-path} is searched until the file containing @var{program} is found. In each directory three different file names are tried, @enumerate @item @var{program} with @samp{.jlc} appended to it. Files with a @samp{.jlc} suffix are usually compiled Lisp files. @xref{Compiled Lisp}. @item @var{program} with @samp{.jl} appended, most uncompiled Lisp programs are stored in files with names like this. @item @var{program} with no modifications. @end enumerate If none of these gives a result the next directory is searched in the same way, when all directories in @code{load-path} have been exhausted and the file still has not been found an error is signalled. Next the file is opened for reading and Lisp forms are read from it one at a time, each form is evaluated before the next form is read. When the end of the file is reached the file has been loaded and this function returns true. The optional arguments to this function are used to modify its behaviour, @table @var @item no-error When this argument is true no error is signalled if the file can not be located. Instead the function returns false. @item no-path The variable @code{load-path} is not used, @var{program} must point to the file from the current working directory. @item no-suffix When true no @samp{.jlc} or @samp{.jl} suffixes are applied to the @var{program} argument when locating the file. @end table If a version of the program whose name ends in @samp{.jlc} is older than a @samp{.jl} version of the same file (i.e. the source code is newer than the compiled version) a warning is displayed and the @samp{.jl} version is used. If no Lisp file can be found matching @var{program}, then each directory in the variable @code{dl-load-path} is searched for a @code{libtool} shared library called @file{@var{program}.la} (@pxref{Shared Libraries}). @end defun @defvar load-filename Whilst loading a Lisp library, this variable is bound to the name of the file being loaded. @end defvar @defvar load-path A list of strings, each element is the name of a directory which is prefixed to the name of a program when Lisp program files are being searched for. @lisp load-path @result{} ("/usr/local/lib/rep/1.0/lisp/" "/usr/local/lib/rep/site-lisp/" "") @end lisp The element @code{""} refers to the current directory, note that directory names should have an ending @samp{/} (or whatever) so that when concatenated with the name of the file they make a meaningful filename. @end defvar @defvar dl-load-path A list of strings defining all directories to search for shared libraries. @end defvar @defvar lisp-lib-directory The name of the directory in which the standard Lisp files are stored. @lisp lisp-lib-dir @result{} "/usr/local/lib/rep/1.0/lisp/" @end lisp @end defvar @defvar after-load-alist An association list of elements of the format @code{(@var{file} @var{forms} @dots{})}. When the library @var{file} is loaded, all @var{forms} are executed. However, note that @var{file} must @emph{exactly} match the @var{program} argument to the @code{load} function. @end defvar @defun eval-after-load library form Arrange for @var{form} to be evaluated immediately after the Lisp library of @var{library} has been read by the @code{load} function. Note that @var{library} must exactly match the @var{program} argument to @code{load}. @end defun @node Autoloading, Features, Load Function, Loading @subsection Autoloading @cindex Autoloading @cindex Loading, on reference Obviously, not all features of the @code{librep} environment are always used. @dfn{Autoloading} allows libraries to only be loaded when they are first required. This speeds up the initialisation process and may save memory. Functions which may be autoloaded have a special form in their symbol's function cell---an @dfn{autoload form}. This is a special kind of closure. When the function call dispatcher finds one of these forms it loads the program file specified in the form then re-evaluates the function call. The true function definition will then have been loaded and therefore the call may proceed as normal. Autoload stubs may be created through the @code{autoload} function. @defun autoload symbol file @t{#!optional} is-command Installs an autoload form into the symbol @var{symbol}. It marks that when @var{symbol} is called as a function the lisp library @var{file} should be loaded to provided the actual definition of @var{symbol}. @end defun It is not necessary to call the @code{autoload} function manually. Simply prefix the definitions of all the functions that may be autoloaded (i.e. the entry points to your module; @emph{not} all the internal functions.) with the magic comment @code{;;;###autoload}. Then load the file into the Jade editor and invoke the @code{add-autoloads} command, creating all the necessary calls to the autoload function in the @file{autoloads.jl} Lisp file (this file which lives in the Lisp library directory is loaded when the environment is initialised). @table @kbd @item Meta-x add-autoloads @kindex Meta-x add-autoloads Scans the current buffer for any autoload definitions. Functions with the comment @code{;;;###autoload} preceding them have autoload forms inserted into the @file{autoloads.jl} file. Simply save this file's buffer and the new autoloads will be used the next time Jade is initialised. It is also possible to mark arbitrary forms for inclusion in the @file{autoloads.jl} file: put them on a single line which starts with the comment @code{;;;###autoload} call the command. The unsaved @file{autoloads.jl} buffer will become the current buffer. @lisp ;;;###autoload (defun foo (bar) ;@code{foo} is to be autoloaded @dots{} ;;;###autoload (setq x y) ;Form to eval on initialisation @end lisp @item Meta-x remove-autoloads @kindex Meta-x remove-autoloads Remove all autoload forms from the @file{autoloads.jl} file which are marked by the @code{;;;###autoload} comment in the current buffer. The unsaved @file{autoloads.jl} buffer will become the current buffer. @end table XXX these editor commands don't really belong here, but they'll do for now@dots{} @node Features, , Autoloading, Loading @subsection Features @cindex Features @dfn{Features} correspond to libraries of Lisp code. Each feature is loaded separately. Each feature has a name, when a certain feature is required its user asks for it to be present (with the @code{require} function), the feature may then be used as normal. When a feature is loaded one of the top-level forms evaluated is a call to the @code{provide} function. This names the feature and installs it into the list of present features. @defvar features A list of the features currently present (that is, loaded) in the current module. Each feature is represented by a symbol. Usually the print name of the symbol (the name of the feature) is the same as the name of the file it was loaded from, minus any @samp{.jl} or @samp{.jlc} suffix. @lisp features @result{} (info isearch fill-mode texinfo-mode lisp-mode xc) @end lisp @end defvar @defun featurep feature Returns true if the feature @var{feature} has been loaded into the current module. @end defun @defun provide feature Adds @var{feature} (a symbol) to the list of loaded features. A call to this function is normally one of the top-level forms in a file. @lisp ;;;; maths.jl -- the @code{maths} library (provide 'maths) @dots{} @end lisp @end defun @defun require feature @t{#!optional} file Show that the caller is planning to use the feature @var{feature} (a symbol). This function will check the @code{features} variable to see if @var{feature} is already loaded, if so it will return immediately. If @var{feature} is not present it will be loaded. If @var{file} is given it specifies the first argument to the @code{load} function, else the print name of the symbol @var{feature} is used, with any @samp{.} characters replaced by the operating system's directory separator (@pxref{Module Loading}). @lisp ;;;; physics.jl -- the @code{physics} library (require 'maths) ;Need the @code{maths} library (provide 'physics) @dots{} @end lisp When called interactively the symbol @var{feature} is prompted for. @end defun Features may also be provided by modules, for more details @xref{Module Loading}. @node Compiled Lisp, Datums, Loading, The language @section Compiled Lisp @cindex Compiled Lisp @code{librep} contains a Lisp compiler as well as an interpreter; this takes a Lisp form or program and compiles it into a @dfn{byte-code} object. This byte-code object is a string of characters representing virtual machine instructions, a vector of constants and some other meta-information. The system also contains a byte-code interpreter; this takes the compiled byte-codes and executes them by simulating the virtual machine. This simulation will have exactly the same effect as interpreting the original form or program. One of the main reasons for compiling programs is to increase their efficiency. Compiled functions are likely to be more efficient than interpreted counterparts in all areas (space and time). For example: @example user> (define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) user> ,time (fib 30) 832040 Elapsed: 17.05572 seconds user> ,compile user> ,time (fib 30) 832040 Elapsed: 1.479007 seconds @end example @noindent ---the compiled function is over an order of magnitude faster than the interpreted version. @menu * Compilation Functions:: How to compile Lisp programs * Compiler Declarations:: Hinting to the compiler * Compilation Tips:: Getting the most out of the compiler * Disassembly:: Examining compiled functions @end menu @node Compilation Functions, Compiler Declarations, , Compiled Lisp @subsection Compilation Functions @cindex Compilation functions @cindex Functions, compilation @defun compile-form form This function compiles the Lisp form @var{form} into a byte-code form which is returned. @lisp (compile-form '(setq foo bar)) @result{} (run-byte-code "F!" [bar foo] 2) @end lisp @end defun @deffn Command compile-function function This function replaces the uncompiled body of the function @var{function} (a symbol) with a compiled version, then returns @var{function}. @end deffn @deffn Command compile-file file-name This function compiles the file called @var{file-name} into a file of compiled Lisp forms whose name is @var{file-name} with @samp{c} appended to it (i.e. if @var{file-name} is @file{foo.jl} it will be compiled to @file{foo.jlc}). If an error occurs while the file is being compiled any semi-written file will be deleted. When called interactively this function will ask for the value of @var{file-name}. @end deffn @deffn Command compile-directory directory @t{#!optional} force exclude Compiles all the Lisp files in the directory called @var{directory} which either haven't been compiled or whose compiled version is older than the source file (Lisp files are those ending in @samp{.jl}). If the optional argument @var{force} is true @emph{all} Lisp files will be recompiled whatever the status of their compiled version. The @var{exclude} argument may be a list of filenames, these files will @emph{not} be compiled. When this function is called interactively it prompts for the directory. @end deffn @deffn Command compile-module module-name Compiles all uncompiled function definitions in the module named @var{module-name} (a symbol). When called interactively the module name will be prompted for. @end deffn @defun run-byte-code byte-codes constants stack Interprets the string of byte instructions @var{byte-codes} with the vector of constants @var{constants}. This function should @emph{never} be called by hand. The compiler will produce calls to this function when it compiles a form or a function. @end defun There is a second form that byte-code objects can take: a vector whose read syntax includes a preceding @samp{#} character is a @dfn{byte-code subr}. These objects represent compiled Lisp functions and macros. @defun bytecodep arg Returns true if @var{arg} is a byte-code subroutine. @end defun @node Compiler Declarations, Compilation Tips, Compilation Functions, Compiled Lisp @subsection Compiler Declarations @cindex Compiler declarations @cindex Declarations, compiler It is often useful to be able to give the compiler extra knowledge about the program forms that it is compiling. The language includes special declaration forms that have no effect when interpreted, but are meaningful to the compiler as it traverses the program. @defmac declare clause@dots{} Offer the information contained in the @var{clause}@dots{} forms to the compiler, which it may or may not use when compiling the program. Each @var{clause} is a list, the first element of each clause is a symbol defining the type of declaration, the interpretation of any other elements in the clause depends upon the declaration type. The following table lists the syntax of all currently supported declaration types: @table @code @item (bound @var{variables}@dots{}) This declaration tells the compiler that all symbols @var{variables} have lexical bindings for the extent of the current lexical scope. This is often useful to prevent spurious compiler warnings. @item (special @var{variables}@dots{}) This tells the compiler that all symbols @var{variables} have special (dynamic) bindings for the extent of the current lexical scope. (It is important that the compiler is able to distinguish special bindings from lexical bindings, since different instruction sequences must be generated to access the different types of binding.) @item (unused @var{variables}@dots{}) Directs the compiler not to warn about bindings for @var{variables}@dots{} being unreferenced. @item (inline @var{names}@dots{}) Tells the compiler that it should consider inlining calls to the functions called @var{names}@dots{}. Inlining will only occur if these functions are declared in the same module as, and after, the declaration itself. @item (in-module @var{module-name}) This declaration should occur at the top-level of a program; it tells the compiler that the forms in the program will be evaluated within the context of the module called @var{module-name} (a symbol). @item (language @var{module}) Explicitly specifies the particular language dialect that the current module or file body is written for. Language dialects included with the librep distribution include @code{rep}, @code{scheme} and @code{unscheme}. These are also the names of the modules that should be imported to use a particular dialect. By default, the @code{rep} dialect is assumed for code outside module definitions. For code inside a module definition the list of imported modules is scanned for a known language dialect (i.e. if the module imports @code{rep}, then the rep language dialect is compiled for). @item (unsafe-for-call/cc) Tell the compiler that it may register-allocate variables, even if it can't prove that doing so wouldn't produce incorrect results if @code{call/cc} causes a function call to return more than once (@pxref{Continuations}). This declaration applies to the entire file that it occurs in. Without this declaration, the compiler will only register-allocate bindings if the following conditions are met: @itemize @bullet @item the binding is not accessed from any inner closures, and, @item the binding is never modified after being initialized (actually, the binding may be modified between being intialized and the next function call) @end itemize @noindent this declaration is often useful where @code{call/cc} isn't used, and there is a lot of side effecting of local variables. @end table Declaration forms always evaluate to false. @end defmac A second type of declaration is the @code{eval-when-compile} form, it allows Lisp forms to be evaluated only at compile-time. @defmac eval-when-compile form This form tells the system that @var{form} should only be evaluated when the containing code is being compiled. The compiler knows to recognize @var{form}s of the pattern @code{(eval-when-compile (require '@var{feature}))} as marking that @var{feature} should be imported at compile-time. Any other @var{form}s are simply evaluated in an unspecified environment. When interpreted, @code{eval-when-compile} forms alway evaluate to false, when compiled they evaluate to the result of evaluating the @var{form} at compile-time. @end defmac @node Compilation Tips, Disassembly, Compiler Declarations, Compiled Lisp @subsection Compilation Tips @cindex Compilation tips @cindex Tips, compilation Here are some tips for making compiled code run fast(er): @itemize @bullet @item Instead of using @code{while} loops to traverse lists, use @code{mapc} or tail recursion. For example you might code a function to scan a list using iteration through a @code{while} loop: @lisp (defun scan-list (lst elt) "Search the LST for an element similar to ELT. Return it if one is found." (catch 'return (while (consp lst) (when (equal (car lst) elt) (throw 'return elt)) (setq lst (cdr lst))))) @end lisp @noindent As well as obscuring what is actually happening, this will probably be fairly slow to execute. A more elegant solution is to use tail-recursion: @lisp (defun scan-list (lst elt) (if (equal (car lst) elt) elt (scan-list (cdr lst) elt))) @end lisp @noindent An alternative idiom is to map an anonymous function over the list using the @code{mapc} function: @lisp (defun scan-list (lst elt) (catch 'return (mapc (lambda (x) (when (equal x elt) (throw 'return elt))) lst) nil)) @end lisp @noindent In fact, the compiler knows that calls to @code{mapc} with a constant lambda expression can be open-coded, so it will code the list traversal directly using the virtual machine stack. However, in most cases the execution time differences are likely to negligible. @item In some cases the functions @code{member}, @code{memq}, @code{assoc}, etc@dots{} can be used to search lists. Since these are primitives written in C they will probably execute several times faster than an equivalent Lisp function. So the above @code{scan-list} example can again be rewritten, this time as: @lisp (defun scan-list (lst elt) (car (member elt lst))) @end lisp @item All conditional structures are equivalent when compiled (they are all translated to @code{cond} statements), so use whichever is the easiest to understand. @item A certain amount of constant folding is performed. If a function is known to be free of side effects, and all its arguments are constants, then it is evaluated at compile-time, and the result folded into the program in its place. For example @lisp (logor (lsh 1 6) x) @expansion{} (logor 32 x) @end lisp @item Careful use of named constants (@pxref{Defining Variables}) can increase the speed of some programs. For example, in the Lisp compiler itself all the opcode values (small integers) are defined as constants. It must be stressed that in some cases constants may @emph{not} be suitable; they may drastically increase the size of the compiled program (when the constants are `big' objects, i.e. long lists) or even introduce subtle bugs (since two references to the same constant may not be @code{eq} whereas two references to the same variable are always @code{eq}). @item Many primitives have corresponding byte-code instructions; these primitives will be quicker to call than those that don't (and incur a normal function call). Currently, the functions which have byte-code instructions (apart from all the special forms) are: @code{cons}, @code{car}, @code{cdr}, @code{rplaca}, @code{rplacd}, @code{nth}, @code{nthcdr}, @code{aset}, @code{aref}, @code{length}, @code{eval}, @code{+}, @code{*}, @code{/}, @code{%}, @code{mod}, @code{lognot}, @code{not}, @code{logior}, @code{logand}, @code{logxor}, @code{equal}, @code{eq}, @code{=}, @code{/=}, @code{>}, @code{<}, @code{>=}, @code{<=}, @code{1+}, @code{1-}, @code{-}, @code{set}, @code{lsh}, @code{zerop}, @code{null}, @code{atom}, @code{consp}, @code{listp}, @code{numberp}, @code{stringp}, @code{vectorp}, @code{throw}, @code{boundp}, @code{symbolp}, @code{get}, @code{put}, @code{signal}, @code{return}, @code{reverse}, @code{nreverse}, @code{assoc}, @code{assq}, @code{rassoc}, @code{rassq}, @code{last}, @code{mapcar}, @code{mapc}, @code{member}, @code{memq}, @code{delete}, @code{delq}, @code{delete-if}, @code{delete-if-not}, @code{copy-sequence}, @code{sequencep}, @code{functionp}, @code{special-form-p}, @code{subrp}, @code{eql}, @code{max}, @code{min}, @code{filter}, @code{macrop}, @code{bytecodep}, @code{bind-object}. @item When a file is being compiled each top-level form it contains is inspected to see if it should be compiled into a byte-code form. Different types of form are processed in different ways: @itemize @bullet @item Function and macro definitions have their body forms compiled into a single byte-code form. The doc-string and interactive declaration are not compiled. @item If the form is a list form (@pxref{List Forms}) and the symbol which is the car of the list is one of: @code{if}, @code{cond}, @code{when}, @code{unless}, @code{let}, @code{let*}, @code{catch}, @code{unwind-protect}, @code{error-protect}, @code{with-buffer}, @code{with-window}, @code{progn}, @code{prog1}, @code{prog2}, @code{while}, @code{and}, @code{or}, @code{case}. @noindent then the form is compiled. Otherwise it is just written to the output file in its uncompiled state. @end itemize If your program contains a lot of top-level forms which you know will not be compiled automatically, consider putting them in a @code{progn} block to make the compiler coalesce them into one byte-code form. @end itemize @node Disassembly, , Compilation Tips, Compiled Lisp @subsection Disassembly @cindex Disassembly @cindex Compilation, disassembly of forms It is possible to disassemble byte-code forms; originally this was so I could figure out why the compiler wasn't working but if you're curious about how the compiler compiles a form it may be of use to you. Naturally, the output of the disassembler is a listing in the assembly language of the @code{librep} virtual machine---it won't take a byte-code form and produce the equivalent Lisp code! @deffn Command disassemble-fun function @t{#!optional} stream This function disassembles the compile Lisp function @var{function}. It writes a listing to the output stream @var{stream} (normally the value of the @code{standard-output} variable). When called interactively it will prompt for a function to disassemble. @end deffn When reading the output of the disassembler bear in mind that @code{librep} simulates a stack machine for the code to run on. All calculations are performed on the stack, the value left on the stack when the piece of code ends is the value of the byte-code form. Here is a small example. Consider the @code{fib} function given at the start of this section: @lisp (define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) @end lisp @noindent After compilation and disassembly, the following is produced (but without the annotations): @example Disassembly of #: 21 bytes, 1 constants, and (5,0,1) stack slots 0 required-arg ;requires a single parameter 1 dup 2 slot-set #0 ;store it in register 0 (r0) 3 pushi 2 4 le 5 jn 10 ;unless r0 <= 2, goto 10 8 pushi 1 9 return ;else, return 1 10 refg [0] fib 11 slot-ref #0 12 dec 13 call #1 ;push result of (fib (1- n)) 14 refg [0] fib 15 slot-ref #0 16 pushi 2 17 sub 18 call #1 ;push (fib (- n 2)) 19 add 20 return ;return the sum of the two calls @end example @node Datums, Queues, Compiled Lisp, The language @section Datums @cindex Datums @cindex Data types, datums @dfn{Datums} are the mechanism by which @code{librep} allows Lisp programs to define new data types, such that these types are completely distinct from the built-in data types (i.e. they match none of the standard type predicates). They also provide encapsulation, in that the data objects they provide are completely opaque, unless a pre-defined value is known (which was specified when the object was created, and is typically known only by the object's creator). @defun make-datum value key Create and return a new datum object. It has the value @var{value} associated with it, and has type @var{key}. @end defun @defun datum-ref arg key If @var{arg} has type @var{key}, then return the value associated with it. Otherwise, an error is signalled. @end defun @defun datum-set arg key value If @var{arg} has type @var{key}, then set the value associated with it to be @var{value}. Otherwise, an error is signalled. @end defun @defun has-type-p arg key Return true if @var{arg} has type @var{key}. @end defun @defun define-datum-printer key printer Associate the function @var{printer} with all datum objects of type @var{key}. When any such object is printed, @var{printer} is applied to two arguments, the datum and the stream to which it should be printed (@pxref{Output Streams}). @end defun @node Queues, Records, Datums, The language @section Queues @cindex Queues @cindex Data types, queues A @dfn{queue} is an ordered set of objects, such that objects enter at one end of the queue (the @dfn{tail}), and leave from the other end of the queue (the @dfn{head}). The acts of entering and leaving a queue are often called @dfn{enqueing} and @dfn{dequeueing}. @code{librep} provides a straightforward queue implementation, implemented by the @code{rep.data.queues} module (@pxref{Modules}). @defun make-queue Create and return a new queue object. The queue will initially be empty. @end defun @defun enqueue q arg Add the object @var{ARG} to the tail of the queue @var{q}. @end defun @defun dequeue q Remove the object at the head of the queue @var{q}, and return it. If @var{q} is empty, an error is signalled. @end defun @defun queue-empty-p q Return true if the queue @var{q} is not empty. @end defun @defun queuep arg Return true if the object @var{arg} is a queue. @end defun @defun queue->list q Return a list of objects representing the contents of the queue @var{q}, with objects ordered from head to tail. Modifying the list structure causes undefined effects to the queue itself. @end defun @defun queue-length q Return the number of objects stored in the queue @var{q}. @end defun @defun delete-from-queue q arg Removes any occurrences of the object @var{arg} from the queue @var{q}. @end defun @node Records, Hash Tables, Queues, The language @section Records @cindex Records @cindex Data types, records @code{librep} provides a convenient means of defining structured data types, these types are known as @dfn{records}. Each record is a distinct data type, meaning that there will only be a single type-predicate matching objects of any individual record type. All definitions documented in this section are provided by the @code{rep.data.records} module (@pxref{Modules}). Record types are defined using the @code{define-record-type} macro, this in turn defines a number of functions implementing the type. These functions include a constructor, a type predicate, and a user-defined set of field-accessor and -modifier functions. @defmac define-record-type type (constructor fields@dots{}) [predicate] (field accessor [modifier])@dots{} This macro creates a new record type storing an opaque object identifying the type in the variable named @var{type}. It then defines a function @var{constructor} with parameter list as specified by the @var{fields@dots{}}, and a predicate function called @var{predicate} if @var{predicate} is given. The fields of the record are defined by the sequence of @code{(@var{field} @var{accessor} [@var{modifier}])} forms, each form describes a single field (named @var{field}, which may match one of the constructor arguments). For each field a function @var{accessor} will be defined that when applied to an argument of the record type, returns the value stored in the associated @var{field}. If the @var{modifier} name is defined a function will be defined of that name, that when applied to a record and an object, stores the object into the associated field of the record. Note that the @var{fields@dots{}} may include all the standard lambda-list features (@pxref{Lambda Expressions}), including keyword parameters and default values. @end defmac Here is an example record definition: @lisp (define-record-type :pare (kons x y) ; constructor pare? ; predicate (x kar set-kar!) ; fields w/ optional accessors (y kdr)) ;and modifiers @end lisp @noindent the variable @code{:pare} is bound to the record type. Following this definition, the record type could be used as follows: @lisp (define x (kons 1 2)) (pare? x) @result{} t (kar x) @result{} 1 (set-kar! x 42) (kar x) @result{} 42 @end lisp By default record objects print as the name of their type in angle brackets, e.g. for the above @code{pare} type, each object would print as the string @samp{#<:pare>}. This may be redefined using the @code{define-record-discloser} function. @defun define-record-discloser type discloser Associate the function @var{discloser} with the record type @var{type}. When any record of this type is printed, @var{discloser} is applied to the object, it should return the value that will actually be printed. @end defun For the above example, the following could be used: @lisp (define-record-discloser :pare (lambda (x) `(pare ,(kar x) ,(kdr x)))) (kons 'a 'b) @result{} (pare a b) @end lisp Constructors for records with large numbers of fields often benefit from using keyword parameters. For example the @code{kons} record above could be defined as follows (though this would make more sense if it had more than two fields): @example (define-record-type :pare (kons #!key (kar 1) (kdr 2)) pare? (kar kar set-kar!) (kdr kdr set-kdr!)) (kons #:kar 42) @result{} (pare 42 2) (kons #:kdr 42) @result{} (pare 1 42) @end example @node Hash Tables, Guardians, Records, The language @section Hash Tables @cindex Hash tables @cindex Data types, hash tables The @code{rep.data.tables} module provides a flexible hash table implementation (@pxref{Modules}). Each hash table is represented by a lisp object satisfying the @code{tablep} predicate: @defun tablep arg Return true if @var{arg} is a hash table. @end defun Hash tables may be created by using the @code{make-table} and @code{make-weak-table} functions: @defun make-table hash-fun compare-fun Create and return a new hash table. When storing and referencing keys it will use the function @var{hash-fun} to map keys to hash codes (positive fixnums), and the predicate function @var{compare-fun} to compare two keys (should return true if the keys are considered equal). @end defun @defun make-weak-table hash-fun compare-fun Similar to @code{make-table}, except that key-value pairs stored in the table are said to be ``weakly keyed''. That is, they are only retained in the table as long the key has not been garbage collected. Unlike with tables created by the @code{make-table} function, the fact that the key is stored in the table is not considered good enough to prevent it being garbage collected. @end defun @defun table-ref table key Return the value stored in hash table @var{table} indexed by object @var{key}. Returns false if no such value exists. @end defun @defun table-bound-p table key Returns true if the hash table @var{table} contains a value associated with @var{key}. @end defun @defun table-set table key value Associate the value @var{value} with @var{key} in hash table @var{table}. Returns @code{value}. @end defun @defun table-unset table key Remove any value stored in @var{table} associated with @var{key}. @end defun @defun table-walk function table Call function @var{function} for every key-value pair stored in hash table @var{table}. For each pair, the function is called with arguments @code{(@var{key} @var{value})}. @end defun Several hash functions are also provided: @defun string-hash string Return an integer representing the string @var{string}. @end defun @defun symbol-hash symbol Call @code{(string-hash (symbol-name @var{symbol}))}. @end defun @defun eq-hash arg Return a hash value representing object @var{arg}. The hash is generated from the @emph{address} of the object. @end defun @defun equal-hash arg Return a hash value representing object @var{arg}. The hash is generated from the @emph{contents} of the object. @end defun @node Guardians, Streams, Hash Tables, The language @section Guardians @cindex Guardians @cindex Garbage collection, guardians A @dfn{guardian} is a lisp object used to control when other data objects are recycled by the garbage collector (@pxref{Garbage Collection}).@footnote{Guardians were first described in a paper by R. Kent Dybvig, Carl Bruggeman, and David Eby: @cite{"Guardians in a Generation-Based Garbage Collector", ACM SIGPLAN Conference on Programming Language Design and Implementation, June 1993.}} The usual behaviour of the collector is to recycle objects as soon as they have no remaining references. Guardians allow the programmer to detect when a specified object would be freed by the garbage collector, and to implement their own allocation policy. This can be useful, for example, with objects that have a high creation-overhead, and thus need to be cached for performance reasons. @defun make-guardian This function allocates and returns a new guardian. Each guardian has a list of data objects associated with it; some of which may have been proved to have no remaining references to them (except from the guardian system). Calling the guardian object with a single argument, adds that value to the list of objects associated with that guardian. Calling the guardian with no arguments has one of two effects: @itemize @bullet @item If objects are associated with the guardian that have been proved to be inaccessible, then return one of those objects, and remove it from the list of objects associated with the guardian. @item If none of the associated objects have been proved to be inaccessible, then return the value false. @end itemize @end defun Note the use of the word ``prove'' in the above description, objects are only moved into a guardian's inaccessible set by the garbage collector. Here is an example use of the guardian system: @lisp ;; create a new guardian object (setq G (make-guardian)) ;; create a lisp object (setq x (cons 'a 'b)) @result{} (a . b) ;; protect the object using the guardian (G x) ;; remove the sole reference to the object (setq x nil) @result{} () ;; invoke the garbage collector, this will ;; prove that the value added to the ;; guardian is no longer accessible (garbage-collect) ;; call the guardian to retrieve the ;; inaccessible value (G) @result{} (a . b) ;; no more inaccessible values available (G) @result{} () @end lisp @node Streams, Hooks, Guardians, The language @section Streams @cindex Streams @cindex Input and output A @dfn{stream} is a Lisp object which is either a data sink (an @dfn{output stream}) or a data source (an @dfn{input stream}). All streams produce or consume sequences of 8-bit characters. Streams are very flexible, functions using streams for their input and output do not need to know the type of stream being accessed. For example the Lisp reader (the @code{read} function) takes an input stream as its sole argument, it then reads characters from this stream until it has parsed a whole object. This stream could be a file, a function, or even a string; the @code{read} function does not need to differentiate. @defun streamp arg Return true if @var{arg} is a stream. @end defun @defun input-stream-p arg Return true if @var{arg} is an input stream. @end defun @defun output-stream-p arg Return true if @var{arg} is an output stream. @end defun @menu * Input Streams:: Types of input stream * Output Streams:: Types of output stream * Input Functions:: Functions to read from streams * Output Functions:: How to output to a stream * Formatted Output:: Output by template @end menu @node Input Streams, Output Streams, , Streams @subsection Input Streams @cindex Input streams @cindex Streams, input These are the possible types of input stream, for the functions which use them see @ref{Input Functions}. @table @code @item @var{file} Characters are read from the file object @var{file}, for the functions which manipulate file objects see @ref{Files}. @item @var{function} Each time an input character is required the @var{function} is called with no arguments. It should return the character read (an integer) or false if for some reason no character is available. @var{function} should also be able to `unread' one character. When this happens the function will be called with one argument---the value of the last character read. The function should arrange it so that the next time it is called it returns this character. A possible implementation could be, @lisp (defvar ms-unread-char nil "If true the character which was pushed back.") (defun my-stream (#!optional unread-char) (if unread-char (setq ms-unread-char unread-char) (if ms-unread-char (prog1 ms-unread-char (setq ms-unread-char nil)) ;; Normal case -- read and return a character from somewhere @dots{} @end lisp @item nil Read from the stream stored in the variable @code{standard-input}. @end table It is also possible to use a string as an input stream. The string to be read from must be applied to the @code{make-string-input-stream} function and the result from this function used as the input stream. @defun make-string-input-stream string @t{#!optional} start Returns an input stream which will supply the characters of the string @var{string} in order starting with the character at position @var{start} (or from position zero if this argument is undefined). @lisp (read (make-string-input-stream "(1 . 2)")) @result{} (1 . 2) @end lisp @end defun @defvar standard-input The input stream which is used when no other is specified or is false. @end defvar Applications that embed @code{librep}, or dynamically loaded extensions, may provide further input stream types. @node Output Streams, Input Functions, Input Streams, Streams @subsection Output Streams @cindex Output streams @cindex Streams, output These are the different types of output stream, for the functions which use them see @ref{Output Functions}. @table @code @item @var{file} Writes to the file object @var{file}. @xref{Files}. @item @var{function} The function @var{function} is called with one argument, either a string or a character. This should be used as the circumstances dictate. If the function returns a number it is the number of characters actually used, otherwise it is assumed that all the characters were successful. @item @var{process} Writes to the standard input of the process object @var{process}. If @var{process} isn't running an error is signalled. @xref{Processes}. @item t Appends the character(s) to the end of the status line message. @item () Write to the stream stored in the variable @code{standard-output}. @end table It is also possible to store the characters sent to an output stream in a string. @defun make-string-output-stream Returns an output stream. It accumulates the text sent to it for the benefit of the @code{get-output-stream-string} function. @end defun @defun get-output-stream-string string-output-stream Returns a string consisting of the text sent to the @var{string-output-stream} since the last call to @var{get-output-stream-string} (or since this stream was created by @code{make-string-output-stream}). @lisp (setq stream (make-string-output-stream)) @result{} ("" . 0) (prin1 keymap-path stream) @result{} ("(lisp-mode-keymap global-keymap)" . 64) (get-output-stream-string stream) @result{} "(lisp-mode-keymap global-keymap)" @end lisp @end defun @defvar standard-output This variable contains the output stream which is used when no other is specified (or when the given output stream is false). @end defvar @defvar standard-error This variable contains the output stream which is used when an error message is being reported. @end defvar Applications that embed @code{librep}, or dynamically loaded extensions, may provide further output stream types. @node Input Functions, Output Functions, Output Streams, Streams @subsection Input Functions @cindex Input functions @cindex Functions, input @cindex Streams, input functions @defun read-char stream Read and return the next character from the input stream @var{stream}. If the end of the stream is reached false is returned. @end defun @defun read-line stream This function reads one line of text from the input stream @var{stream}, a string containing the line (including the newline character which terminates the line). If the end of stream is reached before any characters can be read false is returned, if the end of stream is reached but some characters have been read (but not the newline) these characters are made into a string and returned. Note that unlike the Common Lisp function of the same name, the newline character is not removed from the returned string. @end defun @defun read stream This function is the function which encapsulates the Lisp reader (@pxref{The Lisp Reader}). It reads as many characters from the input stream @var{stream} as required to form the read syntax of a single Lisp object (@pxref{Read Syntax}), this object is then returned. @end defun @defun read-from-string string @t{#!optional} start Reads one Lisp object from the string @var{string}, the first character is read from position @var{start} (or position zero). @lisp (read-from-string @var{string} @var{start}) @equiv{} (read (make-string-input-stream @var{string} @var{start})) @end lisp @end defun @node Output Functions, Formatted Output, Input Functions, Streams @subsection Output Functions @cindex Output functions @cindex Functions, output @cindex Streams, output functions @defun write stream data @t{#!optional} length Writes the specified character(s) to the output stream @var{stream}. @var{data} is either the character or the string to be written. If @var{data} is a string the optional argument @var{length} may specify how many characters are to be written. The value returned is the number of characters successfully written. @lisp (write standard-output "Testing 1.. 2.. 3..") @print{} Testing 1.. 2.. 3.. @result{} 19 @end lisp @end defun @defun copy-stream input-stream output-stream This function copies all characters which may be read from @var{input-stream} to @var{output-stream}. The copying process is not stopped until the end of the input stream is read. Returns the number of characters copied. Be warned, if you don't choose the streams carefully you may get a deadlock which only an interrupt signal can break! @end defun @defun print object @t{#!optional} stream Outputs a newline character to the output stream @var{stream}, then writes a textual representation of @var{object} to the stream. If possible, this representation will be the read syntax of @var{object}. @var{object} is returned. @lisp (print '(1 2 3)) @print{} @print{} (1 2 3) @result{} (1 2 3) @end lisp @end defun @defun prin1 object @t{#!optional} stream Similar to @code{print} but no initial newline is output. @lisp (prin1 '(1 2 3)) @print{} (1 2 3) @result{} (1 2 3) (prin1 '|(xy((z]|) ;A strange symbol @print{} \(xy\(\(z\] @result{} \(xy\(\(z\] @end lisp @end defun @defun prin1-to-string object Returns a string containing the characters that @code{prin1} would output when it prints @var{object}. @lisp (prin1-to-string '(1 2 3)) @result{} "(1 2 3)" @end lisp @end defun @defun princ object @t{#!optional} stream Prints a textual representation of @var{object} to the output stream @var{stream}. No steps are taken to create output that @code{read} can parse; in particular, no double-quote characters surround strings. @lisp (princ "foo") @print{} foo @result{} "foo" (princ '|(xy((z]|) @print{} (xy((z] @result{} \(xy\(\(z\] @end lisp @end defun Several variables may be used to control how objects are printed. @defvar print-escape This defines which control characters @code{print} and @code{prin1} will escape (using backslashes). Possible values are: @table @code @item () Only escape double-quote and backslash characters. @item newlines Only escape double-quote, backslash, newline, @kbd{TAB}, and formfeed characters. @item t Escape double-quote, backslash, and all control characters (anything with a numeric value less than 32, or greater than 126). @end table @end defvar @defvar print-length This variable, if true, limits the number of elements printed from lists. @end defvar @defvar print-level This variable, if true, limits the recursion depth when printing lists. @end defvar @node Formatted Output, , Output Functions, Streams @subsection Formatted Output @cindex Formatted output @cindex Output, formatted @cindex Streams, formatted output @defun format stream template @t{#!rest} values Writes to a stream, @var{stream}, a string constructed from the format string, @var{template}, and list of arguments @var{values}. If @var{stream} is false the resulting string will be returned, not written to a stream. @var{template} is a template for the output string, any @samp{%} characters introduce a substitution, using the next unused argument. The substitutions have the following syntax, @example %[@var{index}$][@var{flags}][@var{field-width}]@var{conversion} @end example @noindent @var{index} is an optional decimal number specifying exactly which of the @var{values} this conversion refers to (with the first at position one), and is usually used when translating messages; by default the next value is used. @var{field-width} is a positive decimal integer, defining the size in characters of the substitution output. @var{conversion} is a character defining how to convert the corresponding argument value to text. The default options are: @table @samp @item s Write the printed representation of the value without quoting (as if from the @code{princ} function). @item S Write the printed representation @emph{with} quoting enabled (like the @code{prin1} function). @item d Output the value as a decimal number. @item o Write the value in octal. @item x @itemx X In hexadecimal. @item c Write the character specified by the value. @item % Print a literal percent character. None of the @var{values} are used. @end table @var{flags} is a sequence of zero or more of the following characters, @table @asis @item @samp{_} Left justify the substitution within the field. @item @samp{^} Truncate the substitution at the size of the field. @item @samp{0} Pad the field with zeros instead of spaces. @item @samp{+} For @samp{d}, @samp{x}, and @samp{o} conversions, output a leading plus sign if the argument is positive. @item @samp{ } (a space) For @samp{d}, @samp{x}, and @samp{o} conversions, if the result doesn't start with a plus or minus sign, output a leading space. @end table The list of @var{conversions} can be extended through the @code{format-hooks-alist} variable; the strings created by these extra conversions are formatted as if by the `s' conversion. Note that the @var{field-width} and all flags currently have no effect on the @samp{S} conversion, (or the @samp{s} conversion when the argument isn't a string). If @var{stream} isn't false (in which case the created string is returned) the value of @var{stream} is returned. @lisp (format nil "foo %S bar 0x%x" '(x . y) 255) @result{} "foo (x . y) bar 0xff" (format standard-output "The %2$s is %1$s!" "purple" "dog") @print{} The dog is purple! @result{} # @end lisp @end defun @defvar format-hooks-alist This variable is an association-list, each element being @code{(@var{char} . @var{function})}, defining extra conversions for the @code{format} function. If a conversion @samp{%@var{x}} is given, and the alist contains an element whose car is the character @var{x}, the the associated function is called with one value, the next argument to be formatted. It should return the string to be inserted. @end defvar @node Hooks, Files, Streams, The language @section Hooks @cindex Hooks A @dfn{hook} allows you to wedge your own pieces of Lisp code into the operation of other functions, enable the extension of that functionality. These pieces of code are evaluated via the hook and the result is available to the hook's caller. One hook has already been encountered, the @code{format-hooks-alist} variable (@pxref{Formatted Output}). @menu * Functions As Hooks:: Some hooks are a single function, * Normal Hooks:: Others may be a list of pieces of code to evaluate. @end menu @node Functions As Hooks, Normal Hooks, , Hooks @subsection Functions As Hooks @cindex Functions as hooks @cindex Hooks, functions as Some hooks only allow a single piece of code to be hooked in. Usually a normally-undefined function is used; to install your hook defined a function with the name of the hook. When the hook is to be evaluated the function is called. Generally the name of the hook's function will end in @code{-function}. An alternative scheme is to use a variable to store the hook, its value should be the function to call. @node Normal Hooks, , Functions As Hooks, Hooks @subsection Normal Hooks @cindex Normal hooks @cindex Hooks, normal This is the standard type of hook, it is a variable whose value is a list of functions. When the hook is evaluated each of the functions will be called in turn. The names of hooks of this type will normally end in @code{-hook}. These functions are exported by the @code{rep.system} module. @defun add-hook hook function @t{#!optional} at-end This function adds a new function @var{function} to the list of functions installed in the (list) hook @var{hook} (a symbol). If @var{at-end} is true the new function is added at the end of the hook's list of functions (and therefore will be called last when the hook is evaluated), otherwise the new function is added to the front of the list. @lisp text-mode-hook @result{} (#) (add-hook 'text-mode-hook my-function) @result{} (# #) @end lisp @end defun @defun remove-hook hook function This function removes the function @var{function} from the list of functions stored in the (list) hook @var{hook} (a symbol). @emph{All} instances of @var{function} are deleted from the hook. @end defun There are actually three calling conventions for this type of hook, differing in how many of the functions in the list actually get called. In this simplest form, @emph{all} functions are called. In an @code{and} type hook, functions are only invoked while all others have returned true. As soon as the first function in the hook returns false, no others will be called. Finally, an @code{or} type hook aborts when a function returns a true result. @defun call-hook hook arg-list @t{#!optional} type Call the hook named by the symbol @var{hook}, passing all functions the arguments in the list @var{arg-list}. Note that @var{hook} may also be the actual list of functions to call. @var{type} defines how the return values of each function in the hook are treated. If @var{type} is false they are ignored, if @var{type} is the symbol @code{and} the hook aborts after a function returns false, if @var{type} is @code{or} the hook aborts when a function returns true. In all cases the value returned by the last-evaluated function is returned. @end defun @node Files, Processes, Hooks, The language @section Files @cindex Files @code{librep} allows you to manipulate files in the operating system's filing system; a special type of Lisp object, a @dfn{file object}, is used to represent files which have been opened for reading or writing (through the streams mechanism, @pxref{Streams}). Names of files are represented by strings, the syntax of file names is defined by the underlying operating system: @code{librep} simply treats it as a string. Unless otherwise stated, all functions and variables described in the following sections are exported by the @code{rep.io.files} module. @menu * File Names:: Files are named by a string * File Objects:: Lisp objects representing files * File Information:: Predicates on files * Manipulating Files:: Deleting, renaming and copying files * Manipulating Directories:: Accessing directories * Manipulating Symlinks:: Handling symbolic links * File Handlers:: Extending the file name-space * Remote Files:: Accessing remote files @end menu @node File Names, File Objects, , Files @subsection File Names @cindex File names @cindex Names of files A @dfn{file name} is a string identifying an individual file (or directory) in the filing system (i.e. the disk). The exact syntax of file names depends on the operating system. There are several functions for manipulating file names. @defun file-name-absolute-p file-name Returns true when @var{file-name} is not specified relative to the current directory. @end defun @defun file-name-directory file-name This function returns the directory part of the file name string @var{file-name}. This is the substring of @var{file-name} defining the directory containing the file. @lisp (file-name-directory "/tmp/foo") @result{} "/tmp/" (file-name-directory "foo") @result{} "" (file-name-directory "foo/bar/") @result{} "foo/bar/" @end lisp @end defun @defun file-name-nondirectory file-name Returns the substring of the file name @var{file-name} which is @emph{not} the directory part. @lisp (file-name-nondirectory "/tmp/foo") @result{} "foo" (file-name-nondirectory "foo") @result{} "foo" (file-name-nondirectory "foo/bar/") @result{} "" @end lisp @end defun @defun file-name-as-directory file-name Returns a string through which the item in the file system named by @var{file-name} can be referred to as a directory. @lisp (file-name-as-directory "./foo") @result{} "./foo/" (file-name-as-directory "./foo/") @result{} "./foo/" @end lisp @end defun @defun directory-file-name directory-name Returns a string through which the directory named by @var{directory-name} can be referred to as a file. @lisp (directory-file-name "./foo/") @result{} "./foo" (directory-file-name "./foo") @result{} "./foo" @end lisp @end defun @defun expand-file-name file-name @t{#!optional} base-dir Expands @var{file-name} assuming that it specifies a file relative to @var{base-dir}. If @var{base-dir} is undefined it is taken as the current value of the @code{default-directory} variable. While expanding the file name, any obvious simplifications will be performed (e.g. on Unix the removal of "." and ".." where possible). Note that the returned file name will only be absolute if one of the following conditions is met: @enumerate @item @var{base-dir} (or @code{default-directory}) is absolute, @item @var{file-name} is already absolute. @end enumerate @lisp (expand-file-name "foo" "./bar") @result{} "bar/foo" @end lisp Note for file handler implementors: when a handler is called for the @code{expand-file-name} operation, it will only ever receive one argument, the already expanded file name. The only action that may be need to be taken is to simplify the file name (e.g. removing @file{.} and @file{..} entries or whatever). @end defun @defun canonical-file-name file-name This function returns the canonical name of the file referred to by the string @var{file-name}. The canonical name of a file is defined such that two files can be compared simply by comparing their canonical names; if the names match, they refer to the same file. (Note that the opposite isn't always true, if two canonical names don't match the files could still be the same, for example via hard links. On most operating systems, symbolic links will be expanded where possible. @lisp (canonical-file-name "foo") @result{} "/home/john/src/librep/man/foo" @end lisp @end defun @defun local-file-name file-name @code{librep} supports extensible file handling (@pxref{File Handlers}), so file names may refer to files not residing in the system's local file structure, and thus which are unavailable to other programs. This function returns either the absolute name of the file @var{file-name}, if it is found in the local system, or false, if the file does not. @lisp (local-file-name "foo") @result{} "/home/john/src/librep/man/foo" (local-file-name "/john@@tango:foo") @result{} () @end lisp @end defun @defun make-temp-name This function returns the name of a file which, when created, may be used for temporary storage. Each time this function is called a unique name is computed. @lisp (make-temp-name) @result{} "/tmp/00088aaa" (make-temp-name) @result{} "/tmp/00088baa" @end lisp @end defun @defvar default-directory This variable names the current working directory. All relative file names are interpreted starting from this location in the file system. @end defvar @node File Objects, File Information, File Names, Files @subsection File Objects @cindex File objects A file object is a Lisp object which represents an open file in the filing system. Any file object may be used as a stream (either input or output) to access the contents of the file (@pxref{Streams}). @defun filep object This function returns true when its argument is a file object. @end defun @menu * Creating File Objects:: Opening files * Destroying File Objects:: Closing files * Functions on File Objects:: Functions operating on file objects @end menu @node Creating File Objects, Destroying File Objects, , File Objects @subsubsection Creating File Objects @cindex Creating file objects @cindex File objects, creating @cindex Files, opening @defun open-file file-name mode This function opens the file called @var{file-name} (@pxref{File Names}) and returns the new file object. The @var{mode} argument is a symbol defining the access modes used to open the file with, the options are: @table @code @item read Open an existing file for reading only. @item write Open the file for writing only, if the file exists it is truncated to zero length. Otherwise a new file is created. @item append Open the file for appending to, i.e. writing to the end of the file. If the file doesn't exist it is created. @end table @end defun The three standard I/O streams are also available as file handles. @defun stdin-file Return a file object representing the interpreters standard input. @end defun @defun stdout-file Return a file object representing the interpreters standard output. @end defun @defun stderr-file Return a file object representing the interpreters standard error. @end defun Attempting to close any of these files will result in the associated stream being connected to @file{/dev/null}. @node Destroying File Objects, Functions on File Objects, Creating File Objects, File Objects @subsubsection Destroying File Objects @cindex Destroying file objects @cindex File objects, destroying @cindex Files, closing The easiest way to close a file is simply to eliminate all references to it, subsequently the garbage collector will close it for you. It is better to close files explicitly though since only a limited number of files may be opened concurrently. @defun close-file file-object This function closes the file pointed to by the file object @var{file-object}. Subsequently, any stream accesses @var{file-object} are illegal and will signal an error. @end defun @node Functions on File Objects, , Destroying File Objects, File Objects @subsubsection Functions on File Objects @cindex Functions on File Objects @cindex File objects, functions @defun seek-file file @t{#!optional} offset where When called as @code{(seek-file @var{file})}, returns the distance in bytes from the start of the file that the next character would be read from. When called as @code{(seek-file @var{file} @var{offset} [@var{where}])} alters the position from which the next byte will be read. @var{where} can be one of the values: @table @code @item () @var{offset} bytes after the current position. @item start @var{offset} bytes after the beginning of the file. @item end @var{offset} bytes before the end of the file. @end table Note that not all files may be seekable; if @code{(seek-file @var{file})} returns false, indicating that the current position is unknown, any attempts to set the current position will also fail. @end defun @defun flush-file file This function flushes any buffered output to the file object @var{file} to disk. @end defun @defun file-binding file Returns the name of the file which the file object @var{file} is currently bound to. Returns false if the file is currently unbound (i.e. @code{close-file} was called on it). @end defun The next three functions are used when non-local files are being accessed. See @ref{File Handlers} for more details. @defun file-bound-stream file If the file object @var{file} doesn't refer to a file in the local filing system, return the stream that it is bound to (allowing the file's contents to be accessed), this may or may not be another file object. @end defun @defun file-handler-data file Return the file-handler-specific data associated with the file object @var{file}. @end defun @defun set-file-handler-data file data Set the handler-specific data of file object @var{file} to @var{data}. This should only be done by the handler owning the file. @end defun It's also possible to register a callback function to be invoked when input is available on a file, @defun set-input-handler local-file function Arrange for @var{function} to be called whenever pending input is available on @var{local-file}, a file object bound to a file in the local file space. Note that this makes @var{local-file} subsequently do non-blocking input. This function is normally only useful when @var{local-file} represents a pipe or socket. @end defun @node File Information, Manipulating Files, File Objects, Files @subsection File Information @cindex File information A number of functions exist which when given the name of a file return one of the attributes relating to that file. @defun file-exists-p file-name Returns true when a file @var{file-name} exists. @end defun @defun file-regular-p file-name Returns true when the file @var{file-name} is a `normal' file. This means that it isn't a directory, device, symbolic link or whatever. @end defun @defun file-directory-p file-name Returns true when the file @var{file-name} is a directory. @end defun @defun file-symlink-p file-name Returns true when the file @var{file-name} is a symbolic link. @end defun @defun file-readable-p file-name Returns true when the file @var{file-name} is readable. @end defun @defun file-writable-p file-name Returns true when the file @var{file-name} is writable. @end defun @defun file-owner-p file-name Returns true when the ownership of the file @var{file-name} is the same as that of any files written by the editor. @end defun @defun file-size file-name Returns the number of bytes stored in the file named @var{file-name}. @end defun @defun file-nlinks file-name Returns the number of hard links pointing to the file @var{file-name}. If @var{file-name} has only one name the number will be one. @end defun @defun file-modes file-name This function returns the access permissions of the file @var{file-name}. This will be an integer whose format is undefined; it differs from operating system to operating system. @end defun @defun file-modes-as-string file-name Returns a ten-character string describing the attibutes of the file called @var{file-name} @lisp (file-modes-as-string ".") @result{} "drwxr-sr-x" @end lisp @end defun @defun set-file-modes file-name modes This function sets the access permissions of the file @var{file-name} to the integer @var{modes} (as returned by the @code{file-modes} function). @end defun @defun file-modtime file-name Returns the system time at the last modification to the file @var{file-name}, this will be in the usual timestamp format, @xref{Timestamps}. @end defun @defun file-newer-than-file-p file-name1 file-name2 This function returns true if the file @var{file-name1} was modified more recently than the file @var{file-name2} was. @end defun @node Manipulating Files, Manipulating Directories, File Information, Files @subsection Manipulating Files @cindex Manipulating files @cindex Files, manipulating @deffn Command delete-file file-name This function deletes the file called @var{file-name}. When called interactively @var{file-name} is prompted for. @end deffn @deffn Command rename-file file-name new-name This function attempts to change the name of the file @var{new-name} to @var{new-name}. This won't work from one file system to another or if a file called @var{new-name} already exists, in these cases an error is signalled. This prompts for its arguments when called interactively. @end deffn @deffn Command copy-file file-name destination-name Creates a new copy of the file @var{file-name} with the name @var{destination-name}. The access modes of the new file will be the same as those of the original file. The arguments are prompted for when this function is called interactively. @end deffn @node Manipulating Directories, Manipulating Symlinks, Manipulating Files, Files @subsection Manipulating Directories @cindex Reading directories @cindex Files, manipulating directories @deffn Command make-directory directory-name Create a new directory called @var{directory-name}. @end deffn @deffn Command delete-directory directory-name Delete the directory called @var{directory-name}. This only succeeds if the directory in question is empty, otherwise an error is signalled. @end deffn @defun directory-files directory-name Returns a list of the names of all items in the directory whose name is @var{directory-name}. The names in the list will be relative to the directory @var{directory-name}. @lisp (directory-files "/tmp/foo" @result{} ("bar" "subdir" "xyz" "." "..") @end lisp @end defun @node Manipulating Symlinks, File Handlers, Manipulating Directories, Files @subsection Manipulating Symbolic Links @cindex Manipulating Symbolic Links @cindex Symbolic Links, manipulating @defun make-symlink name contents Create a symbolic link called @var{name}, containing the string @var{contents}. @end defun @defun read-symlink name Return the string that is the contents of the symbolic link called @var{name}. Signals an error if no such link exists. @end defun @node File Handlers, Remote Files, Manipulating Symlinks, Files @subsection File Handlers @cindex File Handlers As noted earlier, @code{librep} supports virtual files; that is it allows file names to be accessed that don't reside on the local filing system, or aren't normally valid as file names. This is achieved through the use of @dfn{file handlers}, Lisp functions that have signalled that they should be used to redirect all accesses to files whose names match a particular regular expression (@pxref{Regular Expressions}). For example, there is a convention under Unix that a user's home directory can be accessed via the file name @file{~}, even though there is no such support from the operating system itself. So a file handler can be (and has been) written that recognises all file names starting with a tilde, translating them to the actual file in the file system. @defvar file-handler-alist This variable contains a list of file handler declarations, each one of the form @code{(@var{regexp} . @var{function})}. Whenever a file operation is performed on a file whose name matches @var{regexp}, @var{function} is invoked to perform the action. The function is called as @code{(@var{function} @var{operation} @var{args}@dots{})}, where @var{operation} and @var{args} are from the original call. For example if the @code{file-handler-alist} contains the entry @code{("^~" . tilde-file-handler)}, then all file operations on files starting with a tilde are redirected to the @code{tilde-file-handler} function. Thus if a form @code{(file-exists-p "~/foo")} is executed, it would result in a call to @code{tilde-file-handler} as @code{(tilde-file-handler 'file-exists-p "~/foo")}. @end defvar The list of operations that may be redirected to a file handler is: @code{file-name-absolute-p}, @code{expand-file-name}, @code{local-file-name}, @code{canonical-file-name}, @code{file-name-nondirectory}, @code{file-name-directory}, @code{file-name-as-directory}, @code{directory-file-name}, @code{open-file}, @code{close-file}, @code{flush-file}, @code{seek-file}, @code{write-buffer-contents}, @code{read-file-contents}, @code{insert-file-contents}, @code{delete-file}, @code{rename-file}, @code{copy-file}, @code{copy-file-to-local-fs}, @code{copy-file-from-local-fs}, @code{make-directory}, @code{delete-directory}, @code{file-exists-p}, @code{file-regular-p}, @code{file-readable-p}, @code{file-writable-p}, @code{file-directory-p}, @code{file-symlink-p}, @code{file-owner-p}, @code{file-nlinks}, @code{file-size}, @code{file-modes}, @code{file-modes-as-string}, @code{set-file-modes}, @code{file-modtime}, @code{directory-files}, @code{make-symlink}, @code{read-symlink}. There are several undefined functions in this list. The @code{write-buffer-contents}, @code{read-file-contents}, and @code{insert-file-contents} pertain to the Jade text editor. The other two are defined as follows. @deffn Operation copy-file-to-local-fs file-name local-name Called when copying files between file handlers, this operation should copy the file matching the handler @var{file-name}, to the file on the local file system @var{local-name}. @end deffn @deffn Operation copy-file-from-local-fs local-name file-name Called when copying files between file handlers, this operation should copy the local file @var{file-name} to the file matching the handler @var{file-name}. @end deffn To prevent infinite recursion, while a particular operation is being processed by a file handler, that operation may not be passed back to the same handler. To allow file handlers to handle the @code{open-file} operation, it is possible to create file handles from arbitrary streams. @defun make-file-from-stream file-name stream handler Return a new file object that refers to the logical file called @var{file-name}, that is not in the local filing system. All access to the file object will be directed through the stream object @var{stream}, and the file handler function @var{handler}. @end defun An alternative method of opening remote files is to use a temporary file in the local file system with either one (@code{read} or @code{write} modes), or two (@code{append} mode) synchronisations with the remote system. This is the method used by the FTP remote file backend (see the next section). It has the advantage of simplifying the @code{seek-file} operation. @node Remote Files, , File Handlers, Files @subsection Remote files @cindex Remote files @cindex Files, remote @cindex File handlers, remote files Since one of the intentions for file handlers is to allow remote files to be accessed, a common method of providing new methods of doing this has been implemented, in the @file{remote.jl} Lisp library. Accessing a file name matching the regular expression: @example ^/(([a-zA-Z0-9._-]+)@@)?([a-zA-Z0-9._-]+): @end example @noindent for example @file{/john@@host.com:file} refers to a file called @samp{file} owned by the user @samp{john}, on the system @samp{host.com}. If no username is specified explicitly, two variables are used to select the user: @defvar remote-host-user-alist An alist mapping host regexps to the default user name to use for remote file connections to that host. @end defvar @defvar remote-default-user User name to use for remote file connections when otherwise unspecified. By default the current user name on the local system. @end defvar Two variables control how individual hosts are matched to methods of accessing files. @defvar remote-auto-backend-alist An alist of @code{(@var{host-regexp} . @var{backend-type})} mapping host names to methods of accessing remote files. @end defvar @defvar remote-default-backend A symbol defining the method to use for otherwise unselected hosts. @end defvar A method of accessing files, or a @dfn{backend} is a symbol whose @code{remote-backend} property names a function to call when files need to be accessed. For example the @code{ftp} backend is initialised as: @lisp (put 'ftp 'remote-backend remote-ftp-handler) @end lisp The backend function is called as @code{(@var{function} @var{split-name} @var{operation} @var{args})}. The @var{split-name} is a three-element list, @code{(@var{user-or-nil} @var{host} @var{file})} defining the file to be accessed. The other options are as usual. Further details can be found in the @file{remote.jl}, @file{remote-ftp.jl} and @file{remote-rcp.jl} Lisp source files. The @code{ftp} backend is currently the most well-developed, several functions and variables may be used to customise its behaviour. @defun remote-ftp-add-passwd user host passwd Add the string @var{passwd} as the password for the FTP session connecting to @var{user@@host}. @end defun @defvar remote-ftp-show-messages When true (the default), messages are displayed as FTP commands are executed. @end defvar @defvar remote-ftp-display-progress When true (the default) display progress of FTP transfers. @end defvar @defvar remote-ftp-anon-users A regular expression matching the user names for ``anonymous'' FTP sessions. @end defvar @defvar remote-ftp-anon-passwd The string to send as the passwd of an anonymous FTP session. By default the current uses email address. @end defvar There is a problem with the @code{ftp} backend however; due to limitations in the FTP protocol, not all @code{librep} file operations are supported, with the most obvious exception being the @code{make-symlink} function. When this is a problem it may be possible to use rep's custom file transfer protocol. If it is possible to use @code{rsh} to connect to the remote host in question, then the @code{rep} backend may be used. The @code{rep-remote} program distributed with @code{librep} must exist on the remote host, this is executed via @code{rsh} and provides a protocol for executing all of @code{librep}'s file operations on that host. See the @file{lisp/remote-rep.jl} file in the distribution for more details. @node Processes, Regular Expressions, Files, The language @section Processes @cindex Processes @cindex Subprocesses When running on a Unix-style operating system @code{librep} allows you to launch and control an arbitrary number of subprocesses. These subprocesses can run either synchronously or asynchronously in respect to the Lisp system; data can be sent to the @code{stdin} channel and any output from the process is automatically written to a specified Lisp output stream. Unless otherwise stated, all functions and variables described in the following sections are exported by the @code{rep.io.processes} module. @menu * Process Objects:: Lisp objects associated with subprocesses * Asynchronous Processes:: Subprocesses running in parallel * Synchronous Processes:: Subprocesses which run to completion * Process I/O:: Input and output with subprocesses * Process States:: Suspending subprocesses * Signalling Processes:: Sending signals to subprocesses * Process Information:: Information stored in a process object @end menu @node Process Objects, Asynchronous Processes, , Processes @subsection Process Objects @cindex Process objects A @dfn{process object} is a type of Lisp object used to provide a link between a `physical' process running in the operating system and the Lisp system. Each process object consists of a number of values (references to other Lisp objects); these values are used when the object is used to run a subprocess. Process objects which aren't currently being used to run a subprocess store the exit value of the last subprocess which was run on that object. @defun processp object This function returns true when its argument is a process object. @end defun The programmer-accessible components of a process object are, @table @dfn @item Output stream A normal Lisp output stream (@pxref{Output Streams}), all data which the subprocess outputs to its @code{stdout} channel is copied to this output stream. @xref{Process I/O}. @item Error stream A normal Lisp output stream (@pxref{Output Streams}), all data which the subprocess outputs to its @code{stderr} channel is copied to this output stream. Unless explicitly specified error output goes to the @code{stdout} stream. @xref{Process I/O}. @item State change function A Lisp function, called each time the state of the subprocess being run on the object changes. @xref{Process States}. @item Program name The name of the program (a string) to execute when the subprocess is created. @item Program arguments A list of strings defining the arguments which the program executed is given. @item Directory When a subprocess is started its current working directory is set to the directory named by this component of its process object. @item Connection type Asynchronous subprocesses (@pxref{Asynchronous Processes}) use this component to decide how to connect to the I/O channels of the subprocess. Current options include pseudo-terminals and pipes. @end table @defun make-process @t{#!optional} output-stream state-function directory program args This functions creates and returns a new process object. @emph{No subprocess will be started.} The optional arguments are used to define the values of the components of the new process object, any undefined components will be set to default or null values. @end defun For each component of a process object two functions exist; one to read the component's value in a specific process object, the other to set the component's value. @defun process-prog process Returns the value of the program name component of the process object @var{process}. @end defun @defun set-process-prog process prog-name Sets the value of the program name component of the process object @var{process} to the string @var{prog-name}, then returns @var{prog-name}. @end defun @defun process-args process Returns the value of the program arguments component of the process object @var{process}. @end defun @defun set-process-args process arg-list Sets the value of the program arguments component of the process object @var{process} to the list @var{arg-list}, then returns @var{arg-list}. @end defun @defun process-dir process Returns the value of the directory component of the process object @var{process}. @end defun @defun set-process-dir process directory Sets the value of the directory component of the process object @var{process} to the string @var{directory}, then returns @var{directory}. @end defun @defvar process-environment This is a list of environment variable definitions, as well as being used by the @code{setenv} and @code{getenv} functions (@pxref{Environment Variables}), it also provides the environment of all started subprocesses. @lisp (car process-environment) @result{} "LOGNAME=john" @end lisp @end defvar @defun active-processes Returns a list containing all active (i.e. running or stopped) process objects. @end defun @node Asynchronous Processes, Synchronous Processes, Process Objects, Processes @subsection Asynchronous Processes @cindex Asynchronous processes @cindex Processes, asynchronous An @dfn{asynchronous process} is one that runs in parallel with Lisp evaluation, basically this means that once the subprocess has been started (by the @code{start-process} function) @code{librep} will carry on as normal. The event loop checks for output from asynchronous processes, any found is copied to the process' output stream, and calls the the process' state change function when necessary (@pxref{Process States}). Alternatively the @code{accept-process-output} function can be called to explicitly allow output to be processed. When using asynchronous processes you have a choice as to the Unix mechanism used to connect the @code{stdin}, @code{stdout} and @code{stderr} streams of the subprocess to @code{librep}'s process. The two options currently available are pipes or pseudo-terminals; in general pseudo-terminals should only be used to provide a direct interface between the user and a process (i.e. the @samp{*shell*} buffer) since they allow job control to work properly. At other times pipes will be more efficient and are used by default. However, there are cases where the buffering characteristics of pipes mean that ptys must be used. @defun start-process @t{#!optional} process program @t{#!rest} args This function starts an asynchronous subprocess running on the process object @var{process}. If @var{process} is undefined a new process object is created (by calling the function @code{make-process} with all arguments undefined). The function always returns the process object which the subprocess has been started on. If for some reason the subprocess can't be created an error of type @code{process-error} is signalled. The optional argument @var{program} is a string defining the name of the program to execute, it will be searched for in all the directories in the @code{PATH} environment variable. The @var{args} are strings to pass to the subprocess as its arguments. When defined, the optional arguments overrule the values of the related components of the process object. The following example runs the @code{ls} program asynchronously, its output is sent to the @code{standard-output} stream. @lisp (let ((process (make-process standard-output))) (start-process process "ls" "-s")) @end lisp @end defun Note that when @code{librep} exits it kills all of its asynchronous subprocesses which are still running without warning. @defun process-connection-type process Returns the value of the connection type component of the process object @var{process}. See the documentation of the @code{set-process-connection-type} function for the values this may take. @end defun @defun set-process-connection-type process symbol Sets the value of the connection type component of the process object @var{process} to @var{symbol}, then returns @var{symbol}. @var{symbol} should be one of the following symbols, @table @code @item pty Use pseudo-terminals to connect to subprocesses running asynchronously on this process object. @item pipe Use standard Unix pipes to connect, this is the default value of this component. @item socketpair Uses a connected pair of sockets. @end table @end defun Note that currently only the @code{pipe} connection type allows the normal and error output streams of the process to be separated. @node Synchronous Processes, Process I/O, Asynchronous Processes, Processes @subsection Synchronous Processes @cindex Synchronous processes @cindex Processes, synchronous When a @dfn{synchronous process} is started @code{librep} waits for it to terminate before continuing; they are usually used when a Lisp program must invoke an external program as part of its function, i.e. the auto-compression feature runs the compression program @code{gzip} synchronously when it needs to compress a buffer. Unlike asynchronous processes their is no choice between pipes and pseudo-terminals for connecting to a subprocess. Instead, it is possible to link the @code{stdin} channel of a synchronous process to a named file. @defun call-process @t{#!optional} process input-file-name program @t{#!rest} args This function starts a process running on the process object @var{process}. If @var{process} is undefined a new process object is created by calling the @code{make} function. If defined, the string @var{input-file-name} names the file to connect to the standard input of the subprocess, otherwise the subprocess' input comes from the null device (@file{/dev/null} on UNIX). The optional arguments @var{program} and @var{args} define the name of the program to invoke and any arguments to pass to it. The program will be searched for in all directories listed in the @code{process-environment} variable. If any of the optional parameters are unspecified they should have been set in the @var{process-object} prior to calling this function. After successfully creating the new subprocess, this function simply copies any output from the process to the output stream defined by the output stream component of the process object. When the subprocess exits its exit-value is returned (an integer). Note that the exit-value is the value returned by the @code{process-exit-value} function, see @ref{Process Information}. If, for some reason, the new subprocess can't be created an error of type @code{process-error} is signalled. @end defun The following function definition is taken from the @file{gzip.jl} file, it shows how the @code{call-process} function can be used to uncompress a file into a buffer (for Jade). @lisp ;; Uncompress FILE-NAME into the current buffer (defun gzip-uncompress (file-name) (let ((proc (make-process (current-buffer)))) (message (concat "Uncompressing `" file-name "'") t) ;; gunzip can do .Z files as well (unless (zerop (call-process proc nil "gunzip" "-c" file-name)) (signal 'file-error (list "Can't gunzip file" file-name))))) @end lisp The user is able to interrupt synchronous subprocesses (for example if they seem to have got wedged somehow). Each time a user-interrupt is received by @code{librep} (i.e. the @code{INT} signal), a stronger signal is sent to the subprocess. First an interrupt signal, then a termination signal, before finally a non-ignoreable quit signal is sent. @node Process I/O, Process States, Synchronous Processes, Processes @subsection Process I/O @cindex Process I/O It is only possible for lisp programs to explicitly send input data to @emph{asynchronous} processes (by the time it's possible to call a function to send data to a synchronous process, the process will already have terminated!). Simply use the process object which an asynchronous process is running on as a normal Lisp input stream, any strings or characters written to the stream will immediately be copied to the @code{stdin} channel of the subprocess. With synchronous processes, the only control over input data possible is by giving the @code{call-process} function the name of a file containing the subprocess' input data. Output data from subprocesses is handled the same way by both asynchronous and synchronous processes: it is simply copied to the stream defined by the output stream component of the subprocess' process object. @defun process-output-stream process Returns the value of the output stream component of the process object @var{process}. @end defun @defun set-process-output-stream process stream Sets the value of the output stream component of the process object @var{process} to the stream @var{stream}, then returns @var{stream}. @end defun By default the @code{stdout} and @code{stderr} streams are combined, use the @code{set-process-error-stream} function to separate them. (Note that this currently only works with @code{pipe} connection types.) @defun process-error-stream process Returns the value of the error stream component of the process object @var{process}. @end defun @defun set-process-error-stream process stream Sets the value of the error stream component of the process object @var{process} to the stream @var{stream}, then returns @var{stream}. @end defun Output from asynchronous subprocesses (this includes changes of state as well as stream output) is only propagated at well-defined times. Either when in the read stage of the read-eval-print, or input, loop, or when the @code{accept-process-output} or @code{sit-for} functions are called. @defun accept-process-output @t{#!optional} seconds milliseconds Wait @var{seconds} plus @var{milliseconds} for output from any asynchronous subprocesses. If any arrives, process it, then return false. Otherwise return true. If either of the arguments is undefined, they count as zero in the addition. @end defun @defun sit-for @t{#!optional} seconds milliseconds Wait for input to arrive and be processed. No more than @var{seconds} seconds plus @var{milliseconds} milliseconds will be waited. If at the end of this time no input has arrived, return true. Otherwise return false if input was found. Note that this function is only distinct to @code{accept-process-output} when @code{librep} is embedded in another application, or an extension has been loaded that provides an event loop (such as the @code{gtk} binding). In this case other input forms, such as user input, for example, can preempt the timeout. This function is exported by the @code{rep.system} module. @end defun @xref{Streams}. @node Process States, Signalling Processes, Process I/O, Processes @subsection Process States @cindex Process states Each process object has a @dfn{state} associated with it; this depends on the status of the subprocess currently running on the process object (or not as the case may be). The possible states are, @table @dfn @item running This state means that the subprocess using this process object is currently running, i.e. it hasn't been stopped. @item stopped Means that the subprocess has been temporarily suspended from running. @item unused This means that the process object is free to have a new subprocess created on it. @end table Predicates exist which test whether a given process object is in one of these states. @defun process-running-p process-object Returns true when @var{process-object} is in the running state. @end defun @defun process-stopped-p process-object Returns true when @var{process-object} is in the stopped state. @end defun @defun process-in-use-p process-object Returns true when @var{process-object} is @emph{not} in the unused state. @end defun The following two functions are used to stop and then subsequently continue a process running. @defun stop-process process-object @t{#!optional} whole-group This function suspends execution of the subprocess running on the process object @var{process-object}. If @var{whole-group} is true all subprocesses in the process group of @var{process-object} are stopped. @end defun @defun continue-process process-object @t{#!optional} whole-group Use this function to continue a subprocess executing after it has been stopped (by the @code{stop-process} function). If @var{whole-group} is true all subprocesses in the process group of @var{process-object} are continued. @end defun The state change function component of a process object defines a function which will be called each time the state of the process object changes. If your program needs to be informed when an asynchronous process terminates this function is the way to do it. @defun process-function process Returns the value of the state change function component of the process object @var{process}. @end defun @defun set-process-function process function Sets the value of the state change function component of the process object @var{process} to the function @var{function}, then returns @var{function}. @end defun @node Signalling Processes, Process Information, Process States, Processes @subsection Signalling Processes @cindex Signalling processes @cindex Processes, signalling @defun interrupt-process process-object @t{#!optional} whole-group Sends the @code{SIGINT} signal to @var{process-object}. @end defun @defun kill-process process-object @t{#!optional} whole-group Sends the @code{SIGKILL} signal to the @var{process-object}. @end defun Note that the functions @code{stop-process} and @code{continue-process} also send signals to the subprocess. @defun signal-process process signal @t{#!optional} whole-group Send the signal @var{signal} to the process @var{process}; if @var{whole-group} is true the signal is also sent to all processes in the process group of @var{process}. @var{process} may be either a Lisp process object, or an integer defining the pid of the process to signal (not necessarily started by @code{librep}). @var{signal} may either be an integer defining the actual signal number, or a symbol naming the signal. All names are as usual but with the preceding @code{SIG} removed, for example the @code{SIGINT} signal would be sent by using the symbol @code{INT}. If a named signal doesn't exist on the current operating system, an error is raised. Returns true if the signal was sent successfully. @end defun As with the UNIX @code{kill} system call, @code{signal-process} may also be used to test whether a process with a particular pid is currently active, by using a signal with value zero. @node Process Information, , Signalling Processes, Processes @subsection Process Information @cindex Process information @defun process-id process-object This function returns the operating-system identifier associated with the subprocess currently running on the process object @var{process-object}. @end defun @defun process-exit-value process-object Returns the integer representing the return code of the last subprocess to be run on @var{process-object}. If no subprocess has been run on @var{process-object}, @var{process-object} is currently in the running state or the last subprocess exited abnormally (i.e. from a terminal signal) false is returned. @end defun @defun process-exit-status process-object This function returns the integer that was the exit status of the last subprocess which was run on the process object @var{process-object}. Note that the exit status is @emph{not} the value given to the @code{exit} function in a C program, use the @code{process-exit-value} to access this value. If no process has been run on @var{process-object}, or the process is currently in the running state false is returned. @end defun @node Regular Expressions, Time and Date, Processes, The language @section Regular Expressions @cindex Regular expressions @cindex Regexps Regular expressions (or @dfn{regexps}) are a powerful method of matching patterns in strings. @code{librep} uses the @code{regexp(3)} implementation by Henry Spencer, with some modifications that I have made. It comes with this banner: @quotation Copyright (c) 1986 by University of Toronto.@* Written by Henry Spencer. Not derived from licensed software. Permission is granted to anyone to use this software for any purpose on any computer system, and to redistribute it freely, subject to the following restrictions: @enumerate @item The author is not responsible for the consequences of use of this software, no matter how awful, even if they arise from defects in it. @item The origin of this software must not be misrepresented, either by explicit claim or by omission. @item Altered versions must be plainly marked as such, and must not be misrepresented as being the original software. @end enumerate @end quotation @menu * Regexp Syntax:: How to write regular expressions * Regexp Functions:: How to use them @end menu @node Regexp Syntax, Regexp Functions, , Regular Expressions @subsection Regular Expression Syntax @cindex Regular expression syntax @cindex Regexp syntax @cindex Syntax of regexps The syntax of a regular expression is as follows (this is adapted from the manual page): A regular expression is zero or more @dfn{branches}, separated by @samp{|}. It matches anything that matches one of the branches. A branch is zero or more @dfn{pieces}, concatenated. It matches a match for the first, followed by a match for the second, etc. A piece is an @dfn{atom} possibly followed by @samp{*}, @samp{+}, or @samp{?}. An atom followed by @samp{*} matches a sequence of 0 or more matches of the atom. An atom followed by @samp{+} matches a sequence of 1 or more matches of the atom. An atom followed by @samp{?} matches a match of the atom, or the null string. An atom is a regular expression in parentheses (matching a match for the regular expression), a @dfn{range} (see below), @samp{.} (matching any single character), @samp{^} (matching the null string at the beginning of the input string), @samp{$} (matching the null string at the end of the input string), one of the strings @samp{\s}, @samp{\S}, @samp{\w}, @samp{\W}, @samp{\d}, @samp{\D}, @samp{\b}, @samp{\B}, or a @samp{\} followed by a single character (matching that character), or a single character with no other significance (matching that character). A @dfn{range} is a sequence of characters enclosed in @samp{[]}. It normally matches any single character from the sequence. If the sequence begins with @samp{^}, it matches any single character @emph{not} from the rest of the sequence. If two characters in the sequence are separated by @samp{-}, this is shorthand for the full list of ASCII characters between them (e.g. @samp{[0-9]} matches any decimal digit). To include a literal @samp{]} in the sequence, make it the first character (following a possible @samp{^}). To include a literal @samp{-}, make it the first or last character. Also, any of the @samp{*}, @samp{+} or @samp{?} operators can be suffixed by a @samp{?} character (i.e. @samp{*?}, @samp{+?}, @samp{??}). The meaning of the operator remains the same but it becomes @dfn{non-greedy}. This means that it will match the @emph{smallest} number of characters satisfying the regular expression, instead of the default behaviour which is to match the @emph{largest}. The backslash-introduced atoms have the following meanings: @table @samp @item \s Match any whitespace character. @item \S Match any non-whitespace character. @item \w Match any alphanumeric or underscore character. @item \W Match any non-(alphanumeric or underscore) character. @item \d Match any numeric character. @item \D Match any non-numeric character. @item \b Match the null string between two adjacent @samp{\w} and @samp{\W} characters (in any order). @item \B Match the null string that is not between two adjacent @samp{\w} and @samp{\W} characters. @end table @noindent Some example legal regular expressions could be: @table @samp @item ab*a+b Matches an @samp{a} followed by zero or more @samp{b} characters, followed by one or more @samp{a} characters, followed by a @samp{b}. For example, @samp{aaab}, @samp{abbbab}, etc@dots{} @item (one|two)_three Matches @samp{one_three} or @samp{two_three}. @item ^cmd_[0-9]+ @itemx ^cmd_\d+ Matches @samp{cmd_} followed by one or more digits, it must start at the beginning of the line. @end table @node Regexp Functions, , Regexp Syntax, Regular Expressions @subsection Regexp Functions @cindex Regexp functions @cindex Matching strings @cindex String matching These functions are exported by the @code{rep.regexp} module. @defun quote-regexp string Return a version of @var{string}, such that when used as a regexp, it will match the original contents of @var{string} verbatim, and nothing else. This involves quoting regexp meta-characters. @lisp (quote-regexp "abc") @result{} "abc" (quote-regexp "a+c") @result{} "a\\+c" @end lisp @end defun @defun string-match regexp string @t{#!optional} start ignore-case Returns true if the string @var{string} matches the regular expression @var{regexp}. The string matches if executing the regexp at @emph{any} position in the string succeeds. When defined, @var{start} is the index of the first character to start matching at (counting from zero). When @var{ignore-case} is true the case of matched strings are ignored. Note that character classes are still case-significant. @lisp (string-match "ab+c" "abbbc") @result{} t (string-match "ab+c" "xxxabbbcyyy") @result{} t @end lisp @end defun @defun string-looking-at regexp string @t{#!optional} start ignore-case Similar to @code{string-match}, but only returns true if @var{string} matches @var{regexp} starting at the character at index @var{start} in the string (or the first character if @var{start} is undefined). @lisp (string-looking-at "ab+c" "abbbc" 0) @result{} t (string-looking-at "ab+c" "xxxabbbcyyy" 0) @result{} () (string-looking-at "ab+c" "xxxabbbcyyy" 3) @result{} t @end lisp @end defun @defun match-start @t{#!optional} n Returns the position at which the @var{n}'th parenthesised expression started in the last successful regexp match. If @var{n} is false or zero the position of the start of the whole match is returned instead. When matching strings, all positions are integers, with the first character in the string represented by zero. However, extensions that allow regexps to be matched against other textual inputs may return different position values. @lisp (string-match "x*(foo|bar)y" "xxxbary") @result{} t (match-start 1) @result{} 3 @end lisp @end defun @defun match-end @t{#!optional} n Similar to @code{match-start}, but returns the position of the character following the matched item. @lisp (string-match "x*(foo|bar)y" "xxxbary") @result{} t (match-end 1) @result{} 6 @end lisp @end defun A common use of regular expressions is to match a string, then replace certain portions of the string with other text. @defun expand-last-match template Expand the @var{template} substituting the parenthesised expressions from the most recent successfully matched regular expression. @var{template} may contain the following substitution-inducing escape sequences: @table @samp @item \0 @itemx \& Substitute the whole string matched by the last regexp @item \@var{n} Substitute the @var{n}'th parenthensised expression, where 1 <= N <= 9. @item \\ Substitute a single backslash character. @end table @lisp (string-match "x*(foo|bar)y" "xxxbary") @result{} t (expand-last-match "test-\\1-ing") @result{} "test-bar-ing" @end lisp Note that double backslashes are required due to the read syntax of strings (@pxref{Strings}). @end defun @defun string-replace regexp template string Returns the string created by replacing all matches of @var{regexp} in @var{string} with the result of expanding @var{template} using the @code{expand-last-match} function. @lisp (string-replace "-" "_" "foo-bar-baz") @result{} "foo_bar_baz" (string-replace "&(optional|rest)" "#!\\1" "(a &optional b &rest c)") @result{} "(a #!optional b #!rest c)" @end lisp @end defun @node Time and Date, i18n, Regular Expressions, The language @section Time and Date @cindex Time and date @cindex Date and time @cindex Calendar date and time This section describes how time and date values are handled in @code{librep}. @menu * Timestamps:: Internal representation of time * Formatting Dates:: Creating strings from timestamps * Parsing Dates:: Reading textual dates @end menu @node Timestamps, Formatting Dates, , Time and Date @subsection Timestamps @cindex Timestamps @cindex Date and time, timestamps As in UNIX, @code{librep} measures time as the number of seconds since January 1st, 1970 (known as the @dfn{epoch}). For historical reasons rep stores timestamps as a pair of integers, using a cons cell. The first integer records the number of whole days since the epoch, the second records the number of seconds since the start of the day (in universal time). These function are exported by the @code{rep.system} module: @defun current-time Return the number of seconds since the epoch, in a cons-cell. @lisp (current-time) @result{} (10744 . 61063) @end lisp @end defun @defun fix-time timestamp Ensure that the two parts of @var{timestamp} (a pair or integers) are consistent, simply that the number of seconds is less than the number of seconds in a whole day. If not, the timestamp is adjusted to meet this constraint. @end defun @defun time-later-p timestamp-1 timestamp-2 Returns true if @var{timestamp-1} is later than @var{timestamp-2}. @end defun On the plus side, this scheme won't wrap around as quickly as UNIX's @code{time_t} will ;-) The @code{rep.util.time} module also provides some functions for manipulating timestamps: @defun time->seconds timestamp Convert @var{timestamp} to an integer, the number of seconds since the epoch that it represents. @end defun @defun seconds->time seconds Convert from an integer @var{seconds} to a timestamp object. @end defun @defun time- timestamp-1 timestamp-2 Return the number of seconds difference between @var{timestamp-1} and @var{timestamp-2}. @end defun @defvr Constant seconds-per-day The number of seconds in a 24-hour day. @end defvr @node Formatting Dates, Parsing Dates, Timestamps, Time and Date @subsection Formatting Dates @cindex Formatting dates @cindex Dates, formatting as strings @cindex Time, formatting as strings Given a timestamp value it is possible to format it as a string, in many different formats. @defun current-time-string @t{#!optional} timestamp format Return a string defining @var{timestamp} according to the string @var{format}. If @var{timestamp} is undefined, the current time is used. The @var{format} string may include any of the formatting characters from the C library's @code{strftime(3)} function. If undefined a standard, fixed-width, format is used: @lisp (current-time-string) @result{} "Wed Jun 2 18:07:53 1999" @end lisp Some of the possible formatting substitutions include (this is copied from the GNU libc manual, @pxref{(libc)Formatting Date and Time}): @table @samp @item %a The abbreviated weekday name according to the current locale. @item %A The full weekday name according to the current locale. @item %b The abbreviated month name according to the current locale. @item %B The full month name according to the current locale. @item %c The preferred date and time representation for the current locale. @item %d The day of the month as a decimal number (range @code{01} to @code{31}). @item %H The hour as a decimal number, using a 24-hour clock (range @code{00} to @code{23}). @item %I The hour as a decimal number, using a 12-hour clock (range @code{01} to @code{12}). @item %j The day of the year as a decimal number (range @code{001} to @code{366}). @item %m The month as a decimal number (range @code{01} to @code{12}). @item %M The minute as a decimal number. @item %p Either @samp{am} or @samp{pm}, according to the given time value; or the corresponding strings for the current locale. @item %S The second as a decimal number. @item %U The week number of the current year as a decimal number, starting with the first Sunday as the first day of the first week. @item %W The week number of the current year as a decimal number, starting with the first Monday as the first day of the first week. @item %w The day of the week as a decimal number, Sunday being @code{0}. @item %x The preferred date representation for the current locale, but without the time. @item %X The preferred time representation for the current locale, but with no date. @item %y The year as a decimal number, but without a century (range @code{00} to @code{99}). @item %Y The year as a decimal number, including the century. @item %Z The time zone or name or abbreviation (empty if the time zone can't be determined). @item %% A literal @samp{%} character. @end table @lisp (current-time-string nil "%Y-%m-%d") @result{} "1999-06-02" @end lisp @end defun @node Parsing Dates, , Formatting Dates, Time and Date @subsection Parsing Dates @cindex Parsing dates @cindex Dates, parsing @cindex Time, parsing The @code{date} Lisp library provides rudimentary support for parsing date and time descriptions to their individual components, and to timestamps. Evaluate the form @code{(require 'date)} to load this library. @defun parse-date string @t{#!optional} start Returns a vector encoding the date described by @var{string}. If @var{start} is defined, it specifies the index of the character in the string to start parsing from. Each element of the vector contains a separate component of the overall point in time described by the string. The indices of these elements are defined by the following constants: @table @code @item date-vec-day-abbrev @vindex date-vec-day-abbrev The abbreviated name of the day of the week. @item date-vec-day @vindex date-vec-day The numeric day of the month, counting from one. @item date-vec-month-abbrev @vindex date-vec-month-abbrev The abbreviated name of the month. @item date-vec-month @vindex date-vec-month The numeric month of the year, counting from January equals one. @item date-vec-year @vindex date-vec-year The numeric year. @item date-vec-hour @vindex date-vec-hour The numeric hour of the day. @item date-vec-minute @vindex date-vec-minute The numeric minute of the hour. @item date-vec-second @vindex date-vec-second The numeric second of the minute. @item date-vec-timezone @vindex date-vec-timezone If true, a string defining the timezone. @item date-vec-epoch-time @vindex date-vec-epoch-time The timestamp (@pxref{Timestamps}), including the effects of the timezone, if given. @end table @lisp (current-time-string) @result{} "Wed Jun 2 18:37:17 1999" (parse-date (current-time-string)) @result{} ["Wed" 2 "Jun" 6 1999 18 37 17 0 (10744 . 67037)] (parse-date "1999-06-02") @result{} ["Tue" 2 "Jun" 6 1999 0 0 0 0 (10744 . 0)] (parse-date "June 6, 1999") @result{} ["" 0 "Jun" 6 1999 0 0 0 0 (10742 . 0)] (aref (parse-date "June 6, 1999") date-vec-epoch-time) @result{} (10742 . 0) @end lisp @end defun XXX provide more information on accepted formats, outputs for incomplete descriptions, etc@dots{} @node i18n, System Information, Time and Date, The language @section Internationalisation @cindex Internationalisation @code{librep} has support for internationalisation (or i18n) of text messages, using the GNU @code{gettext} implementation (@pxref{Top, , Overview, gettext, The GNU gettext Manual}), a run-time library managing the mapping between text strings in the programmer's native language and in the language of the end user. Three functions are provided to access the message catalogues maintained by GNU @code{gettext}. Import the @code{rep.i18n.gettext} module to load them. @defun _ string Attempt to find a native language equivalent of @var{string}. If no equivalent is found the original string is returned. Note that this function is always defined, even if the @code{gettext} module hasn't been required. In this case it always returns the original string. @end defun @defun bindtextdomain domain directory Tell @code{gettext} that message catalogues for message domain @var{domain} (a string) can be found under the directory called @var{directory}. @end defun @defun textdomain domain Note that any strings that are to be translated in the future (until the next call to @code{textdomain}) are in the domain called @var{domain} (a string). @end defun The usual method of constructing message catalogue templates (@file{.pot} files) is to run @code{xgettext} on the C source files of the program (that have been annotated for i18n). librep provides the @code{rep-xgettext} program to perform the same task for files of Lisp code. @node System Information, User Information, i18n, The language @section System Information @cindex System information These definitions are all exported by the @code{rep.system} module. @defvar operating-system A symbol naming the current operating system. The only current option is @code{unix}. @end defvar @defun system-name This function returns a string naming the host that the interpreter is running on. When possible this be a fully-qualified name (i.e. including the domain) @end defun @defvar rep-build-id A string describing the environment under which @code{librep} was built. This will always have the format @samp{@var{date} by @var{user}@@@var{host}, for @var{arch}.}. @lisp rep-build-id @result{} "Mon May 17 1999 by john@@tizer.dcs.warwick.ac.uk, for sparc-sun-solaris2.6." @end lisp @end defvar @defvar rep-version A string describing the current release of @code{librep}. @lisp rep-version @result{} "1.0" @end lisp @end defvar @node User Information, Environment Variables, System Information, The language @section User Information @cindex User information These functions are exported by the @code{rep.system} module. @defun user-login-name This function returns a string containing the login name of the user. @lisp (user-login-name) @result{} "john" @end lisp @end defun @defun user-full-name @t{#!optional} real-name This function returns a string containing the `real' name of the user; the format of the string will depend on the host system. If @var{real-name} is a string, it defines the name that will be returned by subsequent calls to this function. @lisp (user-full-name) @result{} "John Harper" @end lisp @end defun @defun user-home-directory @t{#!optional} user This function returns the home directory of the user whose login name is @var{user}, or the current user if @var{user} is undefined. The returned string will be as returned by @code{file-name-as-directory} (i.e. terminated by a @samp{/} character under UNIX) @lisp (user-home-directory) @result{} "/home/john/" @end lisp @end defun @node Environment Variables, String Functions, User Information, The language @section Environment Variables @cindex Environment variables These functions are exported by the @code{rep.system} module. @defun getenv variable-name This function returns the value (a string) of the environment variable called @var{variable-name}. If the specified variable doesn't exist false is returned. @lisp (getenv "OSTYPE") @result{} "Linux" @end lisp @end defun @defun setenv variable-name new-value This function sets the value of the environment variable called @var{variable-name} to @var{new-value}. @var{new-value} can either be a string containing the new contents of the variable or false, in which case the environment variable is deleted. @end defun @defun unsetenv variable-name Deletes any variable in @code{process-environment} named @var{variable-name}. @end defun See also @ref{Process Objects} for the description of the @code{process-environment} variable. @node String Functions, utf-8, Environment Variables, The language @section String Functions @cindex String functions @defun translate-string string map Applies the @var{map} to each character in the @var{string}. @var{map} is also string, each character represents the translation for an ASCII character of that characters position in the string. If the string is less than 256 chars long any undefined characters will remain unchanged. For example, if @var{string} contains the character @samp{A}, with ASCII code 65, then it would be replaced by the 65th character in the string @var{map}. Note that the @var{string} really is modified, no copy is made @end defun @defvar upcase-table A @code{translate-string} compatible translation map to convert lowercase characters to uppercase characters. @end defvar @defvar downcase-table A map to convert uppercase characters to lowercase. @end defvar @defvar flatten-table A translation map to convert newline characters to spaces. @end defvar @lisp (translate-string "Foo" upcase-table) @result{} "FOO" (translate-string "Foo" downcase-table) @result{} "foo" @end lisp @defun complete-string template list @t{#!optional} ignore-case Return a string whose beginning matches the string @var{template}, and is unique in the set of all strings in @var{list} which also match @var{template}. If @var{ignore-case} is true, all matching ignores case of characters. @lisp (complete-string "foo" '("bar" "foobar" "forbarf" "foobat")) @result{} "fooba" @end lisp @end defun @defun string-head-eq string-1 string-2 Returns t if @var{string-2} matches the beginning of @var{string-1}. @lisp (string-head-eq "foobar" "foo") @result{} t (string-head-eq "foo" "foobar") @result{} () @end lisp @end defun @defun string-upper-case-p string Return true if @var{string} contains no lower case characters. @end defun @defun string-lower-case-p string Return true if @var{string} contains no upper case characters. @end defun @defun string-capitalized-p string Return true if the first character of @var{string} is upper case. @end defun @defun string-upcase string Return a new string, an upper case copy of @var{string}. @end defun @defun string-downcase string Return a new string, a lower case copy of @var{string}. @end defun @defun capitalize-string string Return a new string, a copy of @var{string} with the first character in upper case. @end defun @defun mapconcat function sequence separator Call @var{function} for each member of @var{sequence}, concatenating the results. Between each pair of results, insert @var{separator}. Return the resulting string. @end defun @defun string->number string &optional radix Return the number represented by @var{string}. If @var{radix} is specified, the number is parsed from that base, otherwise base 10 is assumed. @end defun @defun number->string num &optional radix Return a string containing a printed representation of the number @var{num}. If @var{radix} is specified, print the number in that base, otherwise print it in base 10. @end defun @node utf-8, Sleeping, String Functions, The language @section utf-8 @cindex utf-8 Some functions for utf-8 strings are available. They assume that the string is encoded in utf-8. Otherwise, the behavior is not defined. @defun utf8-string-length string Returns the number of characters of utf-8 encoded @var{string}. @end defun @defun utf8-substring string start @t{#!optional} end Returns the portion of @var{string}, encoded in utf-8, starting at character number @var{start} and ending at the character before @var{end} (or the end of the string if @var{end} is not given). All indices start at zero. @end defun @node Sleeping, Beeping, utf-8, The language @section Sleeping @cindex Sleeping @defun sleep-for seconds @t{#!optional} milliseconds Pause for a @var{seconds} (plus the optional @var{milliseconds} component) long period of time. Input becoming available will @emph{not} break the sleep (@pxref{Process I/O}). This function is exported by the @code{rep.system} module. @end defun @node Beeping, Messages, Sleeping, The language @section Beeping @cindex Beeping Use this function to attract the user's attention. @defun beep Ring a bell somewhere. @end defun @node Messages, Command Line Options, Beeping, The language @section Messages @cindex Messages The @code{message} function will show the user a small message (typically no more than a single column of text). In graphical applications it @emph{won't} bring up a separate window, only displaying the text in a status bar or something similar. In a console-based environment, the message will be printed to the @code{stderr} stream, followed by a line break. @defun message @t{#!optional} display-now Displays a one-line message, the string @var{message}. If @var{display-now}, every effort will be made to display the message as soon as possible, possibly before the next scheduled screen update (if applicable). This function is exported by the @code{rep.system} module. @end defun @node Command Line Options, Shell Commands, Messages, The language @section Command Line Options @cindex Command line options @cindex Options, command line @cindex Arguments, command line As noted earlier any unused command line arguments are made available to scripts through the @code{command-line-args} variable (@pxref{Invocation}). @defvar command-line-args The list of unused command line arguments, in their original order. @end defvar The @code{get-command-line-option} function may be used to scan this list of arguments. The @code{rep.system} module exports this function. @defun get-command-line-option option @t{#!optional} requires-arg Returns t if @var{option} was specified on the command line (@var{option} is typically a phrase beginning with @samp{--}). If @var{requires-arg} is true, the option requires a parameter, the value of which is returned. If a parameter isn't supplied an error is signalled. @end defun @lisp (setq command-line-args '("--foo" "bar")) @result{} ("--foo" "bar") (get-command-line-option "--foo" t) @result{} "bar" command-line-args @result{} () (setq command-line-args '("--foo=bar")) @result{} ("--foo=bar") (get-command-line-option "--foo" t) @result{} "bar" command-line-args @result{} () @end lisp @node Shell Commands, Timers, Command Line Options, The language @section Executing Shell Commands @cindex Executing shell commands @cindex Shell commands, executing The subprocess handling of @code{librep} provides a comprehensive interface to starting and controlling external processes (@pxref{Processes}). However it can be overkill when all that is required is to invoke a shell command, with its I/O going to the same places as the interpreter's. @defun system command Execute the shell command @var{command} synchronously, returning its exit status. An error will be signalled if the shell process could not be started. The @code{stdin}, @code{stdout} and @code{stderr} streams of the shell are left as in the interpreter process. The subprocesses environment is copied from the current value of the @code{process-environment} variable. @end defun Note that the exit status is @emph{not} the same as the return code of the command. It depends on the operating system, but under UNIX the return code can be found through right-shifting the exit status by eight bits. Low non-zero values represent that the process was killed by a signal. It is possible to interrupt a running shell process in the same way as with a normal synchronous process (@pxref{Synchronous Processes}). Interrupt the interpreter, it will send progressively harder-to-ignore signals to the child each interrupt, until it is eventually terminated. @node Timers, Debugging, Shell Commands, The language @section Asynchronous Timers @cindex Asynchronous timers @cindex Timers, asynchronous The @code{rep.io.timers} module (@pxref{Modules}) allows a Lisp program to create multiple asynchronous timers, each of which is primed to call a specified function after a specified period of time. These functions only work when the Lisp event loop is being used (i.e. at least one @code{recursive-edit} is currently in progress). @defun make-timer function @t{#!optional} seconds milliseconds Create and return a new timer object. It will be set to call the Lisp function @var{function} after @var{seconds} seconds plus @var{milliseconds} milliseconds. @var{function} will be called with a single argument, the timer object that has just fired. If both @var{seconds} and @var{milliseconds} are undefined, or zero, the timer will be created but won't call @var{function}. After the time interval has passed, and @var{function} has been called, the timer @emph{will not} be restarted. Use the @code{set-timer} function to reset it. @end defun @defun delete-timer timer Prevent the timer object @var{timer} from calling the Lisp function associated with it. Use the @code{set-timer} function to reset it. @end defun @defun set-timer timer @t{#!optional} seconds milliseconds Reset the timer object @var{timer}. If either/both of @var{seconds} and @var{milliseconds} are defined the interval of the timer will be set to the specified time period. If neither are defined then the current interval of the timer is preserved. @end defun @node Debugging, Tips, Timers, The language @section Debugging @cindex Debugging When you have written a Lisp program you will have to debug it (unless all your programs work first time?). There are two main classes of errors; syntax errors and semantic errors. Syntax errors occur when the text you've typed out to represent your program is not a valid representation of a Lisp object (since a program is simply an ordered set of Lisp objects). When you try to load your program the Lisp reader will find the syntax error and tell you about, unfortunately though it probably won't be able to tell you exactly where the error is. The most common source of syntax errors is too few or too many parentheses; the Jade or Emacs @kbd{Ctrl-Meta-f} and @kbd{Ctrl-Meta-b} commands can be used to show the structure of the program as the Lisp reader sees it. Semantic errors are what we normally call bugs---errors in logic, the program is syntactically correct but doesn't do what you want it to. For these types of errors librep provides hooks to allow interactive debugging. The debugger supplied with librep uses these hooks to implement a simple command line debugger; programs using librep as an extension language may provide their own debugger interface. There are several ways to enter the Lisp debugger; functions can be marked so that they cause the debugger to be entered when they are called, breakpoints can be written in functions or it can be called explicitly with a form to step through. @deffn Command trace symbol This command marks the symbol @var{symbol} so that each time its value is dereferenced the debugger is entered when the next form is evaluated. This can be used to set breakpoints on functions (or variables). When called interactively @var{symbol} is prompted for. @end deffn @deffn Command untrace symbol The opposite of @code{trace}---unmarks the symbol. @end deffn @defun break This function causes the debugger to be entered immediately. By putting the form @code{(break)} at suitable points in your program simple breakpoints can be created. @end defun @deffn Command step form This function invokes the debugger to step through the form @var{form}. When called interactively @var{form} is prompted for. @end deffn @defun backtrace @t{#!optional} stream Prints a description of the current Lisp function call stack to @var{stream} (or @code{standard-output} if @var{stream} is undefined). @lisp (backtrace (current-buffer)) @print{} # ((current-buffer)) nil @print{} # ((backtrace (current-buffer))) t @result{} t @end lisp Each line represents a stack frame, the first item is the called function, the second is the list of arguments applied to it. The third item is true if the list of arguments as displayed has already been evaluated. @end defun Whenever the Lisp debugger is entered the form waiting to be evaluated is printed, preceded by the current depth of execution in angular brackets. At this point the special debugger commands available are, @table @samp @item step @itemx s Step into the current form; this means that in a list form the debugger is used to evaluated each argument in turn. @item next @itemx n Continue evaluating forms normally until the next form at the current level is entered, then re-enter the debugger. @item continue @itemx c Continue execution normally. Note that this command is the one to use when an error has been trapped. @item return @var{form} @itemx r @var{form} Evaluate @var{form} then return this value as the result of the current form. @item print @var{form} @itemx p @var{form} Evaluate @var{form}, then print its value. @item form @itemx f Print the form being debugged. @item backtrace @itemx b Print a backtrace of the current Lisp call stack. @end table Entering a null string repeats the previous @samp{next}, @samp{step}, or @samp{continue} command. After the form has been evaluated (i.e. after you've typed one of the commands above) the value of the form is printed in the buffer, prefixed by the string @samp{=> }. Note that it is also possible to make certain types of errors invoke the debugger immediately they are signalled, see @ref{Errors}. Also note that the debugger is unable to step through compiled Lisp code. @node Tips, , Debugging, The language @section Tips @cindex Tips This section of the manual gives advice about programming in @code{librep}. For advice on getting the most out of the compiler, see @ref{Compilation Tips}. @menu * Comment Styles:: Different types of comments @end menu @node Comment Styles, , , Tips @subsection Comment Styles @cindex Comment styles @cindex Tips, comment styles @cindex Style, comments As already described, single-line comments in Lisp are introduced by a semi-colon (@samp{;}) character. By convention a different number of semi-colons is used to introduce different types of comments, @table @samp @item ; A comment referring to the line of Lisp code that it occurs on, comments of this type are usually indented to the same depth, on the right of the Lisp code. When editing in Jade's Lisp mode the command @kbd{Meta-;} can be used to insert a comment of this type. For example, @lisp (defconst op-call #x08) ;call (stk[n] stk[n-1] ... stk[0]) ; pops n values, replacing the ; function with the result. (defconst op-push #x10) ;pushes constant # n @end lisp @item ;; Comments starting with two semi-colons are written on a line of their own and indented to the same depth as the next line of Lisp code. They describe the following lines of code. For example, @lisp (let ((fname (concat file-name ?c))) ;; Be sure to remove any partially written dst-file. (when (file-exists-p fname) (delete-file fname))) @end lisp Comments of this type are also placed before a function definition to describe the function. This saves wasting memory with a documentation string in a module's internal functions. For example, @lisp ;; Compile a form which occurred at the `top-level' into a ;; byte code form. ;; defuns, defmacros, defvars, etc... are treated specially. ;; require forms are evaluated before being output uncompiled; ;; this is so any macros are brought in before they're used. (defun comp-compile-top-form (form) @dots{} @end lisp @item ;;; This type of comment always starts in the first column of the line, they are used to make general comments about a program and don't refer to any function or piece of code in particular. For example, @lisp ;;; Notes: ;;; Instruction Encoding ;;; ==================== ;;; Instructions which get an argument (with opcodes of zero up to @dots{} @end lisp @item ;;;; Each program should have a comment of this type as its first line, the body of the comment is the name of the file, two dashes and a brief description of what the program does. They always start in the first column. For example, @lisp ;;;; compiler.jl -- Simple compiler for Lisp files/forms @end lisp @end table If you adhere to these standards the indentation functions provide by the Lisp mode will indent your comments to the correct depth. librep-0.90.2/man/interface.texi0000644000175200017520000000340511245011153015466 0ustar chrischris@c -*-Texinfo-*- @chapter librep Internals @cindex librep Internals @cindex Embedding librep @cindex Interface, C @cindex librep internals @cindex Internals This chapter will document the internals of @code{librep}, including how to embed the interpreter into general applications, and how to write dynamically-loadable C libraries. Unfortunately most of it hasn't been written. As always, the best reference is the source, Luke! @menu * Intro To Internals:: * Data Type Representation:: * Garbage Collection Internals:: * Defining Lisp Subrs:: * Useful Functions:: * Shared Libraries:: @end menu @node Intro To Internals, Data Type Representation, , librep Internals @section Introduction To librep Internals @cindex Introduction to librep internals @cindex Internals, introduction to @node Data Type Representation, Garbage Collection Internals, Intro To Internals, librep Internals @section Data Type Representation @cindex Data type representation @cindex Representation of data types @cindex Internals, data types @node Garbage Collection Internals, Defining Lisp Subrs, Data Type Representation, librep Internals @section Garbage Collection Internals @cindex Garbage collection internals @cindex Internals, garbage collection @node Defining Lisp Subrs, Useful Functions, Garbage Collection Internals, librep Internals @section Defining Lisp Subrs @cindex Defining lisp subrs @cindex Subrs, defining @cindex Internals, defining subrs @node Useful Functions, Shared Libraries, Defining Lisp Subrs, librep Internals @section Useful Functions @cindex Useful functions @cindex Internals, useful functions @node Shared Libraries, , Useful Functions, librep Internals @section Shared Libraries @cindex Shared libraries @cindex Dynamically loaded libraries @cindex Libraries, shared librep-0.90.2/man/Makefile.in0000644000175200017520000000350111245011153014675 0ustar chrischris# Makefile.in for Jade's Texinfo manual # Copyright (C) 1998 John Harper # $Id$ # # This file is part of Jade. # # Jade is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # Jade is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Jade; see the file COPYING. If not, write to # the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. top_srcdir=@top_srcdir@ srcdir=@srcdir@ VPATH=@srcdir@:@top_srcdir@ SRCS = librep.texi lang.texi repl.texi news.texi interface.texi all : librep.info ../NEWS ../NEWS : news.texi $(MAKEINFO) $(MAKEINFOFLAGS) --no-headers $< -o ../NEWS librep.info : $(SRCS) $(MAKEINFO) $(MAKEINFOFLAGS) -I $(srcdir) $< -o librep.info librep.html : $(SRCS) $(MAKEINFO) $(MAKEINFOFLAGS) --html -I $(srcdir) $< -o librep.html librep.dvi : $(SRCS) $(TEXI2DVI) -I $(srcdir) $< librep.ps : librep.dvi $(DVIPS) -f librep.ps librep.pdf : $(SRCS) $(TEXI2PDF) -I $(srcdir) $< install : librep.info installdirs for f in librep.info*; do \ $(INSTALL_DATA) $$f $(DESTDIR)$(infodir); \ done -install-info --info-dir=$(DESTDIR)$(infodir) librep.info installdirs : mkinstalldirs $(SHELL) $< $(DESTDIR)$(infodir) uninstall : rm -f $(DESTDIR)$(infodir)/librep.info* -install-info --remove --info-dir=$(DESTDIR)$(infodir) librep.info clean : rm -f *~ librep.info* librep.?? librep.??? distclean : clean rm -f Makefile realclean : distclean check : librep-0.90.2/src/weak-refs.c0000644000175200017520000000520311245011153014675 0ustar chrischris/* weak-refs.c -- Copyright (C) 2001 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #define WEAKP(x) rep_CELL16_TYPEP(x, weak_ref_type ()) #define WEAK(v) ((rep_tuple *) rep_PTR (v)) #define WEAK_NEXT(v) (WEAK(v)->a) #define WEAK_REF(v) (WEAK(v)->b) static repv weak_refs; static int weak_ref_type (void); DEFUN ("make-weak-ref", Fmake_weak_ref, Smake_weak_ref, (repv ref), rep_Subr1) { repv weak_ref; weak_ref = rep_make_tuple (weak_ref_type (), rep_NULL, rep_NULL); WEAK_REF (weak_ref) = ref; WEAK_NEXT (weak_ref) = weak_refs; weak_refs = weak_ref; return weak_ref; } DEFUN ("weak-ref", Fweak_ref, Sweak_ref, (repv weak), rep_Subr1) { rep_DECLARE1 (weak, WEAKP); return WEAK_REF (weak); } DEFUN ("weak-ref-set", Fweak_ref_set, Sweak_ref_set, (repv weak, repv value), rep_Subr2) { rep_DECLARE1 (weak, WEAKP); WEAK_REF (weak) = value; return value; } void rep_scan_weak_refs (void) { repv ref = weak_refs; weak_refs = rep_NULL; while (ref != rep_NULL) { repv next = WEAK_NEXT (ref); if (rep_GC_CELL_MARKEDP (ref)) { /* this ref wasn't gc'd */ WEAK_NEXT (ref) = weak_refs; weak_refs = ref; if (rep_CELLP (WEAK_REF (ref)) && !rep_GC_MARKEDP (WEAK_REF (ref))) { /* but the object it points to was */ WEAK_REF (ref) = Qnil; } } ref = next; } } static void weak_ref_print (repv stream, repv arg) { rep_stream_puts (stream, "#", -1, rep_FALSE); } static int weak_ref_type (void) { static int type; if (type == 0) { type = rep_register_new_type ("weak-ref", rep_ptr_cmp, weak_ref_print, weak_ref_print, 0, 0, 0, 0, 0, 0, 0, 0, 0); } return type; } void rep_weak_refs_init (void) { repv tem = rep_push_structure ("rep.data"); rep_ADD_SUBR(Smake_weak_ref); rep_ADD_SUBR(Sweak_ref); rep_ADD_SUBR(Sweak_ref_set); rep_pop_structure (tem); } librep-0.90.2/src/values.c0000644000175200017520000006660011245011153014320 0ustar chrischris/* values.c -- Handling of Lisp data (includes garbage collection) Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include #include #ifdef NEED_MEMORY_H # include #endif /* #define GC_MONITOR_STK */ #define rep_STRINGBLK_SIZE 510 /* ~4k */ /* Structure of string header allocation blocks */ typedef struct rep_string_block_struct { union { struct rep_string_block_struct *p; /* ensure that the following cons cell is aligned to at least sizeof (rep_string) (for the dcache) */ rep_string dummy; } next; rep_string data[rep_STRINGBLK_SIZE]; } rep_string_block; /* Dumped data */ rep_cons *rep_dumped_cons_start, *rep_dumped_cons_end; rep_symbol *rep_dumped_symbols_start, *rep_dumped_symbols_end; repv rep_dumped_non_constants; int rep_guardian_type; DEFSYM(after_gc_hook, "after-gc-hook"); /* Type handling */ #define TYPE_HASH_SIZE 32 #define TYPE_HASH(type) (((type) >> 1) & (TYPE_HASH_SIZE-1)) static unsigned int next_free_type = 0; static rep_type *data_types[TYPE_HASH_SIZE]; void rep_register_type(unsigned int code, char *name, int (*compare)(repv, repv), void (*princ)(repv, repv), void (*print)(repv, repv), void (*sweep)(void), void (*mark)(repv), void (*mark_type)(void), int (*getc)(repv), int (*ungetc)(repv, int), int (*putc)(repv, int), int (*puts)(repv, void *, int, rep_bool), repv (*bind)(repv), void (*unbind)(repv)) { rep_type *t = rep_alloc(sizeof(rep_type)); if (t == 0) { rep_mem_error (); return; } t->code = code; t->name = name; t->compare = compare ? compare : rep_ptr_cmp; t->princ = princ; t->print = print; t->sweep = sweep; t->mark = mark; t->mark_type = mark_type; t->getc = getc; t->ungetc = ungetc; t->putc = putc; t->puts = puts; t->bind = bind; t->unbind = unbind; t->next = data_types[TYPE_HASH(code)]; data_types[TYPE_HASH(code)] = t; } unsigned int rep_register_new_type(char *name, int (*compare)(repv, repv), void (*princ)(repv, repv), void (*print)(repv, repv), void (*sweep)(void), void (*mark)(repv), void (*mark_type)(void), int (*getc)(repv), int (*ungetc)(repv, int), int (*putc)(repv, int), int (*puts)(repv, void *, int, rep_bool), repv (*bind)(repv), void (*unbind)(repv)) { unsigned int code; assert(next_free_type != 256); code = (next_free_type++ << rep_CELL16_TYPE_SHIFT) | rep_CELL_IS_8 | rep_CELL_IS_16; rep_register_type(code, name, compare, princ, print, sweep, mark, mark_type, getc, ungetc, putc, puts, bind, unbind); return code; } rep_type * rep_get_data_type(unsigned int code) { rep_type *t = data_types[TYPE_HASH(code)]; while (t != 0 && t->code != code) t = t->next; assert (t != 0); return t; } /* General object handling */ /* Returns zero if V1 == V2, less than zero if V1 < V2, and greater than zero otherwise. */ int rep_value_cmp(repv v1, repv v2) { if(v1 != rep_NULL && v2 != rep_NULL) { rep_type *t1 = rep_get_data_type(rep_TYPE(v1)); if (t1 != 0) return (v1 == v2) ? 0 : t1->compare(v1, v2); else return (v1 == v2) ? 0 : 1; } return 1; } void rep_princ_val(repv strm, repv val) { if(val != rep_NULL) { rep_type *t = rep_get_data_type(rep_TYPE(val)); rep_GC_root gc_strm, gc_val; rep_PUSHGC(gc_strm, strm); rep_PUSHGC(gc_val, val); t->princ(strm, val); rep_POPGC; rep_POPGC; } } void rep_print_val(repv strm, repv val) { if(val != rep_NULL) { rep_type *t = rep_get_data_type(rep_TYPE(val)); rep_GC_root gc_strm, gc_val; rep_PUSHGC(gc_strm, strm); rep_PUSHGC(gc_val, val); t->print(strm, val); rep_POPGC; rep_POPGC; } } int rep_type_cmp(repv val1, repv val2) { return !(rep_TYPE(val1) == rep_TYPE(val2)); } /* Strings */ static rep_string_block *string_block_chain; static rep_string *string_freelist; static int allocated_strings, used_strings, allocated_string_bytes; DEFSTRING(null_string_const, ""); repv rep_null_string(void) { return rep_VAL(&null_string_const); } DEFSTRING(string_overflow, "String too long"); /* PTR should have been allocated using rep_alloc or malloc. Ownership of its memory passes to the lisp system. LEN _doesn't_ include the zero terminator */ repv rep_box_string (char *ptr, long len) { rep_string *str; if(len > rep_MAX_STRING) return Fsignal(Qerror, rep_LIST_1(rep_VAL(&string_overflow))); /* find a string header */ str = string_freelist; if(str == NULL) { rep_string_block *cb; cb = rep_alloc(sizeof(rep_string_block)); if(cb != NULL) { int i; allocated_strings += rep_STRINGBLK_SIZE; cb->next.p = string_block_chain; string_block_chain = cb; for(i = 0; i < (rep_STRINGBLK_SIZE - 1); i++) cb->data[i].car = rep_VAL(&cb->data[i + 1]); cb->data[i].car = 0; string_freelist = cb->data; } else return rep_mem_error (); str = string_freelist; } string_freelist = rep_STRING(str->car); used_strings++; rep_data_after_gc += sizeof(rep_string); str->car = rep_MAKE_STRING_CAR (len); rep_data_after_gc += len; str->data = ptr; return rep_VAL (str); } /* Return a string object with room for exactly LEN characters. No extra byte is allocated for a zero terminator; do this manually if required. */ repv rep_make_string(long len) { char *data = rep_alloc (len); if(data != NULL) return rep_box_string (data, len - 1); else return rep_NULL; } repv rep_string_dupn(const char *src, long slen) { rep_string *dst = rep_STRING(rep_make_string(slen + 1)); if(dst != NULL) { memcpy(rep_STR(dst), src, slen); rep_STR(dst)[slen] = 0; } return rep_VAL(dst); } repv rep_string_dup(const char *src) { return rep_string_dupn(src, strlen(src)); } repv rep_concat2(char *s1, char *s2) { int len = strlen(s1) + strlen(s2); repv res = rep_make_string(len + 1); stpcpy(stpcpy(rep_STR(res), s1), s2); return(res); } repv rep_concat3(char *s1, char *s2, char *s3) { int len = strlen(s1) + strlen(s2) + strlen(s3); repv res = rep_make_string(len + 1); stpcpy(stpcpy(stpcpy(rep_STR(res), s1), s2), s3); return(res); } repv rep_concat4(char *s1, char *s2, char *s3, char *s4) { int len = strlen(s1) + strlen(s2) + strlen(s3) + strlen(s4); repv res = rep_make_string(len + 1); stpcpy(stpcpy(stpcpy(stpcpy(rep_STR(res), s1), s2), s3), s4); return(res); } static int string_cmp(repv v1, repv v2) { if(rep_STRINGP(v1) && rep_STRINGP(v2)) { long len1 = rep_STRING_LEN(v1); long len2 = rep_STRING_LEN(v2); long tem = memcmp(rep_STR(v1), rep_STR(v2), MIN(len1, len2)); return tem != 0 ? tem : (len1 - len2); } else return 1; } static void string_sweep(void) { rep_string_block *cb = string_block_chain; string_block_chain = NULL; string_freelist = NULL; used_strings = 0; allocated_string_bytes = 0; while(cb != NULL) { rep_string_block *nxt = cb->next.p; rep_string *newfree = NULL, *newfreetail = NULL, *this; int i, newused = 0; for(i = 0, this = cb->data; i < rep_STRINGBLK_SIZE; i++, this++) { /* if on the freelist then the CELL_IS_8 bit will be unset (since the pointer is long aligned) */ if(rep_CELL_CONS_P(rep_VAL(this)) || !rep_GC_CELL_MARKEDP(rep_VAL(this))) { if(!newfreetail) newfreetail = this; if (!rep_CELL_CONS_P(rep_VAL(this))) rep_free (this->data); this->car = rep_VAL(newfree); newfree = this; } else { rep_GC_CLR_CELL(rep_VAL(this)); allocated_string_bytes += rep_STRING_LEN(rep_VAL(this)); newused++; } } if(newused == 0) { /* Whole block is unused, get rid of it. */ rep_free(cb); allocated_strings -= rep_STRINGBLK_SIZE; } else { if(newfreetail != NULL) { /* Link this mini-freelist onto the main one. */ newfreetail->car = rep_VAL(string_freelist); string_freelist = newfree; used_strings += newused; } /* Have to rebuild the block chain as well. */ cb->next.p = string_block_chain; string_block_chain = cb; } cb = nxt; } } /* Sets the length-field of the dynamic string STR to LEN. */ rep_bool rep_set_string_len(repv str, long len) { if(rep_STRING_WRITABLE_P(str)) { rep_STRING(str)->car = rep_MAKE_STRING_CAR(len); return rep_TRUE; } else return rep_FALSE; } /* Misc */ int rep_ptr_cmp(repv v1, repv v2) { if(rep_TYPE(v1) == rep_TYPE(v2)) return !(rep_PTR(v1) == rep_PTR(v2)); else return 1; } repv rep_box_pointer (void *p) { unsigned rep_PTR_SIZED_INT low; low = (unsigned rep_PTR_SIZED_INT)p; if (low <= rep_LISP_MAX_INT) return rep_MAKE_INT (low); else { int i; unsigned rep_PTR_SIZED_INT high = (unsigned rep_PTR_SIZED_INT)p; for (i = rep_PTR_SIZED_INT_BITS / 2; i < rep_PTR_SIZED_INT_BITS; i++) low &= ~(1 << i); high = high >> (rep_PTR_SIZED_INT_BITS/2); return Fcons (rep_MAKE_INT(high), rep_MAKE_INT(low)); } } void * rep_unbox_pointer (repv v) { if (rep_INTP(v)) return (void *) rep_INT(v); else if (rep_CONSP(v)) { unsigned rep_PTR_SIZED_INT low, high; low = rep_INT(rep_CDR(v)); high = rep_INT(rep_CAR(v)); return (void *) (low | high << (rep_PTR_SIZED_INT_BITS/2)); } else return 0; } /* Cons */ rep_cons_block *rep_cons_block_chain; rep_cons *rep_cons_freelist; int rep_allocated_cons, rep_used_cons; rep_cons * rep_allocate_cons (void) { rep_cons *cn; cn = rep_cons_freelist; if(cn == NULL) { rep_cons_block *cb; cb = rep_alloc(sizeof(rep_cons_block)); if(cb != NULL) { int i; rep_allocated_cons += rep_CONSBLK_SIZE; cb->next.p = rep_cons_block_chain; rep_cons_block_chain = cb; for(i = 0; i < (rep_CONSBLK_SIZE - 1); i++) cb->cons[i].cdr = rep_CONS_VAL(&cb->cons[i + 1]); cb->cons[i].cdr = 0; rep_cons_freelist = cb->cons; } else return rep_CONS (rep_mem_error ()); cn = rep_cons_freelist; } return cn; } DEFUN("cons", Fcons, Scons, (repv car, repv cdr), rep_Subr2) /* ::doc:rep.data#cons:: cons CAR CDR Returns a new cons-cell with car CAR and cdr CDR. ::end:: */ { rep_cons *c = rep_cons_freelist; if (c == 0) c = rep_allocate_cons (); rep_cons_freelist = rep_CONS (c->cdr); rep_used_cons++; rep_data_after_gc += sizeof(rep_cons); c->car = car; c->cdr = cdr; return rep_CONS_VAL (c); } void rep_cons_free(repv cn) { rep_CDR(cn) = rep_CONS_VAL(rep_cons_freelist); rep_cons_freelist = rep_CONS(cn); rep_used_cons--; } static void cons_sweep(void) { rep_cons_block *cb; rep_cons *tem_freelist = 0; int tem_used = 0; for (cb = rep_cons_block_chain; cb != 0; cb = cb->next.p) { register rep_cons *this = cb->cons; rep_cons *last = cb->cons + rep_CONSBLK_SIZE; while (this < last) { if (!rep_GC_CONS_MARKEDP (rep_CONS_VAL (this))) { this->cdr = rep_CONS_VAL (tem_freelist); tem_freelist = rep_CONS (this); } else { rep_GC_CLR_CONS (rep_CONS_VAL (this)); tem_used++; } this++; } } rep_cons_freelist = tem_freelist; rep_used_cons = tem_used; } static int cons_cmp(repv v1, repv v2) { int rc = 1; if(rep_TYPE(v1) == rep_TYPE(v2)) { rc = rep_value_cmp(rep_CAR(v1), rep_CAR(v2)); if(!rc) rc = rep_value_cmp(rep_CDR(v1), rep_CDR(v2)); } return rc; } repv rep_list_1(repv v1) { return rep_LIST_1(v1); } repv rep_list_2(repv v1, repv v2) { return rep_LIST_2(v1, v2); } repv rep_list_3(repv v1, repv v2, repv v3) { return rep_LIST_3(v1, v2, v3); } repv rep_list_4(repv v1, repv v2, repv v3, repv v4) { return rep_LIST_4(v1, v2, v3, v4); } repv rep_list_5(repv v1, repv v2, repv v3, repv v4, repv v5) { return rep_LIST_5(v1, v2, v3, v4, v5); } /* Vectors */ static rep_vector *vector_chain; static int used_vector_slots; repv rep_make_vector(int size) { int len = rep_VECT_SIZE(size); rep_vector *v = rep_ALLOC_CELL(len); if(v != NULL) { rep_SET_VECT_LEN(rep_VAL(v), size); v->next = vector_chain; vector_chain = v; used_vector_slots += size; rep_data_after_gc += len; } return rep_VAL(v); } static void vector_sweep(void) { rep_vector *this = vector_chain; vector_chain = NULL; used_vector_slots = 0; while(this != NULL) { rep_vector *nxt = this->next; if(!rep_GC_CELL_MARKEDP(rep_VAL(this))) rep_FREE_CELL(this); else { this->next = vector_chain; vector_chain = this; used_vector_slots += rep_VECT_LEN(this); rep_GC_CLR_CELL(rep_VAL(this)); } this = nxt; } } static int vector_cmp(repv v1, repv v2) { int rc = 1; if((rep_TYPE(v1) == rep_TYPE(v2)) && (rep_VECT_LEN(v1) == rep_VECT_LEN(v2))) { int i; int len = rep_VECT_LEN(v1); for(i = rc = 0; (i < len) && (rc == 0); i++) rc = rep_value_cmp(rep_VECTI(v1, i), rep_VECTI(v2, i)); } return rc; } /* Guardians */ static rep_guardian *guardians; DEFUN("make-primitive-guardian", Fmake_primitive_guardian, Smake_primitive_guardian, (void), rep_Subr0) { rep_guardian *g = rep_ALLOC_CELL (sizeof (rep_guardian)); rep_data_after_gc += sizeof (rep_guardian); g->car = rep_guardian_type; g->accessible = Qnil; g->inaccessible = Qnil; g->next = guardians; guardians = g; return rep_VAL(g); } DEFUN("primitive-guardian-push", Fprimitive_guardian_push, Sprimitive_guardian_push, (repv g, repv obj), rep_Subr2) { rep_DECLARE1 (g, rep_GUARDIANP); rep_GUARDIAN(g)->accessible = Fcons (obj, rep_GUARDIAN(g)->accessible); return g; } DEFUN("primitive-guardian-pop", Fprimitive_guardian_pop, Sprimitive_guardian_pop, (repv g), rep_Subr1) { rep_DECLARE1 (g, rep_GUARDIANP); if (rep_GUARDIAN(g)->inaccessible != Qnil) { repv ret = rep_CAR (rep_GUARDIAN(g)->inaccessible); rep_GUARDIAN(g)->inaccessible = rep_CDR (rep_GUARDIAN(g)->inaccessible); return ret; } else return Qnil; } static void mark_guardian (repv g) { /* accessible list is marked by run_guardians */ rep_MARKVAL (rep_GUARDIAN(g)->inaccessible); } static void run_guardians (void) { struct saved { struct saved *next; repv obj; } *changed = 0; /* scan all guardians for unmarked objects that used to be accessible */ rep_guardian *g; for (g = guardians; g != 0; g = g->next) { repv *ptr = &g->accessible; /* cons cells store mark bit in CDR, so mask it out. */ while ((*ptr & ~rep_VALUE_CONS_MARK_BIT) != Qnil) { repv cell = *ptr & ~rep_VALUE_CONS_MARK_BIT; if (!rep_GC_MARKEDP (rep_CAR (cell))) { /* move object to inaccessible list */ struct saved *new; /* have to preserve the cons mark bit in *ptr */ *ptr = rep_GCDR (cell) | (*ptr & rep_VALUE_CONS_MARK_BIT); rep_CDR (cell) = g->inaccessible; g->inaccessible = cell; /* note that we need to mark this object */ new = alloca (sizeof (struct saved)); new->obj = rep_CAR (cell); new->next = changed; changed = new; } else ptr = rep_CDRLOC (cell); /* mark the list infrastructure */ rep_GC_SET_CONS (cell); } } /* mark any objects that changed state */ while (changed != 0) { rep_MARKVAL (changed->obj); changed = changed->next; } } static void sweep_guardians (void) { rep_guardian *g = guardians; guardians = 0; while (g) { rep_guardian *next = g->next; if (!rep_GC_CELL_MARKEDP (rep_VAL (g))) rep_FREE_CELL (g); else { rep_GC_CLR_CELL (rep_VAL (g)); g->next = guardians; guardians = g; } g = next; } } static void print_guardian (repv stream, repv obj) { rep_stream_puts (stream, "#", -1, rep_FALSE); } /* Garbage collection */ static repv **static_roots; static int next_static_root, allocated_static_roots; rep_GC_root *rep_gc_root_stack = 0; rep_GC_n_roots *rep_gc_n_roots_stack = 0; rep_bool rep_in_gc = rep_FALSE; /* rep_data_after_gc = bytes of storage used since last gc rep_gc_threshold = value that rep_data_after_gc should be before gc'ing rep_idle_gc_threshold = value that DAGC should be before gc'ing in idle time */ int rep_data_after_gc, rep_gc_threshold = 200000, rep_idle_gc_threshold = 20000; #ifdef GC_MONITOR_STK static int *gc_stack_high_tide; #endif void rep_mark_static(repv *obj) { if (next_static_root == allocated_static_roots) { int new_size = (allocated_static_roots ? (allocated_static_roots * 2) : 256); if (static_roots != 0) static_roots = rep_realloc (static_roots, new_size * sizeof (repv *)); else static_roots = rep_alloc (new_size * sizeof (repv *)); assert (static_roots != 0); allocated_static_roots = new_size; } static_roots[next_static_root++] = obj; } /* Mark a single Lisp object. This attempts to eliminate as much tail-recursion as possible (by changing the rep_VAL and jumping back to the `again' label). Note that rep_VAL must not be NULL, and must not already have been marked, (see the rep_MARKVAL macro in lisp.h) */ void rep_mark_value(register repv val) { #ifdef GC_MONITOR_STK int dummy; /* Assumes that the stack grows downwards (towards 0) */ if(&dummy < gc_stack_high_tide) gc_stack_high_tide = &dummy; #endif again: if(rep_INTP(val)) return; /* must be a cell */ if(rep_CELL_CONS_P(val)) { if(rep_CONS_WRITABLE_P(val)) { /* A cons. Attempts to walk though whole lists at a time (since Lisp lists mainly link from the cdr). */ rep_GC_SET_CONS(val); if(rep_NILP(rep_GCDR(val))) /* End of a list. We can safely mark the car non-recursively. */ val = rep_CAR(val); else { rep_MARKVAL(rep_CAR(val)); val = rep_GCDR(val); } if(val && !rep_INTP(val) && !rep_GC_MARKEDP(val)) goto again; return; } else { /* A constant cons cell. */ return; } } if (rep_CELL16P(val)) { /* A user allocated type. */ rep_type *t = rep_get_data_type(rep_CELL16_TYPE(val)); rep_GC_SET_CELL(val); if (t->mark != 0) t->mark(val); return; } /* So we know that it's a cell8 object */ switch(rep_CELL8_TYPE(val)) { rep_type *t; case rep_Vector: case rep_Compiled: if(rep_VECTOR_WRITABLE_P(val)) { int i, len = rep_VECT_LEN(val); rep_GC_SET_CELL(val); for(i = 0; i < len; i++) rep_MARKVAL(rep_VECTI(val, i)); } break; case rep_Symbol: /* Dumped symbols are dumped read-write, so no worries.. */ rep_GC_SET_CELL(val); rep_MARKVAL(rep_SYM(val)->name); val = rep_SYM(val)->next; if(val && !rep_INTP(val) && !rep_GC_MARKEDP(val)) goto again; break; case rep_String: if(!rep_STRING_WRITABLE_P(val)) break; rep_GC_SET_CELL(val); break; case rep_Number: rep_GC_SET_CELL(val); break; case rep_Funarg: if (!rep_FUNARG_WRITABLE_P(val)) break; rep_GC_SET_CELL(val); rep_MARKVAL(rep_FUNARG(val)->name); rep_MARKVAL(rep_FUNARG(val)->env); rep_MARKVAL(rep_FUNARG(val)->structure); val = rep_FUNARG(val)->fun; if (val && !rep_GC_MARKEDP(val)) goto again; break; case rep_Subr0: case rep_Subr1: case rep_Subr2: case rep_Subr3: case rep_Subr4: case rep_Subr5: case rep_SubrN: case rep_SF: break; default: t = rep_get_data_type(rep_CELL8_TYPE(val)); rep_GC_SET_CELL(val); if (t->mark != 0) t->mark(val); } } DEFUN("garbage-threshold", Fgarbage_threshold, Sgarbage_threshold, (repv val), rep_Subr1) /* ::doc:rep.data#garbage-threshold:: garbage-threshold [NEW-VALUE] The number of bytes of storage which must be used before a garbage- collection is triggered. ::end:: */ { return rep_handle_var_int(val, &rep_gc_threshold); } DEFUN("idle-garbage-threshold", Fidle_garbage_threshold, Sidle_garbage_threshold, (repv val), rep_Subr1) /* ::doc:rep.data#idle-garbage-threshold:: idle-garbage-threshold [NEW-VALUE] The number of bytes of storage which must be used before a garbage- collection is triggered when the editor is idle. ::end:: */ { return rep_handle_var_int(val, &rep_idle_gc_threshold); } DEFUN_INT("garbage-collect", Fgarbage_collect, Sgarbage_collect, (repv stats), rep_Subr1, "") /* ::doc:rep.data#garbage-collect:: garbage-collect Scans all allocated storage for unusable data, and puts it onto the free- list. This is done automatically when the amount of storage used since the last garbage-collection is greater than `garbage-threshold'. ::end:: */ { int i; rep_GC_root *rep_gc_root; rep_GC_n_roots *rep_gc_n_roots; struct rep_Call *lc; #ifdef GC_MONITOR_STK int dummy; gc_stack_high_tide = &dummy; #endif rep_in_gc = rep_TRUE; rep_macros_before_gc (); /* mark static objects */ for(i = 0; i < next_static_root; i++) rep_MARKVAL(*static_roots[i]); /* mark stack based objects protected from GC */ for(rep_gc_root = rep_gc_root_stack; rep_gc_root != 0; rep_gc_root = rep_gc_root->next) { rep_MARKVAL(*rep_gc_root->ptr); } for(rep_gc_n_roots = rep_gc_n_roots_stack; rep_gc_n_roots != 0; rep_gc_n_roots = rep_gc_n_roots->next) { for(i = 0; i < rep_gc_n_roots->count; i++) rep_MARKVAL(rep_gc_n_roots->first[i]); } /* Do data-type specific marking. */ for (i = 0; i < TYPE_HASH_SIZE; i++) { rep_type *t = data_types[i]; while (t != 0) { if (t->mark_type != 0) t->mark_type(); t = t->next; } } rep_mark_regexp_data(); rep_mark_origins (); #ifdef HAVE_DYNAMIC_LOADING rep_mark_dl_data(); #endif /* have to mark the Lisp backtrace. */ lc = rep_call_stack; while(lc) { rep_MARKVAL(lc->fun); rep_MARKVAL(lc->args); rep_MARKVAL(lc->current_form); rep_MARKVAL(lc->saved_env); rep_MARKVAL(lc->saved_structure); lc = lc->next; } /* move and mark any guarded objects that became inaccessible */ run_guardians (); /* look for dead weak references */ rep_scan_weak_refs (); /* Finished marking, start sweeping. */ rep_sweep_tuples (); for(i = 0; i < TYPE_HASH_SIZE; i++) { rep_type *t = data_types[i]; while (t != 0) { if (t->sweep != 0) t->sweep(); t = t->next; } } rep_data_after_gc = 0; rep_in_gc = rep_FALSE; #ifdef GC_MONITOR_STK fprintf(stderr, "gc: stack usage = %d\n", ((int)&dummy) - (int)gc_stack_high_tide); #endif Fcall_hook (Qafter_gc_hook, Qnil, Qnil); if(stats != Qnil) { return rep_list_5(Fcons(rep_MAKE_INT(rep_used_cons), rep_MAKE_INT(rep_allocated_cons - rep_used_cons)), Fcons(rep_MAKE_INT(rep_used_tuples), rep_MAKE_INT(rep_allocated_tuples - rep_used_tuples)), rep_list_3(rep_MAKE_INT(used_strings), rep_MAKE_INT(allocated_strings), rep_MAKE_INT(allocated_string_bytes)), rep_MAKE_INT(used_vector_slots), Fcons(rep_MAKE_INT(rep_used_funargs), rep_MAKE_INT(rep_allocated_funargs - rep_used_funargs))); } else return Qt; } void rep_pre_values_init(void) { rep_register_type(rep_Cons, "cons", cons_cmp, rep_lisp_prin, rep_lisp_prin, cons_sweep, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Vector, "vector", vector_cmp, rep_lisp_prin, rep_lisp_prin, vector_sweep, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_String, "string", string_cmp, rep_string_princ, rep_string_print, string_sweep, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Compiled, "bytecode", vector_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Void, "void", rep_type_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_SF, "special-form", rep_ptr_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Subr0, "subr0", rep_ptr_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Subr1, "subr1", rep_ptr_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Subr2, "subr2", rep_ptr_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Subr3, "subr3", rep_ptr_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Subr4, "subr4", rep_ptr_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Subr5, "subr5", rep_ptr_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_SubrN, "subrn", rep_ptr_cmp, rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_guardian_type = rep_register_new_type ("guardian", rep_ptr_cmp, print_guardian, print_guardian, sweep_guardians, mark_guardian, 0, 0, 0, 0, 0, 0, 0); } void rep_values_init(void) { repv tem = rep_push_structure ("rep.data"); rep_ADD_SUBR(Scons); rep_ADD_SUBR(Sgarbage_threshold); rep_ADD_SUBR(Sidle_garbage_threshold); rep_ADD_SUBR_INT(Sgarbage_collect); rep_ADD_INTERNAL_SUBR(Smake_primitive_guardian); rep_ADD_INTERNAL_SUBR(Sprimitive_guardian_push); rep_ADD_INTERNAL_SUBR(Sprimitive_guardian_pop); rep_INTERN_SPECIAL(after_gc_hook); rep_pop_structure (tem); } void rep_values_kill(void) { rep_cons_block *cb = rep_cons_block_chain; rep_vector *v = vector_chain; rep_string_block *s = string_block_chain; while(cb != NULL) { rep_cons_block *nxt = cb->next.p; rep_free(cb); cb = nxt; } while(v != NULL) { rep_vector *nxt = v->next; rep_FREE_CELL(v); v = nxt; } while(s != NULL) { int i; rep_string_block *nxt = s->next.p; for (i = 0; i < rep_STRINGBLK_SIZE; i++) { if (!rep_CELL_CONS_P (rep_VAL(s->data + i))) rep_free (s->data[i].data); } rep_free(s); s = nxt; } rep_cons_block_chain = NULL; vector_chain = NULL; string_block_chain = NULL; } /* Support for dumped Lisp code */ #ifdef ENABLE_BROKEN_DUMPING void rep_dumped_init(char *file) { void *dl = rep_open_dl_library (rep_string_dup (file)); if (dl == 0) fprintf (stderr, "warning: couldn't open dumped filed %s\n", file); else { /* Main function is to go through all dumped symbols, interning them, and changing rep_NULL values to be void. */ rep_symbol *s; /* But first, intern nil, it'll be filled in later. */ Qnil = Fintern_symbol (rep_VAL(rep_dumped_symbols_end - 1), rep_void_value); /* Stop one symbol too early, since we've already added it */ for (s = rep_dumped_symbols_start; s < rep_dumped_symbols_end - 1; s++) { /* Second arg is [OBARRAY], but it's only checked against being a vector. */ Fintern_symbol (rep_VAL(s), rep_void_value); if (s->value == rep_NULL) s->value = rep_void_value; } } } #endif librep-0.90.2/src/utf8.c0000644000175200017520000001447011245011153013705 0ustar chrischris/* utf8.c - Operations on UTF-8 strings * Some codes in this file are borrowed from glib-2.x/glib/gutf8.c * * Copyright (C) 1999 Tom Tromey * Copyright (C) 2000 Red Hat, Inc. * Copyright (C) 2009 Wang Diancheng. * * This file is part of librep. * * librep is free software; you can redistribute it and/or modify it * under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. * * librep is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with librep; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. * */ /* More functions for utf-8 are available in glib-x.y.z/glib/gutf8.c. */ #define _GNU_SOURCE #include #include "repint.h" static const char utf8_skip_data[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,6,6,1,1 }; const char * const utf8_skip = utf8_skip_data; #define utf8_next_char(p) (char *)((p) + utf8_skip[*(const unsigned char *)(p)]) long utf8_strlen (const char *p, int max); long utf8_pointer_to_offset (const char *str, const char *pos); char * utf8_offset_to_pointer (const char *str, long offset); /** * utf8_strlen: * @p: pointer to the start of a UTF-8 encoded string. * @max: the maximum number of bytes to examine. If @max * is less than 0, then the string is assumed to be * nul-terminated. If @max is 0, @p will not be examined and * may be %NULL. * * Returns the length of the string in characters. * * Return value: the length of the string in characters **/ long utf8_strlen (const char *p, int max) { long len = 0; const char *start = p; if(p == NULL || max == 0) return 0; if (max < 0) { while (*p) { p = utf8_next_char (p); ++len; } } else { if (max == 0 || !*p) return 0; p = utf8_next_char (p); while (p - start < max && *p) { ++len; p = utf8_next_char (p); } /* only do the last len increment if we got a complete * char (don't count partial chars) */ if (p - start <= max) ++len; } return len; } /** * utf8_pointer_to_offset: * @str: a UTF-8 encoded string * @pos: a pointer to a position within @str * * Converts from a pointer to position within a string to a integer * character offset. * * this function allows @pos to be before @str, and returns * a negative offset in this case. * * Return value: the resulting character offset **/ long utf8_pointer_to_offset (const char *str, const char *pos) { const char *s = str; long offset = 0; if (pos < str) offset = - utf8_pointer_to_offset (pos, str); else while (s < pos) { s = utf8_next_char (s); offset++; } return offset; } /** * utf8_offset_to_pointer: * @str: a UTF-8 encoded string * @offset: a character offset within @str * * Converts from an integer character offset to a pointer to a position * within the string. * * this function allows to pass a negative @offset to * step backwards. It is usually worth stepping backwards from the end * instead of forwards if @offset is in the last fourth of the string, * since moving forward is about 3 times faster than moving backward. * * Return value: the resulting pointer **/ char * utf8_offset_to_pointer (const char *str, long offset) { const char *s = str; if (offset > 0) while (offset--) s = utf8_next_char (s); else { const char *s1; /* This nice technique for fast backwards stepping * through a UTF-8 string was dubbed "stutter stepping" * by its inventor, Larry Ewing. */ while (offset) { s1 = s; s += offset; while ((*s & 0xc0) == 0x80) s--; offset += utf8_pointer_to_offset (s, s1); } } return (char *)s; } DEFUN("utf8-string-length", Futf8_string_length, Sutf8_string_length, (repv string), rep_Subr1) /* ::doc:rep.util.utf8#utf8-string-length:: utf8-string-length STRING Returns the number of characters in utf-8 encoded STRING. ::end:: */ { rep_DECLARE1(string, rep_STRINGP); return rep_MAKE_INT(utf8_strlen (rep_STR(string),-1)); } DEFUN("utf8-substring", Futf8_substring, Sutf8_substring, (repv string, repv start, repv end), rep_Subr3) /* ::doc:rep.util.utf8#utf8-substring:: utf8-substring STRING START [END] Returns the portion of STRING, encoded in utf-8, starting at character number START and ending at the character before END (or the end of the string if END is not given). All indices start at zero. ::end:: */ { int utf8len, slen; char *pstart; char *pend; rep_DECLARE1(string, rep_STRINGP); rep_DECLARE2(start, rep_INTP); rep_DECLARE3_OPT(end, rep_INTP); utf8len = utf8_strlen(rep_STR(string), -1); if(rep_INT(start) > utf8len || rep_INT(start) < 0) return(rep_signal_arg_error(start, 2)); pstart = utf8_offset_to_pointer(rep_STR(string), rep_INT(start)); if(rep_INTP(end)) { if((rep_INT(end) > utf8len) || (rep_INT(end) < rep_INT(start))) return(rep_signal_arg_error(end, 3)); pend = utf8_offset_to_pointer(rep_STR(string),rep_INT(end)); return(rep_string_dupn(pstart, pend - pstart)); } else { slen = rep_STRING_LEN(string); return(rep_string_dupn(pstart, slen - (pstart-rep_STR(string)))); } } repv rep_dl_init (void) { repv tem = rep_push_structure ("rep.util.utf8"); rep_ADD_SUBR(Sutf8_substring); rep_ADD_SUBR(Sutf8_string_length); return rep_pop_structure (tem); } librep-0.90.2/src/unix_processes.c0000644000175200017520000014642711245011153016100 0ustar chrischris/* unix_processes.c -- Subprocess handling for Unix Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" /* Note that I have no idea how portable this code will be. It has been tested under Solaris and Linux, but beyond that, I really don't have the experience... */ #include #include #include #include #include #include #include #include #include #ifdef NEED_MEMORY_H # include #endif #ifdef HAVE_UNISTD_H # include #endif #ifdef HAVE_FCNTL_H # include #else # include #endif #ifdef HAVE_SYS_TIME_H # include #endif #if HAVE_SYS_WAIT_H # include #endif #ifndef WEXITSTATUS # define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8) #endif #ifndef WIFEXITED # define WIFEXITED(stat_val) (((stat_val) & 255) == 0) #endif #ifdef HAVE_SYS_IOCTL_H # include #endif #ifdef HAVE_TERMIOS_H # include #endif #ifdef HAVE_DEV_PTMX # ifdef HAVE_STROPTS_H # include # endif #endif #ifdef ENVIRON_UNDECLARED extern char **environ; #endif void (*rep_sigchld_fun) (void) = 0; static struct sigaction chld_sigact; static sigset_t chld_sigset; struct Proc { repv pr_Car; /* status in high bits */ struct Proc *pr_Next; /* Chain of all processes waiting to be notified of a change of state. */ struct Proc *pr_NotifyNext; pid_t pr_Pid; /* pr_Stdin is where we write, pr_Stdout where we read, they may be the same. pr_Stderr is only used with pipes--it may be a separate connection to the stderr stream of the process. At all other times it will be equal to pr_Stdout. */ int pr_Stdin, pr_Stdout, pr_Stderr; repv pr_OutputStream, pr_ErrorStream; int pr_ExitStatus; repv pr_NotifyFun; repv pr_Prog; repv pr_Args; repv pr_Dir; repv pr_ConnType; }; /* Status is two bits above the type code (presently 8->9) */ #define PR_ACTIVE (1 << (rep_CELL16_TYPE_BITS + 0)) /* active, may be stopped */ #define PR_STOPPED (2 << (rep_CELL16_TYPE_BITS + 1)) /* stopped */ #define PR_DEAD 0 #define PR_RUNNING PR_ACTIVE #define PR_ACTIVE_P(p) ((p)->pr_Car & PR_ACTIVE) #define PR_STOPPED_P(p) ((p)->pr_Car & PR_STOPPED) #define PR_RUNNING_P(p) (PR_ACTIVE_P(p) && !PR_STOPPED_P(p)) #define PR_DEAD_P(p) !PR_ACTIVE_P(p) #define PR_SET_STATUS(p,s) \ ((p)->pr_Car = (((p)->pr_Car & ~(PR_ACTIVE | PR_STOPPED)) | (s))) /* Connection types */ DEFSYM(pipe, "pipe"); DEFSYM(pty, "pty"); DEFSYM(socketpair, "socketpair"); #define PR_CONN_PTY_P(p) \ ((p)->pr_ConnType == Qpty) #define PR_CONN_PIPE_P(p) \ ((p)->pr_ConnType == Qpipe) #define PR_CONN_SOCKETPAIR_P(p) \ ((p)->pr_ConnType == Qsocketpair) #define VPROC(v) ((struct Proc *)rep_PTR(v)) #define PROCESSP(v) rep_CELL16_TYPEP(v, process_type) /* Handy debugging macro */ #if 0 # define DB(x) fprintf x #else # define DB(x) #endif static struct Proc *process_chain; static struct Proc *notify_chain; static int process_run_count; static int process_type; /* Set to rep_TRUE by the SIGCHLD handler */ static volatile rep_bool got_sigchld; static void read_from_one_fd(struct Proc *pr, int fd); static void read_from_process(int); DEFSTRING(not_running, "Not running"); DEFSTRING(not_stopped, "Not stopped"); DEFSTRING(no_link, "No link to input"); DEFSTRING(in_use, "Process in use"); DEFSTRING(no_pty, "Can't find unused pty"); DEFSTRING(already_running, "Already running"); DEFSTRING(no_prog, "No program"); DEFSTRING(cant_start, "Can't start"); DEFSTRING(dev_null, "/dev/null"); DEFSTRING(dot, "."); DEFSTRING(not_local, "Need a local file"); DEFSTRING(forkstr, "fork"); DEFSTRING(nosig, "Unknown signal"); static RETSIGTYPE sigchld_handler(int sig) { got_sigchld = rep_TRUE; if (rep_sigchld_fun != 0) (*rep_sigchld_fun) (); } static void close_proc_files(struct Proc *pr) { if(pr->pr_Stdout) { rep_deregister_input_fd(pr->pr_Stdout); close(pr->pr_Stdout); } if(pr->pr_Stderr && pr->pr_Stderr != pr->pr_Stdout) { rep_deregister_input_fd(pr->pr_Stderr); close(pr->pr_Stderr); } if(pr->pr_Stdin && (pr->pr_Stdin != pr->pr_Stdout)) close(pr->pr_Stdin); pr->pr_Stdout = pr->pr_Stdin = pr->pr_Stderr = 0; } /* PR's NotifyFun will be called when possible. This function is safe to call from signal handlers. */ static void queue_notify(struct Proc *pr) { if(pr->pr_NotifyNext == NULL) { pr->pr_NotifyNext = notify_chain; notify_chain = pr; } } /* Dispatch all queued notification. */ static rep_bool proc_notification(void) { if(!notify_chain) return(rep_FALSE); while(notify_chain != NULL && !rep_INTERRUPTP) { struct Proc *pr = notify_chain; notify_chain = pr->pr_NotifyNext; pr->pr_NotifyNext = NULL; if(pr->pr_NotifyFun && !rep_NILP(pr->pr_NotifyFun)) rep_call_lisp1(pr->pr_NotifyFun, rep_VAL(pr)); } return rep_TRUE; } static inline rep_bool notify_queued_p (struct Proc *pr) { return pr->pr_NotifyNext != 0; } static void notify_1 (struct Proc *pr) { if (notify_queued_p (pr)) { struct Proc **ptr = ¬ify_chain; while (*ptr != pr) ptr = &((*ptr)->pr_NotifyNext); *ptr = pr->pr_NotifyNext; pr->pr_NotifyNext = NULL; if (pr->pr_NotifyFun && pr->pr_NotifyFun != Qnil) rep_call_lisp1 (pr->pr_NotifyFun, rep_VAL (pr)); } } /* Checks if any of my children are zombies, takes appropriate action. */ static rep_bool check_for_zombies(void) { if(!got_sigchld) return rep_FALSE; got_sigchld = rep_FALSE; while(process_run_count > 0) { struct Proc *pr; int status; pid_t pid; pid = waitpid(-1, &status, WNOHANG | WUNTRACED); if(pid > 0) { /* Got a process id, find its process structure. */ for(pr = process_chain; pr != 0; pr = pr->pr_Next) { if(PR_ACTIVE_P(pr) && (pr->pr_Pid == pid)) { /* Got it. */ #ifdef WIFSTOPPED if(WIFSTOPPED(status)) { /* Process is suspended. */ PR_SET_STATUS(pr, PR_ACTIVE | PR_STOPPED); queue_notify(pr); } else #endif { /* Process is dead. */ pr->pr_ExitStatus = status; process_run_count--; PR_SET_STATUS(pr, PR_DEAD); /* Try to read any pending output */ if(pr->pr_Stdout) read_from_one_fd(pr, pr->pr_Stdout); if(pr->pr_Stderr && pr->pr_Stderr != pr->pr_Stdout) read_from_one_fd(pr, pr->pr_Stderr); /* Then close the streams */ close_proc_files(pr); queue_notify(pr); } break; } } } else if(pid == 0) break; else if(pid < 0) { if(errno == EINTR) continue; else break; } } return rep_TRUE; } /* Called by the event loop after each event or timeout. Returns true if the display should be updated. */ static rep_bool proc_periodically(void) { rep_bool rc = check_for_zombies(); if(proc_notification()) rc = rep_TRUE; return rc; } /* Read data from FD out of PROC. If necessary it will handle clean up and notification. */ static void read_from_one_fd(struct Proc *pr, int fd) { repv stream = ((fd != pr->pr_Stdout) ? pr->pr_ErrorStream : pr->pr_OutputStream); char buf[1025]; int actual; do { if((actual = read(fd, buf, 1024)) > 0) { buf[actual] = 0; if(!rep_NILP(stream)) rep_stream_puts(stream, buf, actual, rep_FALSE); } } while((actual > 0) || (actual < 0 && errno == EINTR)); if (actual == 0 || (actual < 0 && errno != EWOULDBLOCK && errno != EAGAIN)) { /* We assume EOF */ rep_deregister_input_fd(fd); close(fd); /* Could be either pr_Stdout or pr_Stderr */ if(fd != pr->pr_Stdout) pr->pr_Stderr = 0; else { if(pr->pr_Stdin && (pr->pr_Stdin == pr->pr_Stdout)) pr->pr_Stdin = 0; if(pr->pr_Stderr && (pr->pr_Stderr == pr->pr_Stdout)) pr->pr_Stderr = 0; pr->pr_Stdout = 0; } } } static void read_from_process(int fd) { struct Proc *pr; pr = process_chain; while(pr) { if(PR_ACTIVE_P(pr) && (pr->pr_Stdout == fd || pr->pr_Stderr == fd)) read_from_one_fd(pr, fd); pr = pr->pr_Next; } } static int write_to_process(repv pr, char *buf, int bufLen) { int act = 0; if(!PROCESSP(pr)) return(0); if(PR_ACTIVE_P(VPROC(pr))) { if(VPROC(pr)->pr_Stdin == 0) { Fsignal(Qprocess_error, rep_list_2(pr, rep_VAL(&no_link))); } else { do { /* This will block */ int this = write(VPROC(pr)->pr_Stdin, buf + act, bufLen - act); if (this < 0) { if (errno != EINTR) { rep_signal_file_error(pr); break; } } else act += this; } while (act < bufLen); } } else Fsignal(Qprocess_error, rep_list_2(pr, rep_VAL(¬_running))); return(act); } static rep_bool signal_process(struct Proc *pr, int sig, rep_bool do_grp) { rep_bool rc = rep_TRUE; if(do_grp) { if(pr->pr_Stdin && PR_CONN_PTY_P(pr)) { pid_t gid = tcgetpgrp(pr->pr_Stdin); if(gid != -1) kill(-gid, sig); else if(PR_ACTIVE_P(pr)) kill(-pr->pr_Pid, sig); else rc = rep_FALSE; } else { if(PR_ACTIVE_P(pr)) kill(-pr->pr_Pid, sig); else rc = rep_FALSE; } } else { if(PR_ACTIVE_P(pr)) kill(pr->pr_Pid, sig); else rc = rep_FALSE; } return(rc); } /* This is only called during GC, when the process isn't being referenced. it will already have been taken out of the chain. Also active processes should have been marked anyway. */ static void kill_process(struct Proc *pr) { if(PR_ACTIVE_P(pr)) { /* is this too heavy-handed?? */ if(!signal_process(pr, SIGKILL, rep_TRUE)) kill(-pr->pr_Pid, SIGKILL); waitpid(pr->pr_Pid, &pr->pr_ExitStatus, 0); process_run_count--; close_proc_files(pr); } rep_FREE_CELL(pr); } /* Return the file descriptor (or 0 if an error) of the first available pty master. SLAVENAM will contain the name of the associated slave. */ static int get_pty(char *slavenam) { #if defined(HAVE_PTYS) int master; # if defined(HAVE_DEV_PTMX) && defined(HAVE_GRANTPT) master = open("/dev/ptmx", O_RDWR); if(master >= 0) { char *tem; grantpt(master); unlockpt(master); tem = ptsname(master); if(tem != 0) { strcpy(slavenam, tem); return master; } close(master); } # endif # if defined(FIRST_PTY_LETTER) /* Assume /dev/ptyXNN and /dev/ttyXN naming system. The FIRST_PTY_LETTER gives the first X to try. We try in the sequence FIRST_PTY_LETTER, .., 'z', 'a', .., FIRST_PTY_LETTER. Is this worthwhile, or just over-zealous? */ char c = FIRST_PTY_LETTER; do { int i; for(i = 0; i < 16; i++) { struct stat statb; sprintf(slavenam, "/dev/pty%c%x", c, i); if(stat(slavenam, &statb) < 0) goto none; if((master = open(slavenam, O_RDWR)) >= 0) { slavenam[sizeof("/dev/")-1] = 't'; if(access(slavenam, R_OK | W_OK) == 0) return master; close(master); } } if(++c > 'z') c = 'a'; } while(c != FIRST_PTY_LETTER); none: # endif /* FIRST_PTY_LETTER */ #endif /* HAVE_PTYS */ /* Couldn't find a pty. Signal an error. */ Fsignal(Qprocess_error, rep_LIST_1(rep_VAL(&no_pty))); return 0; } static void child_build_environ (void) { /* Build the environment */ repv tem = Fsymbol_value(Qprocess_environment, Qt); if(rep_CONSP(tem)) { repv len = Flength(tem); if(len && rep_INTP(len)) { environ = rep_alloc(sizeof(char *) * (rep_INT(len) + 1)); if(environ != 0) { char **ptr = environ; while(rep_CONSP(tem)) { *ptr++ = rep_STR(rep_CAR(tem)); tem = rep_CDR(tem); } *ptr++ = 0; } } } } /* does the dirty stuff of getting the process running. if SYNC_INPUT is non-NULL it means to run the process synchronously with it's stdin connected to the file SYNC_INPUT. Otherwise this function returns immediately after starting the process. */ static rep_bool run_process(struct Proc *pr, char **argv, char *sync_input) { rep_bool rc = rep_FALSE; if(PR_DEAD_P(pr)) { rep_bool usepty = PR_CONN_PTY_P(pr); char slavenam[32]; int stdin_fds[2], stdout_fds[2], stderr_fds[2]; /* only for pipes */ pr->pr_ExitStatus = -1; if(sync_input != NULL || !usepty) { usepty = rep_FALSE; pr->pr_ConnType = Qpipe; if(pipe(stdout_fds) == 0) { if(pipe(stderr_fds) == 0) { if(sync_input) { stdin_fds[0] = open(sync_input, O_RDONLY); if(stdin_fds[0] >= 0) pr->pr_Stdin = stdin_fds[0]; /* fake */ } else { if(pipe(stdin_fds) == 0) pr->pr_Stdin = stdin_fds[1]; } if(pr->pr_Stdin != 0) { pr->pr_Stdout = stdout_fds[0]; pr->pr_Stderr = stderr_fds[0]; } else { close(stderr_fds[0]); close(stderr_fds[1]); } } else { close(stdout_fds[0]); close(stdout_fds[1]); } } } else if (PR_CONN_SOCKETPAIR_P(pr)) { /* XXX separate stdout from stderr.. */ if (socketpair (AF_UNIX, SOCK_STREAM, 0, stdin_fds) == 0) { pr->pr_Stdin = stdin_fds[0]; pr->pr_Stdout = stdin_fds[0]; pr->pr_Stderr = stdin_fds[0]; } } else if(usepty) { pr->pr_Stdin = get_pty(slavenam); pr->pr_Stdout = pr->pr_Stdin; pr->pr_Stderr = pr->pr_Stdin; } if(pr->pr_Stdin) { int pty_slave_fd = -1; /* Must set up pty slave before forking, to avoid race condition if master writes to it first */ if(usepty) { struct termios st; pty_slave_fd = open(slavenam, O_RDWR); if (pty_slave_fd >= 0) { #ifdef HAVE_DEV_PTMX # ifdef I_PUSH /* Push the necessary modules onto the slave to get terminal semantics. */ ioctl(pty_slave_fd, I_PUSH, "ptem"); ioctl(pty_slave_fd, I_PUSH, "ldterm"); # endif #endif #ifdef TIOCSCTTY ioctl(pty_slave_fd, TIOCSCTTY, 0); #endif tcgetattr(pty_slave_fd, &st); st.c_iflag &= ~(ISTRIP | IGNCR | INLCR | IXOFF); st.c_iflag |= (ICRNL | IGNPAR | BRKINT | IXON); st.c_oflag &= ~OPOST; st.c_cflag &= ~CSIZE; st.c_cflag |= CREAD | CS8 | CLOCAL; st.c_lflag &= ~(ECHO | ECHOE | ECHOK | NOFLSH | TOSTOP); st.c_lflag |= ISIG; #if 0 st.c_cc[VMIN] = 1; st.c_cc[VTIME] = 0; #endif /* Set some control codes to default values */ st.c_cc[VINTR] = '\003'; /* ^c */ st.c_cc[VQUIT] = '\034'; /* ^| */ st.c_cc[VERASE] = '\177'; /* ^? */ st.c_cc[VKILL] = '\025'; /* ^u */ st.c_cc[VEOF] = '\004'; /* ^d */ tcsetattr(pty_slave_fd, TCSANOW, &st); } } switch(pr->pr_Pid = fork()) { case 0: /* Child process */ child_build_environ (); if(usepty) { if(setsid() < 0) { perror("child: setsid()"); _exit(255); } if(pty_slave_fd < 0) { perror("child: open(slave)"); _exit(255); } close(pr->pr_Stdin); dup2(pty_slave_fd, 0); dup2(pty_slave_fd, 1); dup2(pty_slave_fd, 2); if(pty_slave_fd > 2) { close(pty_slave_fd); pty_slave_fd = -1; } } else if (PR_CONN_SOCKETPAIR_P(pr)) { /* startup for socketpair */ if(setpgid(0, 0) != 0) { perror("setpgid"); _exit(255); } close (stdin_fds[0]); dup2 (stdin_fds[1], 0); dup2 (stdin_fds[1], 1); dup2 (stdin_fds[1], 2); close (stdin_fds[1]); } else { /* startup for pipes */ if(setpgid(0, 0) != 0) { perror("setpgid"); _exit(255); } dup2(stdin_fds[0], 0); close(stdin_fds[0]); if(sync_input == NULL) close(stdin_fds[1]); dup2(stdout_fds[1], 1); dup2(stderr_fds[1], 2); close(stdout_fds[0]); close(stdout_fds[1]); close(stderr_fds[0]); close(stderr_fds[1]); } if(rep_STRINGP(pr->pr_Dir)) { if(rep_STRING_LEN(pr->pr_Dir) > 0) chdir(rep_STR(pr->pr_Dir)); } signal (SIGPIPE, SIG_DFL); execvp(argv[0], argv); perror("child subprocess can't exec"); _exit(255); case -1: /* Clean up all open files */ if (pty_slave_fd != -1) close (pty_slave_fd); if (PR_CONN_SOCKETPAIR_P(pr)) { close (stdin_fds[0]); close (stdin_fds[1]); } if (sync_input != 0 || !usepty) { /* pipes */ close(stdout_fds[0]); close(stdout_fds[1]); close(stderr_fds[0]); close(stderr_fds[1]); close(stdin_fds[0]); if (sync_input != 0) close(stdin_fds[1]); } else close(pr->pr_Stdin); pr->pr_Stdin = pr->pr_Stdout = pr->pr_Stderr = 0; rep_signal_file_error(rep_VAL(&forkstr)); break; default: /* Parent process */ if (pty_slave_fd != -1) close (pty_slave_fd); PR_SET_STATUS(pr, PR_RUNNING); if (PR_CONN_SOCKETPAIR_P(pr)) { close (stdin_fds[1]); } else if(!usepty) { close(stdin_fds[0]); close(stdout_fds[1]); close(stderr_fds[1]); } if(sync_input == NULL) { if(pr->pr_Stdin == pr->pr_Stdout) { /* So that pr_Stdout can be made non-blocking set up another fd for writing to. */ if((pr->pr_Stdin = dup(pr->pr_Stdout)) < 0) { /* Maybe this is unwise? */ perror("dup(pr->pr_Stdout)"); pr->pr_Stdin = pr->pr_Stdout; } } rep_unix_set_fd_cloexec(pr->pr_Stdin); rep_unix_set_fd_nonblocking(pr->pr_Stdout); rep_register_input_fd(pr->pr_Stdout, read_from_process); if(pr->pr_Stderr != pr->pr_Stdout) { rep_unix_set_fd_nonblocking(pr->pr_Stderr); rep_register_input_fd(pr->pr_Stderr, read_from_process); } process_run_count++; } else { /* Run synchronously. */ char buf[1025]; int actual; fd_set inputs; rep_bool done_out = rep_FALSE, done_err = rep_FALSE; rep_bool exited = rep_FALSE; int interrupt_count = 0; #ifdef KLUDGE_SYNCHRONOUS_OUTPUT int post_exit_count = 0; #endif FD_ZERO(&inputs); FD_SET(pr->pr_Stdout, &inputs); FD_SET(pr->pr_Stderr, &inputs); pr->pr_Stdin = 0; fcntl(pr->pr_Stdout, F_SETFL, O_NONBLOCK); fcntl(pr->pr_Stderr, F_SETFL, O_NONBLOCK); while(!(done_out && done_err)) { fd_set copy = inputs; struct timeval timeout; int number; timeout.tv_sec = 1; timeout.tv_usec = 0; rep_sig_restart(SIGCHLD, rep_FALSE); number = select(FD_SETSIZE, ©, NULL, NULL, &timeout); rep_sig_restart(SIGCHLD, rep_TRUE); rep_TEST_INT_SLOW; if(rep_INTERRUPTP) { int signal; /* What to do here? */ switch(++interrupt_count) { case 1: signal = SIGINT; break; case 2: signal = SIGTERM; break; default: signal = SIGKILL; } signal_process(pr, signal, rep_TRUE); if(rep_throw_value == rep_int_cell) rep_throw_value = 0; } if(number > 0) { rep_GC_root gc_pr; repv vpr = rep_VAL(pr); rep_PUSHGC(gc_pr, vpr); if(!done_out && FD_ISSET(pr->pr_Stdout, ©)) { actual = read(pr->pr_Stdout, buf, 1024); if(actual > 0) { buf[actual] = 0; if(!rep_NILP(pr->pr_OutputStream)) { rep_stream_puts(pr->pr_OutputStream, buf, actual, rep_FALSE); } } else if(actual == 0 || (errno != EINTR && errno != EAGAIN && errno != EWOULDBLOCK)) { done_out = rep_TRUE; FD_CLR(pr->pr_Stdout, &inputs); } } if(!done_err && FD_ISSET(pr->pr_Stderr, ©)) { actual = read(pr->pr_Stderr, buf, 1024); if(actual > 0) { buf[actual] = 0; if(!rep_NILP(pr->pr_ErrorStream)) { rep_stream_puts(pr->pr_ErrorStream, buf, actual, rep_FALSE); } } else if(actual == 0 || (errno != EINTR && errno != EAGAIN && errno != EWOULDBLOCK)) { done_err = rep_TRUE; FD_CLR(pr->pr_Stderr, &inputs); } } rep_POPGC; } #ifdef KLUDGE_SYNCHRONOUS_OUTPUT /* This still doesn't work. The best way to solve this problem is to move the onus to the caller. If a command is called which spawns on its streams, they should be redirected somewhere safe beforehand. */ /* The next two statements are a bit kludgey. Problem: If the child process exits, but has spawned an orphan of its own on the same input and output streams, the done_out and done_err flags won't get set until the _orphan_ quits. Solution: Check for process exit here. If it has exited, allow a few more timeouts, before breaking the loop. */ if(exited && number == 0 && ++post_exit_count > 2) break; if(!exited && got_sigchld && waitpid(pr->pr_Pid, &pr->pr_ExitStatus, WNOHANG) == pr->pr_Pid) exited = rep_TRUE; #endif } if(!exited) waitpid(pr->pr_Pid, &pr->pr_ExitStatus, 0); close(pr->pr_Stdout); close(pr->pr_Stderr); pr->pr_Stdout = 0; pr->pr_Stderr = 0; PR_SET_STATUS(pr, PR_DEAD); queue_notify(pr); } rc = rep_TRUE; break; } } else if(rep_throw_value == rep_NULL) Fsignal(Qprocess_error, rep_LIST_1(rep_lookup_errno())); } else Fsignal(Qprocess_error, rep_list_2(rep_VAL(pr), rep_VAL(&already_running))); return(rc); } static void proc_mark(repv pr) { rep_MARKVAL(VPROC(pr)->pr_OutputStream); rep_MARKVAL(VPROC(pr)->pr_ErrorStream); rep_MARKVAL(VPROC(pr)->pr_NotifyFun); rep_MARKVAL(VPROC(pr)->pr_Prog); rep_MARKVAL(VPROC(pr)->pr_Args); rep_MARKVAL(VPROC(pr)->pr_Dir); rep_MARKVAL(VPROC(pr)->pr_ConnType); } static void mark_active_processes(void) { struct Proc *pr = process_chain; while(pr != 0) { if(PR_ACTIVE_P(pr)) rep_MARKVAL(rep_VAL(pr)); pr = pr->pr_Next; } } static void proc_sweep(void) { struct Proc *pr; /* First weed out any unused processes from the notify chain... */ pr = notify_chain; notify_chain = NULL; while(pr) { if(rep_GC_CELL_MARKEDP(rep_VAL(pr))) { pr->pr_NotifyNext = notify_chain; notify_chain = pr; } pr = pr->pr_NotifyNext; } /* ...then do the normal sweep stuff. */ pr = process_chain; process_chain = NULL; while(pr) { struct Proc *nxt = pr->pr_Next; if(!rep_GC_CELL_MARKEDP(rep_VAL(pr))) kill_process(pr); else { rep_GC_CLR_CELL(rep_VAL(pr)); pr->pr_Next = process_chain; process_chain = pr; } pr = nxt; } } static void proc_prin(repv strm, repv obj) { struct Proc *pr = VPROC(obj); char buf[40]; rep_stream_puts(strm, "#pr_Prog), -1, rep_TRUE); } else if(PR_STOPPED_P(pr)) { rep_stream_puts(strm, " stopped: ", -1, rep_FALSE); rep_stream_puts(strm, rep_PTR(pr->pr_Prog), -1, rep_TRUE); } else { if(pr->pr_ExitStatus != -1) { #ifdef HAVE_SNPRINTF snprintf(buf, sizeof(buf), " exited: 0x%x", pr->pr_ExitStatus); #else sprintf(buf, " exited: 0x%x", pr->pr_ExitStatus); #endif rep_stream_puts(strm, buf, -1, rep_FALSE); } } rep_stream_putc(strm, '>'); } static int proc_putc(repv stream, int c) { char tmps[2]; tmps[0] = (char)c; tmps[1] = 0; return write_to_process(stream, tmps, 1); } static int proc_puts(repv stream, void *data, int len, rep_bool is_lisp) { char *buf = is_lisp ? rep_STR(data) : data; return write_to_process(stream, buf, len); } DEFUN("make-process", Fmake_process, Smake_process, (repv stream, repv fun, repv dir, repv prog, repv args), rep_Subr5) /* ::doc:rep.io.processes#make-process:: make-process [OUTPUT-STREAM] [FUN] [DIR] [PROGRAM] [ARGS] Creates a new process-object, OUTPUT-STREAM is where all output from this process goes, both stdout and stderr, FUN is a function to call each time the process running on this object changes state. DIR is the process' current directory, PROGRAM the filename of the program to run and ARGS a list of arguments passed to the process. Any of the arguments may be unspecified, in which case they can be set either by the functions provided or by the function called to create the actual running process. If the DIR parameter is nil it will be inherited from the `default-directory' variable of the current buffer. ::end:: */ { repv pr = rep_VAL(rep_ALLOC_CELL(sizeof(struct Proc))); if(pr != rep_NULL) { rep_GC_root gc_pr; rep_data_after_gc += sizeof (struct Proc); VPROC(pr)->pr_Car = process_type; VPROC(pr)->pr_Next = process_chain; process_chain = VPROC(pr); VPROC(pr)->pr_NotifyNext = NULL; PR_SET_STATUS(VPROC(pr), PR_DEAD); VPROC(pr)->pr_Pid = 0; VPROC(pr)->pr_Stdin = VPROC(pr)->pr_Stdout = 0; VPROC(pr)->pr_ExitStatus = -1; VPROC(pr)->pr_OutputStream = stream; VPROC(pr)->pr_ErrorStream = stream; VPROC(pr)->pr_NotifyFun = fun; VPROC(pr)->pr_Prog = prog; VPROC(pr)->pr_Args = args; VPROC(pr)->pr_ConnType = Qpipe; VPROC(pr)->pr_Dir = dir; /* Ensure that pr_Dir refers to an absolute local file */ rep_PUSHGC(gc_pr, pr); dir = Flocal_file_name(rep_STRINGP(dir) ? dir : rep_VAL(&dot)); rep_POPGC; if(dir && rep_STRINGP(dir)) VPROC(pr)->pr_Dir = dir; else VPROC(pr)->pr_Dir = Qnil; return pr; } else return rep_mem_error(); } DEFUN("close-process", Fclose_process, Sclose_process, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#close-process:: close-processes [PROCESS] Closes the stdin, stdout, and stderr streams of the asynchronous process- object PROCESS. ::end:: */ { rep_DECLARE1(proc, PROCESSP); close_proc_files(VPROC(proc)); return(Qnil); } DEFUN("start-process", Fstart_process, Sstart_process, (repv arg_list), rep_SubrN) /* ::doc:rep.io.processes#start-process:: start-process [PROCESS] [PROGRAM] [ARGS...] Starts a process running on process-object PROCESS. The child-process runs asynchronously with the editor. If PROCESS is unspecified the make-process function will be called (with zero arguments) to create one. PROGRAM is the filename of the binary image, it will be searched for in all directories listed in the `PATH' environment variable. ARGS are the arguments to give to the process. If any of the optional parameters are unspecified they should have been set in the PROCESS prior to calling this function. ::end:: */ { struct Proc *pr = NULL; repv res = Qnil; if(rep_CONSP(arg_list)) { if(PROCESSP(rep_CAR(arg_list))) pr = VPROC(rep_CAR(arg_list)); arg_list = rep_CDR(arg_list); } if(pr == NULL) { pr = VPROC(Fmake_process(Qnil, Qnil, Qnil, Qnil, Qnil)); if(pr == NULL) return rep_NULL; } if(rep_CONSP(arg_list)) { if(rep_STRINGP(rep_CAR(arg_list))) pr->pr_Prog = rep_CAR(arg_list); arg_list = rep_CDR(arg_list); if(rep_CONSP(arg_list)) pr->pr_Args = arg_list; } if(!rep_STRINGP(pr->pr_Prog)) { res = Fsignal(Qprocess_error, rep_list_2(rep_VAL(&no_prog), rep_VAL(pr))); } else { int numargs = rep_list_length(pr->pr_Args) + 1; char **argv = rep_alloc(sizeof(char *) * (numargs + 1)); if(argv) { int i; arg_list = pr->pr_Args; argv[0] = rep_STR(pr->pr_Prog); for(i = 1; i < numargs; i++) { if(rep_STRINGP(rep_CAR(arg_list))) argv[i] = rep_STR(rep_CAR(arg_list)); else argv[i] = ""; arg_list = rep_CDR(arg_list); } argv[i] = NULL; if(run_process(pr, argv, NULL)) res = rep_VAL(pr); else { res = Fsignal(Qprocess_error, rep_list_2(rep_VAL(&cant_start), rep_VAL(pr))); } rep_free(argv); } } return(res); } DEFUN("call-process", Fcall_process, Scall_process, (repv arg_list), rep_SubrN) /* ::doc:rep.io.processes#call-process:: call-process [PROCESS] [IN-FILE] [PROGRAM] [ARGS...] Starts a process running on process-object PROCESS. Waits for the child to exit, then returns the exit-value of the child. If PROCESS is unspecified the make-process function will be called (with zero arguments) to create one. IN-FILE is the name of the file to connect to the process' standard input, if this is not defined `/dev/null' is used. PROGRAM is the filename of the binary image, it will be searched for in all directories listed in the `PATH' environment variable. ARGS are the arguments to give to the process. If any of the optional parameters are unspecified they should have been set in the PROCESS prior to calling this function. ::end:: */ { struct Proc *pr = NULL; repv res = Qnil, infile = rep_VAL(&dev_null); if(rep_CONSP(arg_list)) { if(PROCESSP(rep_CAR(arg_list))) pr = VPROC(rep_CAR(arg_list)); arg_list = rep_CDR(arg_list); } if(pr == NULL) { pr = VPROC(Fmake_process(Qnil, Qnil, Qnil, Qnil, Qnil)); if(pr == NULL) return rep_NULL; } if(rep_CONSP(arg_list)) { if(rep_STRINGP(rep_CAR(arg_list))) infile = rep_CAR(arg_list); arg_list = rep_CDR(arg_list); if(rep_CONSP(arg_list)) { if(rep_STRINGP(rep_CAR(arg_list))) pr->pr_Prog = rep_CAR(arg_list); arg_list = rep_CDR(arg_list); if(rep_CONSP(arg_list)) pr->pr_Args = arg_list; } } if(infile != rep_VAL(&dev_null)) { /* Ensure that INFILE is a real name in the local file system, and that the file actually exists. */ rep_GC_root gc_arg_list, gc_pr, gc_infile; repv _pr = rep_VAL(pr); rep_PUSHGC(gc_arg_list, arg_list); rep_PUSHGC(gc_pr, _pr); rep_PUSHGC(gc_infile, infile); infile = Flocal_file_name(infile); if(infile && rep_STRINGP(infile)) { if(rep_NILP(rep_file_exists_p(infile))) res = rep_signal_file_error(infile); } else res = Fsignal(Qprocess_error, rep_LIST_2(rep_VAL(¬_local), rep_VAL(pr))); rep_POPGC; rep_POPGC; rep_POPGC; } if(rep_NILP(res) && !rep_STRINGP(pr->pr_Prog)) res = Fsignal(Qprocess_error, rep_LIST_2(rep_VAL(&no_prog), rep_VAL(pr))); if(rep_NILP(res)) { int numargs = rep_list_length(pr->pr_Args) + 1; char **argv = rep_alloc(sizeof(char *) * (numargs + 1)); if(argv) { int i; arg_list = pr->pr_Args; argv[0] = rep_STR(pr->pr_Prog); for(i = 1; i < numargs; i++) { if(rep_STRINGP(rep_CAR(arg_list))) argv[i] = rep_STR(rep_CAR(arg_list)); else argv[i] = ""; arg_list = rep_CDR(arg_list); } argv[i] = NULL; if(run_process(pr, argv, rep_STR(infile))) res = rep_MAKE_INT(pr->pr_ExitStatus); else { res = Fsignal(Qprocess_error, rep_list_2(rep_VAL(&cant_start), rep_VAL(pr))); } rep_free(argv); } } return(res); } /* If PROC is running asynchronously then send signal number SIGNAL to it. If SIGNAL-GROUP is non-nil send the signal to all processes in the process group of PROC. Returns t if successful. */ static repv do_signal_command(repv proc, int signal, repv signal_group) { repv res = Qnil; rep_DECLARE1(proc, PROCESSP); if(PR_ACTIVE_P(VPROC(proc))) { if(signal_process(VPROC(proc), signal, !rep_NILP(signal_group))) res = Qt; } else { res = Fsignal(Qprocess_error, rep_list_2(proc, rep_VAL(¬_running))); } return res; } DEFUN("interrupt-process", Finterrupt_process, Sinterrupt_process, (repv proc, repv grp), rep_Subr2) /* ::doc:rep.io.processes#interrupt-process:: interrupt-process PROCESS [SIGNAL-GROUP] Interrupt the asynchronous process PROCESS. If SIGNAL-GROUP is t, interrupt all child processes of PROCESS (it's process group). ::end:: */ { return do_signal_command(proc, SIGINT, grp); } DEFUN("kill-process", Fkill_process, Skill_process, (repv proc, repv grp), rep_Subr2) /* ::doc:rep.io.processes#kill-process:: kill-process PROCESS [SIGNAL-GROUP] Kill the asynchronous process PROCESS. If SIGNAL-GROUP is t, kill all child processes of PROCESS (it's process group). ::end:: */ { return do_signal_command(proc, SIGKILL, grp); } DEFUN("stop-process", Fstop_process, Sstop_process, (repv proc, repv grp), rep_Subr2) /* ::doc:rep.io.processes#stop-process:: stop-process PROCESS [SIGNAL-GROUP] Suspends execution of PROCESS, see `continue-process'. If SIGNAL-GROUP is non-nil also suspends the processes in the process group of PROCESS. ::end:: */ { return do_signal_command(proc, SIGSTOP, grp); } DEFUN("continue-process", Fcontinue_process, Scontinue_process, (repv proc, repv grp), rep_Subr2) /* ::doc:rep.io.processes#continue-process:: continue-process PROCESS [SIGNAL-GROUP] Restarts PROCESS after it has been stopped (via `stop-process'). If SIGNAL-GROUP is non-nil also continues the processes in the process group of PROCESS. ::end:: */ { repv res = Qt; rep_DECLARE1(proc, PROCESSP); if(PR_STOPPED_P(VPROC(proc))) { if(signal_process(VPROC(proc), SIGCONT, !rep_NILP(grp))) { PR_SET_STATUS(VPROC(proc), PR_RUNNING); res = Qt; queue_notify(VPROC(proc)); } } else { res = Fsignal(Qprocess_error, rep_list_2(proc, rep_VAL(¬_stopped))); } return(res); } DEFUN("signal-process", Fsignal_process, Ssignal_process, (repv proc, repv sig, repv grp), rep_Subr3) /* ::doc:rep.io.processes#signal_process:: signal-process PROCESS SIGNAL [SIGNAL-GROUP] Sends the signal SIGNAL to the process PROCESS. If SIGNAL-GROUP is non-nil also continues the processes in the process group of PROCESS. PROCESS may be either a Lisp process object, or an integer giving the process-id of a process (not necessarily started by rep). SIGNAL may either be a numeric signal, or a symbol naming a signal, i.e. the symbol `INT' for the UNIX SIGINT signal. ::end:: */ { static const struct { const char *name; int sig; } signals[] = { #ifdef SIGFPE { "FPE", SIGFPE }, #endif #ifdef SIGILL { "ILL", SIGILL }, #endif #ifdef SIGSEGV { "SEGV", SIGSEGV }, #endif #ifdef SIGBUS { "BUS", SIGBUS }, #endif #ifdef SIGABRT { "ABRT", SIGABRT }, #endif #ifdef SIGIOT { "IOT", SIGIOT }, #endif #ifdef SIGTRAP { "TRAP", SIGTRAP }, #endif #ifdef SIGEMT { "EMT", SIGEMT }, #endif #ifdef SIGSYS { "SYS", SIGSYS }, #endif #ifdef SIGTERM { "TERM", SIGTERM }, #endif #ifdef SIGINT { "INT", SIGINT }, #endif #ifdef SIGQUIT { "QUIT", SIGQUIT }, #endif #ifdef SIGKILL { "KILL", SIGKILL }, #endif #ifdef SIGHUP { "HUP", SIGHUP }, #endif #ifdef SIGALRM { "ALRM", SIGALRM }, #endif #ifdef SIGVTALRM { "VTALRM", SIGVTALRM }, #endif #ifdef SIGPROF { "PROF", SIGPROF }, #endif #ifdef SIGIO { "IO", SIGIO }, #endif #ifdef SIGURG { "URG", SIGURG }, #endif #ifdef SIGPOLL { "POLL", SIGPOLL }, #endif #ifdef SIGCHLD { "CHLD", SIGCHLD }, { "CLD", SIGCHLD }, #endif #ifdef SIGCONT { "CONT", SIGCONT }, #endif #ifdef SIGSTOP { "STOP", SIGSTOP }, #endif #ifdef SIGTSTP { "TSTP", SIGTSTP }, #endif #ifdef SIGTTIN { "TTIN", SIGTTIN }, #endif #ifdef SIGTTOU { "TTOU", SIGTTOU }, #endif #ifdef SIGPIPE { "PIPE", SIGPIPE }, #endif #ifdef SIGLOST { "LOST", SIGLOST }, #endif #ifdef SIGXCPU { "XCPU", SIGXCPU }, #endif #ifdef SIGXFSZ { "XFSZ", SIGXFSZ }, #endif #ifdef SIGUSR1 { "USR1", SIGUSR1 }, #endif #ifdef SIGUSR2 { "USR2", SIGUSR2 }, #endif #ifdef SIGWINCH { "WINCH", SIGWINCH }, #endif #ifdef SIGINFO { "INFO", SIGINFO }, #endif { 0 } }; int signal = -1; rep_DECLARE(1, proc, PROCESSP(proc) || rep_INTP(proc)); rep_DECLARE(2, sig, rep_INTP(sig) || rep_SYMBOLP(sig)); if (rep_INTP(sig)) signal = rep_INT(sig); else { char *s = rep_STR(rep_SYM(sig)->name); int i; for (i = 0; signals[i].name != 0; i++) { if (strcmp (s, signals[i].name) == 0) { signal = signals[i].sig; break; } } if (signal == -1) return Fsignal (Qerror, rep_list_2 (rep_VAL(&nosig), sig)); } if (rep_INTP(proc) && rep_INT(proc) > 0) { struct Proc *pr = process_chain; while (pr != 0 && pr->pr_Pid != rep_INT(proc)) pr = pr->pr_Next; if (pr != 0) proc = rep_VAL(pr); } if (PROCESSP(proc)) return do_signal_command (proc, signal, grp); else { int r; if (grp != Qnil) r = kill (- rep_INT(proc), signal); else r = kill (rep_INT(proc), signal); return (r == 0) ? Qt : Qnil; } } DEFUN("process-exit-status", Fprocess_exit_status, Sprocess_exit_status, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-exit-status:: process-exit-status PROCESS Returns the unprocessed exit-status of the last process to be run on the process-object PROCESS. If PROCESS is currently running, return nil. ::end:: */ { repv res = Qnil; rep_DECLARE1(proc, PROCESSP); if(PR_DEAD_P(VPROC(proc))) { if(VPROC(proc)->pr_ExitStatus != -1) res = rep_MAKE_INT(VPROC(proc)->pr_ExitStatus); } return(res); } DEFUN("process-exit-value", Fprocess_exit_value, Sprocess_exit_value, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-exit-value:: process-exit-value PROCESS Returns the return-value of the last process to be run on PROCESS, or nil if: a) no process has run on PROCESS b) PROCESS is still running c) PROCESS exited abnormally ::end:: */ { repv res = Qnil; rep_DECLARE1(proc, PROCESSP); if((PR_DEAD_P(VPROC(proc))) && (VPROC(proc)->pr_ExitStatus != -1)) res = rep_MAKE_INT(WEXITSTATUS(VPROC(proc)->pr_ExitStatus)); return(res); } DEFUN("process-id", Fprocess_id, Sprocess_id, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-id:: process-id [PROCESS] If PROCESS is running or stopped, return the process-identifier associated with it (ie, its pid). If PROCESS is nil, return the process id of the Lisp interpreter. ::end:: */ { if (proc == Qnil) return rep_MAKE_INT(getpid ()); else { repv res = Qnil; rep_DECLARE1(proc, PROCESSP); if(PR_ACTIVE_P(VPROC(proc))) res = rep_MAKE_INT(VPROC(proc)->pr_Pid); return(res); } } DEFUN("process-running-p", Fprocess_running_p, Sprocess_running_p, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-running-p:: process-running-p PROCESS Return t if PROCESS is running. ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); if(PR_RUNNING_P(VPROC(proc))) res = Qt; else res = Qnil; return(res); } DEFUN("process-stopped-p", Fprocess_stopped_p, Sprocess_stopped_p, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-stopped-p:: process-stopped-p PROCESS Return t if PROCESS has been stopped. ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); if(PR_STOPPED_P(VPROC(proc))) res = Qt; else res = Qnil; return(res); } DEFUN("process-in-use-p", Fprocess_in_use_p, Sprocess_in_use_p, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-in-use-p:: process-in-use-p PROCESS Similar to `process-running-p' except that this returns t even when the process has stopped. ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); if(PR_ACTIVE_P(VPROC(proc))) res = Qt; else res = Qnil; return(res); } DEFUN("processp", Fprocessp, Sprocessp, (repv arg), rep_Subr1) /* ::doc:rep.io.processes#process-p:: processp ARG Return t is ARG is a process-object. ::end:: */ { if(PROCESSP(arg)) return(Qt); return(Qnil); } DEFUN("process-prog", Fprocess_prog, Sprocess_prog, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-prog:: process-prog PROCESS Return the name of the program in PROCESS. ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); res = VPROC(proc)->pr_Prog; return(res); } DEFUN("set-process-prog", Fset_process_prog, Sset_process_prog, (repv proc, repv prog), rep_Subr2) /* ::doc:rep.io.processes#set-process-prog:: set-process-prog PROCESS PROGRAM Sets the name of the program to run on PROCESS to FILE. ::end:: */ { rep_DECLARE1(proc, PROCESSP); rep_DECLARE2(prog, rep_STRINGP); VPROC(proc)->pr_Prog = prog; return(prog); } DEFUN("process-args", Fprocess_args, Sprocess_args, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-args:: process-args PROCESS Return the list of arguments to PROCESS. ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); res = VPROC(proc)->pr_Args; return(res); } DEFUN("set-process-args", Fset_process_args, Sset_process_args, (repv proc, repv args), rep_Subr2) /* ::doc:rep.io.processes#set-process-args:: set-process-args PROCESS ARG-LIST Set the arguments to PROCESS. ::end:: */ { rep_DECLARE1(proc, PROCESSP); if(!rep_NILP(args) && !rep_CONSP(args)) return(rep_signal_arg_error(args, 2)); VPROC(proc)->pr_Args = args; return(args); } DEFUN("process-output-stream", Fprocess_output_stream, Sprocess_output_stream, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-output-stream:: process-output-stream PROCESS Return the stream to which all output from PROCESS is sent. ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); res = VPROC(proc)->pr_OutputStream; return(res); } DEFUN("set-process-output-stream", Fset_process_output_stream, Sset_process_output_stream, (repv proc, repv stream), rep_Subr2) /* ::doc:rep.io.processes#set-process-output-stream:: set-process-output-stream PROCESS STREAM Set the output-stream of PROCESS to STREAM. nil means discard all output. ::end:: */ { rep_DECLARE1(proc, PROCESSP); VPROC(proc)->pr_OutputStream = stream; return(stream); } DEFUN("process-error-stream", Fprocess_error_stream, Sprocess_error_stream, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-error-stream:: process-error-stream PROCESS Return the stream to which all standard-error output from PROCESS is sent. ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); res = VPROC(proc)->pr_ErrorStream; return(res); } DEFUN("set-process-error-stream", Fset_process_error_stream, Sset_process_error_stream, (repv proc, repv stream), rep_Subr2) /* ::doc:rep.io.processes#set-process-error-stream:: set-process-error-stream PROCESS STREAM Set the error-stream of PROCESS to STREAM. nil means discard all output. Note that this currently only works correctly with pipe connections. ::end:: */ { rep_DECLARE1(proc, PROCESSP); VPROC(proc)->pr_ErrorStream = stream; return(stream); } DEFUN("process-function", Fprocess_function, Sprocess_function, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-function:: process-function PROCESS Return the function which is called when PROCESS changes state (i.e. it exits or is stopped). ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); res = VPROC(proc)->pr_NotifyFun; return(res); } DEFUN("set-process-function", Fset_process_function, Sset_process_function, (repv proc, repv fn), rep_Subr2) /* ::doc:rep.io.processes#set-process-function:: set-process-function PROCESS FUNCTION Set the function which is called when PROCESS changes state to FUNCTION. ::end:: */ { rep_DECLARE1(proc, PROCESSP); VPROC(proc)->pr_NotifyFun = fn; return(fn); } DEFUN("process-dir", Fprocess_dir, Sprocess_dir, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-dir:: process-dir PROCESS Return the name of the directory which becomes the working directory of PROCESS when it is started. ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); res = VPROC(proc)->pr_Dir; return(res); } DEFUN("set-process-dir", Fset_process_dir, Sset_process_dir, (repv proc, repv dir), rep_Subr2) /* ::doc:rep.io.processes#set-process-dir:: set-process-dir PROCESS DIR Set the directory of PROCESS to DIR. ::end:: */ { rep_GC_root gc_proc; rep_DECLARE1(proc, PROCESSP); rep_DECLARE2(dir, rep_STRINGP); /* Ensure that pr_Dir refers to an absolute local file */ rep_PUSHGC(gc_proc, proc); dir = Flocal_file_name(rep_STRINGP(dir) ? dir : rep_VAL(&dot)); rep_POPGC; if(dir && rep_STRINGP(dir)) VPROC(proc)->pr_Dir = dir; else VPROC(proc)->pr_Dir = Qnil; return VPROC(proc)->pr_Dir;; } DEFUN("process-connection-type", Fprocess_connection_type, Sprocess_connection_type, (repv proc), rep_Subr1) /* ::doc:rep.io.processes#process-connection-type:: process-connection-type PROCESS Returns a symbol defining the type of stream (i.e. pipe, pty, or socketpair) used to connect PROCESS with its physical process. ::end:: */ { repv res; rep_DECLARE1(proc, PROCESSP); res = VPROC(proc)->pr_ConnType; return(res); } DEFUN("set-process-connection-type", Fset_process_connection_type, Sset_process_connection_type, (repv proc, repv type), rep_Subr2) /* ::doc:rep.io.processes#set-process-connection-type:: set-process-connection-type PROCESS TYPE Define how PROCESS communicates with it's child process, TYPE may be one of the following symbols: pty Use a pty pipe Three pipes are used socketpair Use a socketpair This function can only be used when PROCESS is not in use. Note that only the `pipe' connection type allows process output and process error output to be differentiated. ::end:: */ { rep_DECLARE1(proc, PROCESSP); if(PR_ACTIVE_P(VPROC(proc))) type = Fsignal(Qprocess_error, rep_list_2(rep_VAL(&in_use), proc)); else VPROC(proc)->pr_ConnType = type; return(type); } DEFUN("active-processes", Factive_processes, Sactive_processes, (void), rep_Subr0) /* ::doc:rep.io.processes#active-processes:: active-processes Return a list containing all active process objects. ::end:: */ { repv head = Qnil; repv *ptr = &head; struct Proc *p = process_chain; while(p != 0) { if(PR_ACTIVE_P(p)) { *ptr = Fcons(rep_VAL(p), Qnil); ptr = &(rep_CDR(*ptr)); } p = p->pr_Next; } return head; } #define MAX_HANDLERS 16 static void (*input_handlers[MAX_HANDLERS])(int); static int n_input_handlers = 0; void rep_register_process_input_handler (void (*handler)(int)) { assert (n_input_handlers < MAX_HANDLERS); input_handlers[n_input_handlers++] = handler; } DEFUN("accept-process-output", Faccept_process_output, Saccept_process_output, (repv secs, repv msecs), rep_Subr2) /* ::doc:rep.io.processes#accept-process-output:: accept-process-output [SECONDS] [MILLISECONDS] Wait SECONDS plus MILLISECONDS for output from any asynchronous subprocesses. If any arrives, process it, then return nil. Otherwise return t. Note that output includes notification of process termination. ::end:: */ { repv result = Qt; rep_DECLARE2_OPT(secs, rep_NUMERICP); rep_DECLARE3_OPT(msecs, rep_NUMERICP); /* Only wait for output if nothing already waiting. */ if(!got_sigchld && !notify_chain) { result = (rep_accept_input_for_callbacks ((rep_get_long_int (secs) * 1000) + (rep_get_long_int (msecs)), n_input_handlers, input_handlers)); } if(got_sigchld || notify_chain) { result = Qnil; rep_proc_periodically(); } return result; } DEFUN("accept-process-output-1", Faccept_process_output_1, Saccept_process_output_1, (repv process, repv secs, repv msecs), rep_Subr3) /* ::doc:rep.io.processes#accept-process-output-1:: accept-process-output-1 PROCESS [SECONDS] [MILLISECONDS] Wait SECONDS plus MILLISECONDS for output from the asynchronous subprocess PROCESS. If any arrives, process it, then return nil. Otherwise return t. Note that output includes notification of process termination. ::end:: */ { repv result = Qt; rep_DECLARE1 (process, PROCESSP); rep_DECLARE2_OPT(secs, rep_NUMERICP); rep_DECLARE3_OPT(msecs, rep_NUMERICP); /* Only wait for output if nothing already waiting. */ if (got_sigchld) check_for_zombies (); if (!notify_queued_p (VPROC (process))) { int fds[2]; fds[0] = VPROC (process)->pr_Stdout; fds[1] = VPROC (process)->pr_Stderr; result = (rep_accept_input_for_fds ((rep_get_long_int (secs) * 1000) + rep_get_long_int (msecs), 2, fds)); } if (got_sigchld) check_for_zombies (); if (notify_queued_p (VPROC (process))) { notify_1 (VPROC (process)); result = Qt; } return result; } /* Don't use libc system (), since it blocks signals. */ repv rep_system (char *command) { int pid, status; int interrupt_count = 0; pid = fork (); switch (pid) { char *argv[4]; repv ret; DEFSTRING (cant_fork, "can't fork ()"); case -1: return Fsignal (Qerror, Fcons (rep_VAL (&cant_fork), Qnil)); case 0: child_build_environ (); argv[0] = "sh"; argv[1] = "-c"; argv[2] = command; argv[3] = 0; signal (SIGPIPE, SIG_DFL); execve ("/bin/sh", argv, environ); perror ("can't exec /bin/sh"); _exit (255); default: ret = Qnil; rep_sig_restart (SIGCHLD, rep_FALSE); while (1) { struct timeval timeout; int x; rep_TEST_INT_SLOW; if (rep_INTERRUPTP) { static int signals[] = { SIGINT, SIGTERM, SIGQUIT }; if (interrupt_count < 3) interrupt_count++; kill (pid, signals[interrupt_count - 1]); if (rep_throw_value == rep_int_cell) rep_throw_value = rep_NULL; } x = waitpid (pid, &status, WNOHANG); if (x == -1) { if (errno != EINTR && errno != EAGAIN) { DEFSTRING (cant_waitpid, "can't waitpid ()"); ret = Fsignal (Qerror, Fcons (rep_VAL (&cant_waitpid), Qnil)); break; } } else if (x == pid) { ret = rep_MAKE_INT (status); break; } timeout.tv_sec = 1; timeout.tv_usec = 0; select (FD_SETSIZE, NULL, NULL, NULL, &timeout); } rep_sig_restart (SIGCHLD, rep_TRUE); return ret; } } void rep_proc_init(void) { repv tem; /* Setup SIGCHLD stuff. */ sigemptyset(&chld_sigset); sigaddset(&chld_sigset, SIGCHLD); chld_sigact.sa_handler = sigchld_handler; chld_sigact.sa_mask = chld_sigset; #ifdef SA_RESTART chld_sigact.sa_flags = SA_RESTART; #else chld_sigact.sa_flags = 0; #endif sigaction(SIGCHLD, &chld_sigact, NULL); /* Is this necessary?? Better safe than core-dumped ;-) */ signal(SIGPIPE, SIG_IGN); rep_INTERN(pipe); rep_INTERN(pty); rep_INTERN(socketpair); tem = rep_push_structure ("rep.io.processes"); rep_ADD_SUBR(Sclose_process); rep_ADD_SUBR(Smake_process); rep_ADD_SUBR(Sstart_process); rep_ADD_SUBR(Scall_process); rep_ADD_SUBR(Sinterrupt_process); rep_ADD_SUBR(Skill_process); rep_ADD_SUBR(Sstop_process); rep_ADD_SUBR(Scontinue_process); rep_ADD_SUBR(Ssignal_process); rep_ADD_SUBR(Sprocess_exit_status); rep_ADD_SUBR(Sprocess_exit_value); rep_ADD_SUBR(Sprocess_id); rep_ADD_SUBR(Sprocess_running_p); rep_ADD_SUBR(Sprocess_stopped_p); rep_ADD_SUBR(Sprocess_in_use_p); rep_ADD_SUBR(Sprocessp); rep_ADD_SUBR(Sprocess_prog); rep_ADD_SUBR(Sset_process_prog); rep_ADD_SUBR(Sprocess_args); rep_ADD_SUBR(Sset_process_args); rep_ADD_SUBR(Sprocess_output_stream); rep_ADD_SUBR(Sset_process_output_stream); rep_ADD_SUBR(Sprocess_error_stream); rep_ADD_SUBR(Sset_process_error_stream); rep_ADD_SUBR(Sprocess_function); rep_ADD_SUBR(Sset_process_function); rep_ADD_SUBR(Sprocess_dir); rep_ADD_SUBR(Sset_process_dir); rep_ADD_SUBR(Sprocess_connection_type); rep_ADD_SUBR(Sset_process_connection_type); rep_ADD_SUBR(Sactive_processes); rep_ADD_SUBR(Saccept_process_output); rep_ADD_SUBR(Saccept_process_output_1); rep_pop_structure (tem); process_type = rep_register_new_type ("subprocess", rep_ptr_cmp, proc_prin, proc_prin, proc_sweep, proc_mark, mark_active_processes, 0, 0, proc_putc, proc_puts, 0, 0); rep_register_process_input_handler (read_from_process); rep_add_event_loop_callback (proc_periodically); } void rep_proc_kill(void) { struct Proc *pr; signal(SIGCHLD, SIG_DFL); pr = process_chain; while(pr) { struct Proc *nxt = pr->pr_Next; kill_process(pr); pr = nxt; } process_chain = NULL; } librep-0.90.2/src/unix_main.c0000644000175200017520000005162111245011153015005 0ustar chrischris/* unix_main.c -- Miscellaneous functions for Unix Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #include #include #include #include #include #include #include #include #include #ifdef HAVE_FCNTL_H # include #endif #ifdef HAVE_SYS_TIME_H # include #endif #ifdef HAVE_UNISTD_H # include #endif #ifdef HAVE_SYS_UTSNAME_H # include #endif #ifdef HAVE_STRERROR # include #else extern int sys_nerr, errno; extern char *sys_errlist[]; #endif #ifdef ENVIRON_UNDECLARED extern char **environ; #endif void (*rep_redisplay_fun)(void); long (*rep_wait_for_input_fun)(void *inputs, unsigned long timeout_msecs); int rep_input_timeout_secs = 1; /* Support functions */ #ifndef HAVE_STRERROR DEFSTRING(unknown_err, "Unknown system error"); #endif repv rep_lookup_errno(void) { #ifdef HAVE_STRERROR return rep_string_dup(strerror(errno)); #else if(errno >= sys_nerr) return rep_string_dup(sys_errlist[errno]); else return rep_VAL(&unknown_err); #endif } unsigned long rep_getpid (void) { return getpid (); } unsigned long rep_time(void) { return time(0); } rep_long_long rep_utime (void) { rep_long_long t; #ifdef HAVE_GETTIMEOFDAY struct timeval time; gettimeofday (&time, 0); t = ((rep_long_long) time.tv_sec * 1000000) + time.tv_usec; #else t = (rep_long_long) rep_time () * 1000000; #endif return t; } void rep_sleep_for(long secs, long msecs) { struct timeval timeout; timeout.tv_sec = secs + msecs / 1000; timeout.tv_usec = (msecs % 1000) * 1000; select(FD_SETSIZE, NULL, NULL, NULL, &timeout); } repv rep_user_login_name(void) { /* Just look this up once, then use the saved copy. */ static repv user_login_name; char *tmp; if(user_login_name) return user_login_name; if(!(tmp = getlogin())) { struct passwd *pwd; if(!(pwd = getpwuid(geteuid()))) return rep_NULL; tmp = pwd->pw_name; } user_login_name = rep_string_dup(tmp); rep_mark_static(&user_login_name); return user_login_name; } repv rep_user_full_name(void) { struct passwd *pwd; static repv user_full_name; if(user_full_name) return user_full_name; if(!(pwd = getpwuid(geteuid()))) return rep_NULL; #ifndef FULL_NAME_TERMINATOR user_full_name = rep_string_dup(pwd->pw_gecos); #else { char *end = strchr(pwd->pw_gecos, FULL_NAME_TERMINATOR); if(end) user_full_name = rep_string_dupn(pwd->pw_gecos, end - pwd->pw_gecos); else user_full_name = rep_string_dup(pwd->pw_gecos); } #endif rep_mark_static(&user_full_name); return user_full_name; } DEFSTRING(no_home, "Can't find home directory"); repv rep_user_home_directory(repv user) { static repv user_home_directory; if(rep_NILP(user) && user_home_directory) return user_home_directory; else { repv dir; char *src = 0; int len; if(rep_NILP(user)) src = getenv("HOME"); if(src == 0) { struct passwd *pwd; if(rep_NILP(user)) pwd = getpwuid(geteuid()); else pwd = getpwnam(rep_STR(user)); if(pwd == 0 || pwd->pw_dir == 0) return Fsignal(Qerror, rep_LIST_2(rep_VAL(&no_home), user)); src = pwd->pw_dir; } len = strlen(src); if(src[len] != '/') { dir = rep_string_dupn(src, len + 1); rep_STR(dir)[len] = '/'; rep_STR(dir)[len+1] = 0; } else dir = rep_string_dup(src); if(rep_NILP(user)) { user_home_directory = dir; rep_mark_static(&user_home_directory); } return dir; } } repv rep_system_name(void) { char buf[256]; struct hostent *h; static repv system_name; if(system_name) return system_name; #ifdef HAVE_GETHOSTNAME if(gethostname(buf, 256)) return rep_NULL; #else { struct utsname uts; uname(&uts); strncpy(buf, uts.nodename, 256); } #endif h = gethostbyname(buf); if(h) { if(!strchr(h->h_name, '.')) { /* The official name is not fully qualified. Try looking through the list of alternatives. */ char **aliases = h->h_aliases; while(*aliases && !strchr(*aliases, '.')) aliases++; system_name = rep_string_dup(*aliases ? *aliases : h->h_name); } else system_name = rep_string_dup((char *)h->h_name); } else system_name = rep_string_dup(buf); rep_mark_static(&system_name); return system_name; } /* Main input loop */ /* This is the set of fds we're waiting for input from. */ static fd_set input_fdset; /* For every bit set in unix_fd_read_set there should be a corresponding function in here that will be called when input becomes available. -- Is this really such a good idea, it's a lot of wasted space.. */ static void (*input_actions[FD_SETSIZE])(int); /* A bit set in this array means that the corresponding fd has input read but not yet handled. */ static fd_set input_pending; static int input_pending_count; void (*rep_register_input_fd_fun)(int fd, void (*callback)(int fd)) = 0; void (*rep_deregister_input_fd_fun)(int fd) = 0; #define MAX_EVENT_LOOP_CALLBACKS 16 static int next_event_loop_callback; static rep_bool (*event_loop_callbacks[MAX_EVENT_LOOP_CALLBACKS])(void); void rep_register_input_fd(int fd, void (*callback)(int fd)) { FD_SET(fd, &input_fdset); input_actions[fd] = callback; if (rep_register_input_fd_fun != 0) (*rep_register_input_fd_fun) (fd, callback); rep_unix_set_fd_cloexec(fd); } void rep_deregister_input_fd(int fd) { FD_CLR(fd, &input_fdset); input_actions[fd] = NULL; if (rep_deregister_input_fd_fun != 0) (*rep_deregister_input_fd_fun) (fd); } void rep_map_inputs (void (*fun)(int fd, void (*callback)(int))) { int i; for (i = 0; i < FD_SETSIZE; i++) { if (input_actions[i] != 0) fun (i, input_actions[i]); } } void rep_mark_input_pending(int fd) { if(!FD_ISSET(fd, &input_pending)) { FD_SET(fd, &input_pending); input_pending_count++; } } void rep_unix_set_fd_nonblocking(int fd) { int flags = fcntl(fd, F_GETFL, 0); if(flags != -1) fcntl(fd, F_SETFL, flags | O_NONBLOCK); } void rep_unix_set_fd_blocking(int fd) { int flags = fcntl(fd, F_GETFL, 0); if(flags != -1) fcntl(fd, F_SETFL, flags & ~O_NONBLOCK); } void rep_unix_set_fd_cloexec(int fd) { /* Set close on exec flag. */ int tem = fcntl(fd, F_GETFD, 0); if(tem != -1) fcntl(fd, F_SETFD, tem | FD_CLOEXEC); } /* Turns on or off restarted system calls for SIG */ void rep_sig_restart(int sig, rep_bool flag) { #if defined (HAVE_SIGINTERRUPT) siginterrupt (sig, !flag); #else struct sigaction act; sigaction (sig, 0, &act); if(flag) { # if defined (SA_RESTART) act.sa_flags |= SA_RESTART; # elif defined (SA_INTERRUPT) act.sa_flags &= ~SA_INTERRUPT; # endif } else { # if defined (SA_RESTART) act.sa_flags &= ~SA_RESTART; # elif defined (SA_INTERRUPT) act.sa_flags |= SA_INTERRUPT; # endif } sigaction(sig, &act, 0); #endif /* !HAVE_SIGINTERRUPT */ } void rep_add_event_loop_callback (rep_bool (*callback)(void)) { if (next_event_loop_callback == MAX_EVENT_LOOP_CALLBACKS) abort (); event_loop_callbacks [next_event_loop_callback++] = callback; } rep_bool rep_proc_periodically (void) { rep_bool ret = rep_FALSE; int i; for (i = 0; i < next_event_loop_callback; i++) { if (event_loop_callbacks[i] ()) ret = rep_TRUE; } return ret; } /* Wait for input for no longer than TIMEOUT-MSECS for input fds defined by INPUTS. If input arrived return the number of ready fds, with the actual fds defined by the fdset INPUTS. Return zero if the timeout was reached. */ static int wait_for_input(fd_set *inputs, unsigned long timeout_msecs) { fd_set copy; int ready = -1; if(input_pending_count > 0) { /* Check the pending inputs first.. */ fd_set out; int i, count = 0, seen = 0; for(i = 0; seen < input_pending_count && i < FD_SETSIZE; i++) { if(FD_ISSET(i, &input_pending)) { seen++; if(FD_ISSET(i, inputs)) { if(count == 0) FD_ZERO(&out); FD_SET(i, &out); count++; } } } if(count > 0) { memcpy(inputs, &out, sizeof(out)); return count; } } /* Allow embedders to override this part of the function. */ if (rep_wait_for_input_fun != 0) return (*rep_wait_for_input_fun) (inputs, timeout_msecs); /* Break the timeout into one-second chunks, then check for interrupt between each call to select. */ do { struct timeval timeout; unsigned long max_sleep = rep_max_sleep_for (); unsigned long this_timeout_msecs = MIN (timeout_msecs, rep_input_timeout_secs * 1000); unsigned long actual_timeout_msecs = MIN (this_timeout_msecs, max_sleep); timeout.tv_sec = actual_timeout_msecs / 1000; timeout.tv_usec = (actual_timeout_msecs % 1000) * 1000; memcpy (©, inputs, sizeof (copy)); /* Dont test for interrupts before the first call to select() */ if (ready == 0) { rep_TEST_INT_SLOW; if (rep_INTERRUPTP) break; } /* Don't want select() to restart after a SIGCHLD or SIGALRM; there may be a notification to dispatch. */ rep_sig_restart(SIGCHLD, rep_FALSE); rep_sig_restart(SIGALRM, rep_FALSE); ready = select(FD_SETSIZE, ©, NULL, NULL, &timeout); rep_sig_restart(SIGALRM, rep_TRUE); rep_sig_restart(SIGCHLD, rep_TRUE); if (ready == 0 && actual_timeout_msecs < this_timeout_msecs) { Fthread_suspend (Qnil, rep_MAKE_INT (this_timeout_msecs - actual_timeout_msecs)); } timeout_msecs -= this_timeout_msecs; } while (ready == 0 && timeout_msecs > 0); memcpy (inputs, ©, sizeof (copy)); return ready; } /* Handle the READY fds with pending input (defined by fdset INPUTS). Return true if the display might require updating. Returns immediately if a Lisp error has occurred. */ static rep_bool handle_input(fd_set *inputs, int ready) { static long idle_period; rep_bool refreshp = rep_FALSE; if(ready > 0) { int i; idle_period = 0; for(i = 0; i < FD_SETSIZE && ready > 0 && !rep_INTERRUPTP; i++) { if(FD_ISSET(i, inputs)) { ready--; if(FD_ISSET(i, &input_pending)) { FD_CLR(i, &input_pending); input_pending_count--; } if(input_actions[i] != NULL) { input_actions[i](i); refreshp = rep_TRUE; } } } } else if(ready == 0) { /* A timeout. */ if(rep_INTERRUPTP || rep_on_idle(idle_period)) refreshp = rep_TRUE; idle_period++; } if(!rep_INTERRUPTP && rep_proc_periodically()) refreshp = rep_TRUE; return refreshp; } /* The input handler loop. */ repv rep_event_loop(void) { repv result = Qnil; if (rep_redisplay_fun != 0) (*rep_redisplay_fun)(); while(1) { int ready; rep_bool refreshp = rep_FALSE; fd_set copy; if (rep_throw_value == rep_NULL) { memcpy(©, &input_fdset, sizeof(copy)); ready = wait_for_input(©, rep_input_timeout_secs * 1000); refreshp = handle_input(©, ready); } /* Check for exceptional conditions. */ if(rep_throw_value != rep_NULL) { if(rep_handle_input_exception(&result)) return result; else refreshp = rep_TRUE; } if(refreshp && rep_redisplay_fun != 0) (*rep_redisplay_fun)(); #ifdef C_ALLOCA /* Using the C implementation of alloca. So garbage collect anything below the current stack depth. */ alloca(0); #endif } return result; } repv rep_sit_for(unsigned long timeout_msecs) { fd_set copy; int ready; if(timeout_msecs != 0 && rep_redisplay_fun != 0) (*rep_redisplay_fun)(); memcpy(©, &input_fdset, sizeof(copy)); ready = wait_for_input(©, timeout_msecs); if(rep_INTERRUPTP) return rep_NULL; else return (ready > 0) ? Qnil : Qt; } /* Wait TIMEOUT_MSECS for input, ignoring any input fds that would invoke any callback function except CALLBACKS. Return Qnil if any input was serviced, Qt if the timeout expired, rep_NULL for an error. */ repv rep_accept_input_for_callbacks (unsigned long timeout_msecs, int ncallbacks, void (**callbacks)(int)) { fd_set copy; int ready, i; FD_ZERO(©); for(i = 0; i < FD_SETSIZE; i++) { if(FD_ISSET(i, &input_fdset)) { int j; for (j = 0; j < ncallbacks; j++) { if (input_actions[i] == callbacks[j]) { FD_SET(i, ©); break; } } } } ready = wait_for_input(©, timeout_msecs); if(ready > 0 && !rep_INTERRUPTP) handle_input(©, ready); if(rep_INTERRUPTP) return rep_NULL; else return ready > 0 ? Qnil : Qt; } /* Wait TIMEOUT_MSECS for input from the NFDS file descriptors stored in FDS. Return Qnil if any input was serviced, Qt if the timeout expired, rep_NULL for an error. */ repv rep_accept_input_for_fds (unsigned long timeout_msecs, int nfds, int *fds) { fd_set copy; int ready, i; FD_ZERO(©); for(i = 0; i < nfds; i++) { if(FD_ISSET(fds[i], &input_fdset)) FD_SET(fds[i], ©); } ready = wait_for_input(©, timeout_msecs); if(ready > 0 && !rep_INTERRUPTP) handle_input(©, ready); if(rep_INTERRUPTP) return rep_NULL; else return ready > 0 ? Qnil : Qt; } /* obsolete, for compatibility only */ repv rep_accept_input(unsigned long timeout_msecs, void (*callback)(int)) { return rep_accept_input_for_callbacks (timeout_msecs, 1, &callback); } rep_bool rep_poll_input(int fd) { fd_set in; FD_ZERO(&in); FD_SET(fd, &in); return wait_for_input(&in, 0); } /* Memory allocation; most of these are normally macros in unix_defs.h */ #ifdef DEBUG_SYS_ALLOC struct alloc_data { struct alloc_data *next; size_t size; void *function; double unused; /* double to force good alignment */ }; #define SIZEOF_ALLOC_DATA (sizeof (struct alloc_data) - sizeof (double)) static struct alloc_data *allocations; void * rep_alloc(unsigned int length) { void *mem; length += SIZEOF_ALLOC_DATA; mem = malloc(length); if(mem != 0) { struct alloc_data *x = mem; /* Check that the alignment promised actually occurs */ assert((((rep_PTR_SIZED_INT)mem) & (rep_MALLOC_ALIGNMENT - 1)) == 0); mem = ((char *)mem) + SIZEOF_ALLOC_DATA; x->next = allocations; allocations = x; x->size = length - SIZEOF_ALLOC_DATA; x->function = rep_db_return_address(); } return mem; } void * rep_realloc(void *ptr, unsigned int length) { void *mem; length += SIZEOF_ALLOC_DATA; ptr = (void *)(((char *)ptr) - SIZEOF_ALLOC_DATA); mem = realloc(ptr, length); if(mem != 0) { struct alloc_data *x = mem; /* Check that the alignment promised actually occurs */ assert((((rep_PTR_SIZED_INT)mem) & (rep_MALLOC_ALIGNMENT - 1)) == 0); if(allocations == ptr) allocations = x; else { struct alloc_data *p = allocations; while(p->next != ptr) p = p->next; p->next = x; } mem = ((char *)mem) + SIZEOF_ALLOC_DATA; x->size = length - SIZEOF_ALLOC_DATA; x->function = rep_db_return_address(); } return mem; } void rep_free(void *ptr) { struct alloc_data *x = (struct alloc_data *)(((char *)ptr) - SIZEOF_ALLOC_DATA); struct alloc_data **p = &allocations; while(*p != 0 && (*p) != x) p = &((*p)->next); assert(*p != 0); (*p) = x->next; free(x); } void rep_print_allocations(void) { if(allocations != 0) { struct alloc_data *x = allocations; fprintf(stderr, "\n\nOutstanding allocations:\n\n"); while(x != 0) { char *sname; void *saddr; fprintf(stderr, "\t(%p, %d)", ((char *)x) + SIZEOF_ALLOC_DATA, x->size); if(rep_find_c_symbol(x->function, &sname, &saddr)) fprintf(stderr, "\t\t<%s+%d>", sname, x->function - saddr); fprintf(stderr, "\n"); x = x->next; } } } DEFUN("unix-print-allocations", Funix_print_allocations, Sunix_print_allocations, (void), rep_Subr0) /* ::doc:rep.lang.debug#unix-print-allocations:: unix-print-allocations Output a list of all allocated memory blocks to standard error. ::end:: */ { rep_print_allocations(); return Qt; } #endif /* Standard signal handlers */ static volatile rep_bool in_fatal_signal_handler; /* Invoked by any of the handlable error reporting signals */ static RETSIGTYPE fatal_signal_handler(int sig) { /* Sometimes this function can get in an infinite loop, even with the in_fatal_signal_handler exclusion? Does this help..? */ signal(sig, SIG_DFL); /* Check for nested calls to this function */ if(in_fatal_signal_handler) raise(sig); in_fatal_signal_handler = rep_TRUE; #ifdef HAVE_PSIGNAL psignal(sig, "rep: received fatal signal"); #else # ifdef HAVE_STRSIGNAL fprintf(stderr, "rep: received fatal signal: %s\n", strsignal(sig)); # else fprintf(stderr, "rep: received fatal signal: %d\n", sig); # endif #endif /* Save the C backtrace */ rep_db_print_backtrace(rep_common_db, "fatal_signal_handler"); /* Output all debug buffers */ rep_db_spew_all(); /* Try and output the Lisp call stack; this may or may not provoke another error, but who cares.. */ fprintf(stderr, "\nLisp backtrace:\n"); Fbacktrace(Fstderr_file()); fputs("\n", stderr); /* Now reraise the signal, since it's currently blocked the default action will occur, i.e. termination */ raise(sig); } /* Invoked by SIGINT (i.e. ^C) */ static RETSIGTYPE interrupt_signal_handler(int sig) { if (rep_throw_value == rep_int_cell) { signal (sig, SIG_DFL); raise (sig); } else { rep_throw_value = rep_int_cell; signal (sig, interrupt_signal_handler); } } /* Invoked by trappable termination signals */ static RETSIGTYPE termination_signal_handler(int sig) { if (rep_throw_value == rep_term_cell) { signal (sig, SIG_DFL); raise (sig); } else { rep_throw_value = rep_term_cell; signal (sig, termination_signal_handler); } } /* Invoked by SIGUSR1 or SIGUSR2 */ static RETSIGTYPE usr_signal_handler (int sig) { switch (sig) { case SIGUSR1: fprintf(stderr, "\n\nLisp backtrace:\n"); Fbacktrace(Fstderr_file()); fputs("\n\n", stderr); break; case SIGUSR2: fprintf (stderr, "\n\nDebug buffers:\n"); rep_db_spew_all (); fputc ('\n', stderr); break; } signal (sig, usr_signal_handler); } /* Initialisation */ /* This function is called _before_ almost anything else; but most importantly, it's called before sys_init() (i.e. we start opening displays) */ void rep_pre_sys_os_init(void) { FD_ZERO(&input_fdset); FD_ZERO(&input_pending); /* First the error signals */ #ifndef IGNORE_FATAL_SIGNALS #ifdef SIGFPE if(signal(SIGFPE, fatal_signal_handler) == SIG_IGN) signal(SIGFPE, SIG_IGN); #endif #ifdef SIGILL if(signal(SIGILL, fatal_signal_handler) == SIG_IGN) signal(SIGILL, SIG_IGN); #endif #ifdef SIGSEGV if(signal(SIGSEGV, fatal_signal_handler) == SIG_IGN) signal(SIGSEGV, SIG_IGN); #endif #ifdef SIGBUS if(signal(SIGBUS, fatal_signal_handler) == SIG_IGN) signal(SIGBUS, SIG_IGN); #endif #ifdef SIGQUIT if(signal(SIGQUIT, fatal_signal_handler) == SIG_IGN) signal(SIGQUIT, SIG_IGN); #endif #ifdef SIGABRT if(signal(SIGABRT, fatal_signal_handler) == SIG_IGN) signal(SIGABRT, SIG_IGN); #endif #endif /* Install the interrupt handler */ #ifdef SIGINT if(signal(SIGINT, interrupt_signal_handler) == SIG_IGN) signal(SIGINT, SIG_IGN); else rep_sig_restart (SIGINT, rep_FALSE); #endif /* Finally, the termination signals */ #ifdef SIGTERM if(signal(SIGTERM, termination_signal_handler) == SIG_IGN) signal(SIGTERM, SIG_IGN); else rep_sig_restart (SIGTERM, rep_FALSE); #endif #ifdef SIGHUP if(signal(SIGHUP, termination_signal_handler) == SIG_IGN) signal(SIGHUP, SIG_IGN); else rep_sig_restart (SIGHUP, rep_FALSE); #endif #ifdef SIGUSR1 signal(SIGUSR1, usr_signal_handler); #endif #ifdef SIGUSR2 signal(SIGUSR2, usr_signal_handler); #endif } /* More normal initialisation. */ void rep_sys_os_init(void) { repv env; char **ptr; /* Initialise process-environment variable */ env = Qnil; if (environ != 0) { ptr = environ; while(*ptr != 0) env = Fcons(rep_string_dup(*ptr++), env); } Fset (Qprocess_environment, env); #ifdef DEBUG_SYS_ALLOC { repv tem = rep_push_structure ("rep.lang.debug"); rep_ADD_SUBR(Sunix_print_allocations); rep_pop_structure (tem); } #endif rep_proc_init(); } void rep_sys_os_kill(void) { rep_proc_kill(); } librep-0.90.2/src/unix_files.c0000644000175200017520000002675311245011153015173 0ustar chrischris/* unix_files.c -- Built-in file handler functions for Unix-like files Copyright (C) 1998 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #include #include #include #ifdef HAVE_FCNTL_H # include #endif #ifdef HAVE_UNISTD_H # include #endif #if HAVE_DIRENT_H # include # define NAMLEN(dirent) strlen((dirent)->d_name) #else # define dirent direct # define NAMLEN(dirent) (dirent)->d_namlen # if HAVE_SYS_NDIR_H # include # endif # if HAVE_SYS_DIR_H # include # endif # if HAVE_NDIR_H # include # endif #endif #ifndef PATH_MAX # define PATH_MAX 256 #endif #ifndef S_ISLNK #define S_ISLNK(mode) (((mode) & S_IFMT) == S_IFLNK) #endif #ifndef S_ISSOCK #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK) #endif /* Support functions */ DEFSTRING(dot, "."); static inline char * file_part(char *name) { char *tmp = strrchr(name, '/'); return tmp != 0 ? tmp + 1 : name; } static struct stat * stat_file(repv file) { static struct stat statbuf; if(stat(rep_STR(file), &statbuf) == 0) return &statbuf; else return 0; } unsigned long rep_file_length(repv file) { struct stat *st = stat_file(file); if(st != 0) return st->st_size; else return 0; } /* File ops */ repv rep_file_name_absolute_p(repv file) { return (((rep_STR(file)[0] == '/') || (rep_STR(file)[0] == '~')) ? Qt : Qnil); } repv rep_expand_file_name(repv file) { char buf[PATH_MAX]; char *optr = buf; char *iptr = rep_STR(file); while(*iptr != 0) { char *end; if(iptr[0] == '.') { if(iptr[1] == '/') { iptr += 1; goto strip; } else if(iptr[1] == 0) { if(optr == buf) /* Only character in string. Must preserve the dot. */ *optr++ = '.'; iptr++; continue; } else if(iptr[1] == '.' && (iptr[2] == '/' || iptr[2] == 0)) { /* `XXX/..[/]' Try to back up over the parent directory */ char *back = optr; rep_bool all_dots = rep_TRUE; char *end; /* Step over any contiguous `/' characters */ while(back > buf && back[-1] == '/') back--; end = back; /* Step over any non-`/' characters */ while(back > buf && back[-1] != '/') { back--; if (back[0] != '.') all_dots = rep_FALSE; } if(back < optr && back >= buf && *back != '/' /* Don't allow `../..' -> `' */ && (!all_dots || end - back != 2)) { /* Reset the output ptr to the end of the parent */ optr = back; } /* Check for `/..' */ else if (all_dots && end == back && back == buf && optr > buf && buf[0] == '/' && optr - end == 1) { optr = back + 1; } else { /* Can't move up; leave the .. in the file name */ *optr++ = '.'; *optr++ = '.'; if(iptr[2] == '/') *optr++ = '/'; } iptr += (iptr[2] == 0) ? 2 : 3; goto strip; } } end = strchr(iptr, '/'); if(end == 0) end = iptr + strlen(iptr); memcpy(optr, iptr, end - iptr); optr += end - iptr; iptr = end; if(*iptr == '/') *optr++ = *iptr++; strip: /* merge multiple slashes into one */ while (*iptr && *iptr == '/') iptr++; } /* Don't allow a fully-empty string to be returned */ if (optr - buf == 0) *optr++ = '.'; if(optr - buf != rep_STRING_LEN(file) || memcmp(rep_STR(file), buf, optr - buf) != 0) return rep_string_dupn(buf, optr - buf); else return file; } repv rep_canonical_file_name(repv file) { char buf[PATH_MAX]; int len; if(realpath(rep_STR(file), buf) == 0) { /* realpath () failed; copy the source */ strncpy (buf, rep_STR (file), sizeof (buf)); } len = strlen(buf); while (len > 0 && buf[len - 1] == '/') { buf[len - 1] = 0; len--; } return rep_string_dupn(buf, len); } repv rep_file_name_nondirectory(repv file) { char *tem = file_part(rep_STR(file)); return tem == rep_STR(file) ? file : rep_string_dup(tem); } repv rep_file_name_directory(repv file) { int len = file_part(rep_STR(file)) - rep_STR(file); return rep_string_dupn(rep_STR(file), len); } repv rep_file_name_as_directory(repv file) { int len = rep_STRING_LEN(file); if(file_part(rep_STR(file)) == rep_STR(file) + len) { /* It's already a directory */ return file; } else { repv new = rep_string_dupn(rep_STR(file), len + 1); if(new) { rep_STR(new)[len] = '/'; rep_STR(new)[len+1] = 0; } return new; } } repv rep_directory_file_name(repv file) { int len = rep_STRING_LEN(file); if(file_part(rep_STR(file)) != rep_STR(file) + len) { /* There's a file part. Just return the initial string? */ return file; } else { if(len == 0) return rep_VAL(&dot); else if(len == 1) return file; else /* Chop the trailing "/" */ return rep_string_dupn(rep_STR(file), len - 1); } } repv rep_delete_file(repv file) { if(unlink(rep_STR(file)) == 0) return Qt; else return rep_signal_file_error(file); } repv rep_rename_file(repv old, repv new) { if(rename(rep_STR(old), rep_STR(new)) != -1) return Qt; else return rep_signal_file_error(rep_list_2(old, new)); } repv rep_make_directory(repv dir) { int len = rep_STRING_LEN(dir); /* Trim trailing '/' to mkdir(2) since some OSes fail the call otherwise */ if (*(rep_STR(dir) + len - 1) == '/') dir = rep_string_dupn(rep_STR(dir), len - 1); if(mkdir(rep_STR(dir), S_IRWXU | S_IRWXG | S_IRWXO) == 0) return Qt; else return rep_signal_file_error(dir); } repv rep_delete_directory(repv dir) { if(rmdir(rep_STR(dir)) == 0) return Qt; else return rep_signal_file_error(dir); } repv rep_copy_file(repv src, repv dst) { repv res = Qt; int srcf; srcf = open(rep_STR(src), O_RDONLY); if(srcf != -1) { int dstf = open(rep_STR(dst), O_WRONLY | O_CREAT | O_TRUNC, 0666); if(dstf != -1) { struct stat statb; int rd; if(fstat(srcf, &statb) == 0) chmod(rep_STR(dst), statb.st_mode); do { char buf[BUFSIZ]; int wr; rd = read(srcf, buf, BUFSIZ); if(rd < 0) { res = rep_signal_file_error(src); break; } wr = write(dstf, buf, rd); if(wr != rd) { res = rep_signal_file_error(dst); break; } } while(rd != 0); close(dstf); } else res = rep_signal_file_error(dst); close(srcf); } else res = rep_signal_file_error(src); return res; } repv rep_file_readable_p(repv file) { return access(rep_STR(file), R_OK) == 0 ? Qt : Qnil; } repv rep_file_writable_p(repv file) { return access(rep_STR(file), W_OK) == 0 ? Qt : Qnil; } repv rep_file_exists_p(repv file) { return access(rep_STR(file), F_OK) == 0 ? Qt : Qnil; } repv rep_file_regular_p(repv file) { struct stat *st = stat_file(file); if(st != 0) return S_ISREG(st->st_mode) ? Qt : Qnil; else return Qnil; } repv rep_file_directory_p(repv file) { struct stat *st = stat_file(file); if(st != 0) return S_ISDIR(st->st_mode) ? Qt : Qnil; else return Qnil; } repv rep_file_symlink_p(repv file) { struct stat st; if(lstat(rep_STR(file), &st) == 0) return S_ISLNK(st.st_mode) ? Qt : Qnil; else return Qnil; } repv rep_file_owner_p(repv file) { struct stat *st = stat_file(file); if(st != 0) return ((st->st_uid == geteuid() && st->st_gid == getegid()) ? Qt : Qnil); else return Qnil; } repv rep_file_nlinks(repv file) { struct stat *st = stat_file(file); if(st != 0) return rep_MAKE_INT(st->st_nlink); else return Qnil; } repv rep_file_size(repv file) { struct stat *st = stat_file(file); if(st != 0) return rep_make_long_uint(st->st_size); else return Qnil; } repv rep_file_modes(repv file) { struct stat *st = stat_file(file); if(st != 0) return rep_MAKE_INT(st->st_mode & 07777); else return Qnil; } repv rep_set_file_modes(repv file, repv modes) { rep_DECLARE2(modes, rep_INTP); if(chmod(rep_STR(file), rep_INT(modes)) == 0) return modes; else return rep_signal_file_error(file); } repv rep_file_modes_as_string(repv file) { struct stat *st = stat_file(file); repv string = Fmake_string(rep_MAKE_INT(10), rep_MAKE_INT('-')); if(st != 0 && string && rep_STRINGP(string)) { unsigned long perms = st->st_mode; int i; char c = '-'; if(S_ISDIR(perms)) c = 'd'; else if(S_ISLNK(perms)) c = 'l'; else if(S_ISBLK(perms)) c = 'b'; else if(S_ISCHR(perms)) c = 'c'; else if(S_ISFIFO(perms)) c = 'p'; else if(S_ISSOCK(perms)) c = 's'; rep_STR(string)[0] = c; for(i = 0; i < 3; i++) { unsigned long xperms = perms >> ((2 - i) * 3); if(xperms & 4) rep_STR(string)[1+i*3] = 'r'; if(xperms & 2) rep_STR(string)[2+i*3] = 'w'; c = (xperms & 1) ? 'x' : 0; if(perms & (04000 >> i)) { static char extra_bits[3] = { 'S', 'S', 'T' }; /* Rampant abuse of ASCII knowledge :-) */ c = extra_bits[i] | (c & 0x20); } if(c != 0) rep_STR(string)[3+i*3] = c; } } return string; } repv rep_file_modtime(repv file) { struct stat *st = stat_file(file); if(st != 0) return rep_MAKE_TIME(st->st_mtime); else /* Really this should return nil */ return rep_MAKE_TIME(0); } repv rep_directory_files(repv dir_name) { DIR *dir; if(*rep_STR(dir_name) == 0) dir_name = rep_VAL(&dot); dir = opendir(rep_STR(dir_name)); if(dir) { repv list = Qnil; struct dirent *de; while((de = readdir(dir))) { repv name = rep_string_dupn(de->d_name, NAMLEN(de)); list = Fcons(name, list); if(name == rep_NULL || list == rep_NULL) { rep_mem_error(); closedir(dir); return rep_NULL; } } closedir(dir); return list; } return Fsignal(Qfile_error, rep_list_2(rep_lookup_errno(), dir_name)); } repv rep_read_symlink (repv file) { char buf[PATH_MAX]; int len = readlink (rep_STR(file), buf, sizeof (buf)); if (len == -1) return rep_signal_file_error (file); else return rep_string_dupn (buf, len); } repv rep_make_symlink (repv file, repv contents) { if (symlink (rep_STR (contents), rep_STR (file)) == 0) return Qt; else return rep_signal_file_error (file); } repv rep_getpwd(void) { char buf[PATH_MAX]; #ifdef HAVE_GETCWD if(!getcwd(buf, PATH_MAX)) #else if(!getwd(buf)) #endif return rep_signal_file_error(Qnil); else { /* Ensure that it ends with "/" */ int len = strlen(buf); if(len < (PATH_MAX - 1) && buf[len] != '/') { buf[len++] = '/'; buf[len] = 0; } return rep_string_dupn(buf, len); } } /* module name conversion */ repv rep_structure_file (repv in) { /* Convert dots to slashes. XXX escape meta chars? */ char *ptr = strchr (rep_STR (in), '.'); if (ptr == 0) return in; else { repv copy = rep_string_dupn (rep_STR (in), rep_STRING_LEN (in)); for (ptr = rep_STR (copy); *ptr != 0; ptr++) { if (*ptr == '.') *ptr = '/'; } return copy; } } librep-0.90.2/src/unix_dl.c0000644000175200017520000002634211245011153014462 0ustar chrischris/* unix_dl.c -- Dynamic loading of C modules Copyright (C) 1998 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include /* we define some extensions to the libtool .la file. As well as using the dlname entry to find the .so file to open, we also look for: rep_open_globally=[yes|no] whether or not to open with RTLD_GLOBAL rep_requires='FEATURES...' FEATURES is space separated list of feature symbols. Each of which must be provided by a dl object. */ #ifdef HAVE_DYNAMIC_LOADING #if defined (HAVE_DLFCN_H) # include # if ! defined (RTLD_LAZY) # if defined (DL_LAZY) # define RTLD_LAZY DL_LAZY # else /* from gmodule-dl.c ``The Perl sources say, RTLD_LAZY needs to be defined as (1), at least for Solaris 1.'' */ # define RTLD_LAZY 1 # endif # endif # if ! defined (RTLD_GLOBAL) # if defined (DL_GLOBAL) # define RTLD_GLOBAL DL_GLOBAL # else # define RTLD_GLOBAL 0 # endif # endif # if ! defined (RTLD_LOCAL) # if defined (DL_LOCAL) # define RTLD_LOCAL DL_LOCAL # else # define RTLD_LOCAL 0 # endif # endif # if ! defined (RTLD_NOW) # if defined (DL_NOW) # define RTLD_NOW DL_NOW # else # define RTLD_NOW 0 # endif # endif # if ! defined (RTLD_DEFAULT) # define RTLD_DEFAULT ((void *) 0) # endif # if defined (BROKEN_RTLD_GLOBAL) # undef RTLD_GLOBAL # define RTLD_GLOBAL 0 # endif #elif defined (HAVE_DL_H) || defined (HAVE_SYS_DL_H) # if defined (HAVE_DL_H) # include # else # include # endif # if ! defined (BIND_IMMEDIATE) # define BIND_IMMEDIATE 0 # endif # if ! defined (BIND_DEFERRED) # define BIND_DEFERRED 0 # endif # if ! defined (BIND_NONFATAL) # define BIND_NONFATAL 0 # endif # if ! defined (DYNAMIC_PATH) # define DYNAMIC_PATH 0 # endif #endif struct dl_lib_info { repv file_name; repv feature_sym; repv structure; void *handle; rep_bool is_rep_module; }; static int n_dl_libs, n_alloc_dl_libs; static struct dl_lib_info *dl_libs; #if !defined (HAVE_DLOPEN) && defined (HAVE_SHL_LOAD) static inline void * dlsym (void *handle, char *sym) { void *addr; if (shl_findsym (&handle, sym, TYPE_UNDEFINED, &addr) == 0) return addr; else return 0; } static inline void dlclose (void *handle) { shl_unload (handle); } #endif #ifndef DLSYM_NEED_USCORE # define x_dlsym dlsym #else static void * x_dlsym (void *handle, char *sym) { void *ptr = 0; char *tem = alloca (strlen(sym) + 2); tem[0] = '_'; strcpy (tem + 1, sym); ptr = dlsym (handle, tem); return ptr; } #endif static int find_dl (repv file) { int i; assert (rep_STRINGP (file)); for (i = 0; i < n_dl_libs; i++) { assert (rep_STRINGP (dl_libs[i].file_name)); if (!strcmp (rep_STR (file), rep_STR (dl_libs[i].file_name))) return i; } return -1; } static int find_dl_by_feature(repv feature) { int i; assert (rep_STRINGP(feature)); for (i = 0; i < n_dl_libs; i++) { if (rep_SYMBOLP (dl_libs[i].feature_sym) && strcmp (rep_STR (rep_SYM (dl_libs[i].feature_sym)->name), rep_STR (feature)) == 0) { return i; } } return -1; } static rep_bool load_requires (char *ptr) { ptr += strspn (ptr, " \t"); while (*ptr != 0) { char *end = ptr + strcspn (ptr, " \t"); repv sym = Fintern (rep_string_dupn (ptr, end - ptr), Qnil); if (Fintern_structure (sym) == rep_NULL) return rep_FALSE; ptr = end + strspn (end, " \t"); } return rep_TRUE; } static void signal_error (const char *msg) { if (Qerror != 0) Fsignal (Qerror, rep_LIST_1 (rep_string_dup (msg))); else fprintf (stderr, "error: %s\n", msg); } int rep_intern_dl_library (repv file_name) { const char *dlname = 0; rep_bool open_globally = rep_FALSE; rep_bool is_rep_module = rep_TRUE; int idx; const char *tem; int len; idx = find_dl (file_name); if(idx >= 0) return idx; tem = rep_STR (file_name); len = strlen (tem); if (len >= 3 && strcmp (tem + len - 3, ".la") == 0) { /* We're trying to open a _libtool_ dl object. i.e it's a file ending in .la that contains a dlname=FOO line pointing to the actual DL object (in the same directory). */ char buf[256]; FILE *fh; fh = fopen(rep_STR(file_name), "r"); if (fh == 0) { rep_signal_file_error(file_name); return -1; } while (fgets(buf, sizeof(buf), fh)) { if (strncmp("dlname='", buf, sizeof("dlname='") - 1) == 0) { char *ptr = buf + sizeof("dlname='") - 1; char *base; char *end = strchr(ptr, '\''); if (end != 0 && end > ptr) { char *name; *end = 0; base = strrchr(rep_STR(file_name), '/'); if (base == 0) { name = alloca (strlen (ptr) + 1); strcpy (name, ptr); } else { base++; name = alloca (strlen(ptr) + base - rep_STR(file_name) + 1); memcpy(name, rep_STR(file_name), base - rep_STR(file_name)); strcpy(name + (base - rep_STR(file_name)), ptr); } dlname = name; } } else if (strncmp("rep_open_globally=", buf, sizeof("rep_open_globally=") - 1) == 0) { char *ptr = buf + sizeof ("rep_open_globally=") - 1; if (strncmp ("yes", ptr, 3) == 0) open_globally = rep_TRUE; } else if (strncmp("rep_requires='", buf, sizeof ("rep_requires='") - 1) == 0) { char *ptr = buf + sizeof ("rep_requires='") - 1; char *end = strchr (ptr, '\''); if (end != 0) { rep_GC_root gc_file_name; rep_bool success; char *string = alloca (end - ptr + 1); memcpy (string, ptr, end - ptr); string[end - ptr] = 0; rep_PUSHGC (gc_file_name, file_name); success = load_requires (string); rep_POPGC; if (!success) return -1; } } } fclose(fh); } else { /* not .la, assume a native library name */ dlname = rep_STR (file_name); is_rep_module = rep_FALSE; } if (dlname == NULL) { char err[256]; #ifdef HAVE_SNPRINTF snprintf (err, sizeof (err), "Can't find dlname in %s", rep_STR (file_name)); #else sprintf (err, "Can't find dlname in %s", rep_STR (file_name)); #endif signal_error (err); return -1; } else { void *handle; rep_bool relocate_now = rep_FALSE; struct dl_lib_info *x; if (Qdl_load_reloc_now && Fsymbol_value (Qdl_load_reloc_now, Qt) != Qnil) { relocate_now = rep_TRUE; } #if defined (HAVE_DLOPEN) handle = dlopen(dlname, (relocate_now ? RTLD_NOW : RTLD_LAZY) | (open_globally ? RTLD_GLOBAL : RTLD_LOCAL)); #elif defined (HAVE_SHL_LOAD) /* XXX how do we open these locally/globally? */ handle = shl_load (dlname, (relocate_now ? BIND_IMMEDIATE : BIND_DEFERRED) | BIND_NONFATAL | DYNAMIC_PATH, 0L); #endif if(handle == NULL) { const char *err; #ifdef HAVE_DLERROR err = dlerror(); #else err = "unknown dl error"; #endif if(err != 0) signal_error (err); return -1; } if (n_alloc_dl_libs == n_dl_libs) { int new_n = MAX (n_alloc_dl_libs * 2, 32); void *ptr; ptr = rep_realloc (dl_libs, new_n * sizeof (struct dl_lib_info)); if (ptr == NULL) { rep_mem_error(); dlclose(handle); return -1; } dl_libs = ptr; n_alloc_dl_libs = new_n; } idx = n_dl_libs++; x = &dl_libs[idx]; x->file_name = file_name; x->handle = handle; x->feature_sym = Qnil; x->structure = Qnil; x->is_rep_module = is_rep_module; if (is_rep_module) { repv (*init_func)(repv); init_func = x_dlsym(handle, "rep_dl_init"); if(init_func != 0) { repv ret; ret = init_func(file_name); if(Qnil != rep_NULL /* initialising */ && (ret == rep_NULL || ret == Qnil)) { /* error. abort abort.. */ --n_dl_libs; dlclose(handle); return -1; } else if (ret && rep_SYMBOLP(ret) && ret != Qt) x->feature_sym = ret; else if (ret && rep_STRUCTUREP (ret)) { x->structure = ret; ret = rep_STRUCTURE (ret)->name; if (ret && rep_SYMBOLP (ret)) x->feature_sym = ret; } } } } return idx; } repv rep_open_dl_library(repv file_name) { int idx; idx = rep_intern_dl_library (file_name); if (idx < 0) return rep_NULL; if (dl_libs[idx].is_rep_module) { if (dl_libs[idx].feature_sym != Qnil && dl_libs[idx].structure == Qnil) { /* only `provide' the feature if there's no associated structure (since we haven't actually imported it) */ Fprovide (dl_libs[idx].feature_sym); } return dl_libs[idx].structure; } else return Qt; } void * rep_lookup_dl_symbol (int idx, const char *name) { void *handle; handle = (idx >= 0 && idx < n_dl_libs) ? dl_libs[idx].handle : RTLD_DEFAULT; return x_dlsym (handle, name); } void rep_mark_dl_data(void) { int i; for (i = 0; i < n_dl_libs; i++) { rep_MARKVAL(dl_libs[i].file_name); rep_MARKVAL(dl_libs[i].feature_sym); rep_MARKVAL(dl_libs[i].structure); } } void rep_kill_dl_libraries(void) { int i; for (i = 0; i < n_dl_libs; i++) { if (dl_libs[i].is_rep_module) { void (*exit_func) (void); exit_func = x_dlsym (dl_libs[i].handle, "rep_dl_kill"); if(exit_func != 0) (*exit_func) (); } #if 0 /* Closing libraries is a _bad_ idea. There's no way of knowing if any pointers to their contents exist. For example, it's impossible to completely expunge libgtk/libgdk, since they install an atexit () handler.. */ dlclose(x->handle); #endif } n_dl_libs = n_alloc_dl_libs = 0; rep_free (dl_libs); dl_libs = NULL; } void * rep_find_dl_symbol (repv feature, char *symbol) { int idx; assert (rep_SYMBOLP (feature)); idx = find_dl_by_feature (rep_SYM(feature)->name); if (idx <= 0) return NULL; return x_dlsym (dl_libs[idx].handle, symbol); } /* Attempt to find the name and address of the nearest symbol before or equal to PTR */ rep_bool rep_find_c_symbol(void *ptr, char **symbol_name_p, void **symbol_addr_p) { #ifdef HAVE_DLADDR Dl_info info; if(dladdr(ptr, &info) != 0) { *symbol_name_p = (char *)info.dli_sname; *symbol_addr_p = info.dli_saddr; return rep_TRUE; } else #endif return rep_FALSE; } #else /* HAVE_DYNAMIC_LOADING */ rep_bool rep_find_c_symbol(void *ptr, char **name_p, void **addr_p) { return rep_FALSE; } #endif /* !HAVE_DYNAMIC_LOADING */ librep-0.90.2/src/unix_defs.h0000644000175200017520000000166311245011153015010 0ustar chrischris/* unix_defs.h -- Declarations for Unix Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #ifndef _UNIX_DEFS_H #define _UNIX_DEFS_H #define sys_memory_kill() #define sys_memory_init() (1) #endif /* _UNIX_DEFS_H */ librep-0.90.2/src/tuples.c0000644000175200017520000000557411245011153014340 0ustar chrischris/* tuples.c -- management of `tuples' (car and two values) Copyright (C) 1993, 1994, 2000 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #define rep_TUPLEBLK_SIZE 680 /* ~8k */ /* Symbol allocation blocks */ typedef struct rep_tuple_block_struct rep_tuple_block; struct rep_tuple_block_struct { rep_tuple_block *next; rep_ALIGN_CELL(rep_tuple tuples[rep_TUPLEBLK_SIZE]); }; static rep_tuple_block *tuple_block_chain; static rep_tuple *tuple_freelist; int rep_allocated_tuples, rep_used_tuples; repv rep_make_tuple (repv car, repv a, repv b) { rep_tuple *t; if (tuple_freelist == 0) { rep_tuple_block *sb = rep_ALLOC_CELL (sizeof (rep_tuple_block)); if (sb != 0) { int i; rep_allocated_tuples += rep_TUPLEBLK_SIZE; sb->next = tuple_block_chain; tuple_block_chain = sb; for (i = 0; i < (rep_TUPLEBLK_SIZE - 1); i++) { sb->tuples[i].a = rep_VAL (&sb->tuples[i + 1]); sb->tuples[i].car = 0; } sb->tuples[i].a = rep_VAL (tuple_freelist); sb->tuples[i].car = 0; tuple_freelist = sb->tuples; } else abort (); } t = tuple_freelist; tuple_freelist = rep_TUPLE (t->a); t->car = car; t->a = a; t->b = b; rep_used_tuples++; rep_data_after_gc += sizeof (rep_tuple); return rep_VAL (t); } void rep_mark_tuple (repv t) { rep_MARKVAL (rep_TUPLE (t)->a); rep_MARKVAL (rep_TUPLE (t)->b); } void rep_sweep_tuples (void) { rep_tuple_block *sb; rep_tuple *tem_freelist = 0; int tem_used = 0; for (sb = tuple_block_chain; sb != 0; sb = sb->next) { rep_tuple *this = sb->tuples; rep_tuple *last = &(sb->tuples[rep_TUPLEBLK_SIZE]); while (this < last) { if (!rep_GC_CELL_MARKEDP (rep_VAL (this))) { this->a = rep_VAL (tem_freelist); tem_freelist = this; } else { rep_GC_CLR_CELL (rep_VAL (this)); tem_used++; } this++; } } tuple_freelist = tem_freelist; rep_used_tuples = tem_used; } void rep_tuples_kill(void) { rep_tuple_block *sb = tuple_block_chain; while (sb != 0) { rep_tuple_block *nxt = sb->next; rep_FREE_CELL (sb); sb = nxt; } tuple_block_chain = NULL; } librep-0.90.2/src/timers.c0000644000175200017520000002204511245011153014317 0ustar chrischris/* timers.c -- call a function after a period of time has passed Copyright (C) 1999 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include #include #ifdef HAVE_UNISTD_H # include #endif #ifdef HAVE_SYS_TIME_H # include #endif static int timer_type; #define TIMER(v) ((Lisp_Timer *)rep_PTR(v)) #define TIMERP(v) rep_CELL16_TYPEP(v, timer_type) typedef struct lisp_timer { repv car; struct lisp_timer *next; struct lisp_timer *next_alloc; repv function; long secs, msecs; long rel_secs, rel_msecs; unsigned int fired : 1; unsigned int deleted : 1; } Lisp_Timer; /* List of all allocated timer objects, linked through next_alloc field */ static Lisp_Timer *allocated_timers; /* List of all pending timers, linked through next field. Only ever touch this variable if SIGALRM is blocked! */ static Lisp_Timer *timer_chain; /* Pipe used to trigger the input callback */ static int pipe_fds[2]; /* Contains SIGALRM */ static sigset_t alrm_sigset; static RETSIGTYPE timer_signal_handler (int sig) { int dummy = 0; Lisp_Timer *t = timer_chain; assert (t != 0); t->rel_secs = t->rel_msecs = 0; while (t != 0 && t->rel_secs == 0 && t->rel_msecs == 0) { t->fired = 1; t = t->next; } write (pipe_fds[1], &dummy, sizeof (dummy)); } /* only call with SIGALRM blocked */ static void setup_next_timer (void) { if (timer_chain != 0 && (timer_chain->rel_secs > 0 || timer_chain->rel_msecs > 0)) { #ifdef HAVE_SETITIMER struct itimerval it, tem; it.it_interval.tv_usec = 0; it.it_interval.tv_sec = 0; it.it_value.tv_usec = timer_chain->rel_msecs * 1000; it.it_value.tv_sec = timer_chain->rel_secs; setitimer (ITIMER_REAL, &it, &tem); #else alarm (timer_chain->secs); #endif signal (SIGALRM, timer_signal_handler); } else signal (SIGALRM, SIG_IGN); } static inline void fix_time (long *secs, long *msecs) { while (*msecs < 0) { *msecs += 1000; (*secs)--; } while (*msecs >= 1000) { *msecs -= 1000; (*secs)++; } } static void insert_timer (Lisp_Timer *t) { sigset_t old; sigprocmask (SIG_BLOCK, &alrm_sigset, &old); if (t->secs > 0 || t->msecs > 0) { Lisp_Timer **x; t->rel_secs = t->secs; t->rel_msecs = t->msecs; t->fired = 0; t->deleted = 0; x = &timer_chain; while (*x != 0 && ((*x)->rel_secs < t->rel_secs || ((*x)->rel_secs == t->rel_secs && (*x)->rel_msecs <= t->rel_msecs))) { t->rel_msecs -= (*x)->rel_msecs; t->rel_secs -= (*x)->rel_secs; fix_time (&t->rel_secs, &t->rel_msecs); x = &((*x)->next); } if (*x != 0) { (*x)->rel_msecs -= t->rel_msecs; (*x)->rel_secs -= t->rel_secs; fix_time (&(*x)->rel_secs, &(*x)->rel_msecs); } t->next = *x; *x = t; if (timer_chain == t) setup_next_timer (); } sigprocmask (SIG_SETMASK, &old, 0); } static void delete_timer (Lisp_Timer *t) { Lisp_Timer **x; sigset_t old; sigprocmask (SIG_BLOCK, &alrm_sigset, &old); t->deleted = 1; x = &timer_chain; while (*x != 0 && (*x) != t) x = &((*x)->next); if (*x == t) { if (t->next != 0) { t->next->rel_msecs += t->rel_msecs; t->next->rel_secs += t->rel_secs; fix_time (&t->next->rel_secs, &t->next->rel_msecs); } t->rel_secs = t->rel_msecs = 0; *x = t->next; if (x == &timer_chain) setup_next_timer (); } sigprocmask (SIG_SETMASK, &old, 0); } static void timer_fd_handler (int fd) { int dummy; int ready, i; repv *timers; rep_GC_n_roots gc_timers; Lisp_Timer *t; sigset_t old; read (pipe_fds[0], &dummy, sizeof (dummy)); sigprocmask (SIG_BLOCK, &alrm_sigset, &old); ready = 0; for (t = timer_chain; t != 0 && t->fired; t = t->next) ready++; timers = alloca (sizeof (repv) * ready); for (i = 0; i < ready; i++) { timers[i] = rep_VAL(timer_chain); timer_chain = timer_chain->next; } setup_next_timer (); sigprocmask (SIG_SETMASK, &old, 0); rep_PUSHGCN(gc_timers, timers, ready); for (i = 0; i < ready; i++) { if (!TIMER(timers[i])->deleted) rep_call_lisp1 (TIMER(timers[i])->function, timers[i]); } rep_POPGCN; } /* Lisp interface */ DEFUN("make-timer", Fmake_timer, Smake_timer, (repv fun, repv secs, repv msecs), rep_Subr3) /* ::doc:rep.io.timers#make-timer:: make-timer FUNCTION [SECONDS] [MILLISECONDS] Create and return a new one-shot timer object. After SECONDS*1000 + MILLISECONDS milliseconds FUNCTION will be called. Note that the timer will only fire _once_, use the `set-timer' function to re-enable it. ::end:: */ { Lisp_Timer *t = rep_ALLOC_CELL (sizeof (Lisp_Timer)); rep_data_after_gc += sizeof (Lisp_Timer); t->car = timer_type; t->function = fun; t->secs = rep_get_long_int (secs); t->msecs = rep_get_long_int (msecs); fix_time (&t->secs, &t->msecs); t->next_alloc = allocated_timers; allocated_timers = t; insert_timer (t); return rep_VAL(t); } DEFUN("delete-timer", Fdelete_timer, Sdelete_timer, (repv timer), rep_Subr1) /* ::doc:rep.io.timers#delete-timer:: delete-timer TIMER Prevent the one-shot timer TIMER from firing (i.e. calling the function associated with it). If the timer has already fired, this function has no effect. ::end:: */ { rep_DECLARE1(timer, TIMERP); delete_timer (TIMER(timer)); return timer; } DEFUN("set-timer", Fset_timer, Sset_timer, (repv timer, repv secs, repv msecs), rep_Subr3) /* ::doc:rep.io.timers#set-timer:: set-timer TIMER [SECONDS] [MILLISECONDS] Restart the one-shot timer TIMER. If SECONDS and/or MILLISECONDS is defined the period after which it fires will be reset to the specified duration. Otherwise, the existing values are preserved. ::end:: */ { rep_DECLARE1(timer, TIMERP); rep_DECLARE2_OPT(secs, rep_NUMERICP); rep_DECLARE3_OPT(msecs, rep_NUMERICP); delete_timer (TIMER(timer)); if (secs != Qnil || msecs != Qnil) { TIMER(timer)->secs = rep_get_long_int (secs); TIMER(timer)->msecs = rep_get_long_int (msecs); fix_time (&TIMER (timer)->secs, &TIMER (timer)->msecs); } insert_timer (TIMER(timer)); return timer; } /* Type hooks */ static void timer_mark (repv val) { rep_MARKVAL (TIMER(val)->function); } static void timer_mark_active (void) { Lisp_Timer *t; sigset_t old; sigprocmask (SIG_BLOCK, &alrm_sigset, &old); t = timer_chain; while (t != 0) { rep_MARKVAL (rep_VAL(t)); t = t->next; } sigprocmask (SIG_SETMASK, &old, 0); } static void timer_sweep (void) { Lisp_Timer *x = allocated_timers; allocated_timers = 0; while (x != 0) { Lisp_Timer *next = x->next_alloc; if (!rep_GC_CELL_MARKEDP (rep_VAL(x))) rep_FREE_CELL (x); else { rep_GC_CLR_CELL (rep_VAL(x)); x->next_alloc = allocated_timers; allocated_timers = x; } x = next; } } static void timer_print (repv stream, repv arg) { char buf[64]; #ifdef HAVE_SNPRINTF snprintf (buf, sizeof (buf), "#", TIMER(arg)->secs, TIMER(arg)->msecs); #else sprintf (buf, "#", TIMER(arg)->secs, TIMER(arg)->msecs); #endif rep_stream_puts (stream, buf, -1, rep_FALSE); } /* DL hooks */ repv rep_dl_init (void) { repv tem; timer_type = rep_register_new_type ("timer", 0, timer_print, timer_print, timer_sweep, timer_mark, timer_mark_active, 0, 0, 0, 0, 0, 0); pipe (pipe_fds); rep_register_input_fd (pipe_fds[0], timer_fd_handler); #ifdef rep_HAVE_UNIX rep_unix_set_fd_cloexec (pipe_fds[1]); #endif sigemptyset (&alrm_sigset); sigaddset (&alrm_sigset, SIGALRM); rep_sig_restart (SIGALRM, rep_TRUE); tem = rep_push_structure ("rep.io.timers"); /* ::alias:timers rep.io.timers:: */ rep_alias_structure ("timers"); rep_ADD_SUBR(Smake_timer); rep_ADD_SUBR(Sdelete_timer); rep_ADD_SUBR(Sset_timer); return rep_pop_structure (tem); } void rep_dl_kill (void) { rep_deregister_input_fd (pipe_fds[0]); close (pipe_fds[0]); close (pipe_fds[1]); signal (SIGALRM, SIG_IGN); } librep-0.90.2/src/tables.c0000644000175200017520000003346311245011153014274 0ustar chrischris/* tables.c -- hash tables Copyright (C) 2000 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* notes: The api of this module (except for make-table) was mostly borrowed from Scheme48. The implementation is all my own fault.. */ #define _GNU_SOURCE #include "repint.h" #include #ifdef NEED_MEMORY_H # include #endif typedef unsigned rep_PTR_SIZED_INT hash_value; typedef struct node_struct node; struct node_struct { node *next; repv key, value; hash_value hash; }; typedef struct table_struct table; struct table_struct { repv car; table *next; int total_buckets, total_nodes; node **buckets; repv hash_fun; repv compare_fun; repv guardian; /* non-null if a weak table */ }; #define TABLEP(v) rep_CELL16_TYPEP(v, table_type) #define TABLE(v) ((table *) rep_PTR(v)) static int table_type; static table *all_tables; /* ensure X is +ve and in an int */ #define TRUNC(x) (((x) << (rep_VALUE_INT_SHIFT+1)) >> (rep_VALUE_INT_SHIFT+1)) /* type hooks */ static void table_mark (repv val) { int i; for (i = 0; i < TABLE(val)->total_buckets; i++) { node *n; for (n = TABLE(val)->buckets[i]; n != 0; n = n->next) { if (!TABLE(val)->guardian) rep_MARKVAL(n->key); rep_MARKVAL(n->value); } } rep_MARKVAL(TABLE(val)->hash_fun); rep_MARKVAL(TABLE(val)->compare_fun); rep_MARKVAL(TABLE(val)->guardian); } static void free_table (table *x) { int i; for (i = 0; i < x->total_buckets; i++) { node *n, *next; for (n = x->buckets[i]; n != 0; n = next) { next = n->next; rep_free (n); } } if (x->total_buckets > 0) rep_free (x->buckets); rep_FREE_CELL (x); } static void table_sweep (void) { table *x = all_tables; all_tables = 0; while (x != 0) { table *next = x->next; if (!rep_GC_CELL_MARKEDP (rep_VAL(x))) free_table (x); else { rep_GC_CLR_CELL (rep_VAL(x)); x->next = all_tables; all_tables = x; } x = next; } } static void table_print (repv stream, repv arg) { rep_stream_puts (stream, "#hash_fun); rep_stream_putc (stream, ' '); rep_princ_val (stream, TABLE(arg)->compare_fun); rep_stream_putc (stream, '>'); } /* hash functions */ static inline hash_value hash_string (register char *ptr) { register hash_value value = 0; while (*ptr != 0) value = (value * 33) + *ptr++; return rep_MAKE_INT (TRUNC (value)); } DEFUN("string-hash", Fstring_hash, Sstring_hash, (repv string), rep_Subr1) /* ::doc:rep.data.tables#string-hash:: string-hash STRING Return a positive fixnum somehow related to the contents of STRING, such that (string= X Y) implies (= (string-hash X) (string-hash Y)). ::end:: */ { rep_DECLARE1(string, rep_STRINGP); return hash_string (rep_STR (string)); } DEFUN("symbol-hash", Fsymbol_hash, Ssymbol_hash, (repv sym), rep_Subr1) /* ::doc:rep.data.tables#symbol-hash:: symbol-hash SYMBOL Return a positive fixnum somehow related to the name of SYMBOL. ::end:: */ { rep_DECLARE1(sym, rep_SYMBOLP); return hash_string (rep_STR (rep_SYM (sym)->name)); } DEFUN("eq-hash", Feq_hash, Seq_hash, (repv value), rep_Subr1) /* ::doc:rep.data.tables#eq-hash:: eq-hash ARG Return a positive fixnum somehow related to object ARG, such that (eq X Y) implies (= (eq-hash X) (eq-hash Y)). ::end:: */ { hash_value hv = value; return rep_MAKE_INT (TRUNC (hv)); } /* XXX This is probably _very_ sub-optimal.. */ DEFUN("equal-hash", Fequal_hash, Sequal_hash, (repv x, repv n_), rep_Subr2) /* ::doc:rep.data.tables#equal-hash:: equal-hash ARG Return a positive fixnum somehow related to ARG, such that (equal X Y) implies (= (equal-hash X) (equal-hash Y)). ::end:: */ { int n = rep_INTP (n_) ? rep_INT (n_) : rep_PTR_SIZED_INT_BITS / 2; if (rep_CONSP (x)) { if (n > 0) { repv left = Fequal_hash (rep_CAR(x), rep_MAKE_INT (n/2)); repv right = Fequal_hash (rep_CDR(x), rep_MAKE_INT (n/2)); return rep_MAKE_INT ((rep_INT (left) << 1) + rep_INT (right)); } else return rep_MAKE_INT (rep_Cons); } else if (rep_VECTORP (x) || rep_COMPILEDP (x)) { hash_value hash = 0; int i = MIN (n, rep_VECT_LEN (x)); while (i-- > 0) { repv tem = Fequal_hash (rep_VECTI (x, i), rep_MAKE_INT (n/2)); hash = hash * 33 + rep_INT (tem); } return rep_MAKE_INT (TRUNC (hash)); } else if (rep_STRINGP (x)) return Fstring_hash (x); else if (rep_SYMBOLP (x)) return Fsymbol_hash (x); else if (rep_INTP (x)) { hash_value hash = rep_INT (x); return rep_MAKE_INT (TRUNC (hash)); } else if (rep_NUMBERP (x)) { hash_value hash = rep_get_long_uint (x); return rep_MAKE_INT (TRUNC (hash)); } else return rep_MAKE_INT (rep_TYPE (x) * 255); } /* table functions */ DEFUN("make-table", Fmake_table, Smake_table, (repv hash_fun, repv cmp_fun, repv is_weak), rep_Subr3) /* ::doc:rep.data.tables#make-table:: make-table HASH-FUNCTION COMPARE-FUNCTION Create and return a new hash table. When storing and referencing keys it will use the function HASH-FUNCTION to map keys to hash codes (positive fixnums), and the predicate function COMPARE-FUNCTION to compare two keys (should return true if the keys are considered equal). ::end:: */ { table *tab; rep_DECLARE(1, hash_fun, Ffunctionp (hash_fun) != Qnil); rep_DECLARE(2, cmp_fun, Ffunctionp (cmp_fun) != Qnil); tab = rep_ALLOC_CELL (sizeof (table)); rep_data_after_gc += sizeof (table); tab->car = table_type; tab->next = all_tables; all_tables = tab; tab->hash_fun = hash_fun; tab->compare_fun = cmp_fun; tab->total_buckets = 0; tab->total_nodes = 0; tab->guardian = (is_weak == Qnil) ? rep_NULL : Fmake_primitive_guardian (); return rep_VAL(tab); } DEFUN("make-weak-table", Fmake_weak_table, Smake_weak_table, (repv hash_fun, repv cmp_fun), rep_Subr2) /* ::doc:rep.data.tables#make-weak-table:: make-weak-table HASH-FUNCTION COMPARE-FUNCTION Similar to `make-table, except that key-value pairs stored in the table are said to be ``weakly keyed''. That is, they are only retained in the table as long the key has not been garbage collected. Unlike with tables created by the `make-table function, the fact that the key is stored in the table is not considered good enough to prevent it being garbage collected. ::end:: */ { return Fmake_table (hash_fun, cmp_fun, Qt); } DEFUN("tablep", Ftablep, Stablep, (repv arg), rep_Subr1) /* ::doc:rep.data.tables#tablep:: tablep ARG Return true if ARG is a hash table. ::end:: */ { return TABLEP(arg) ? Qt : Qnil; } static hash_value hash_key (repv tab, repv key) { repv hash; if (TABLE(tab)->hash_fun == rep_VAL(&Sstring_hash)) hash = Fstring_hash (key); else if (TABLE(tab)->hash_fun == rep_VAL(&Ssymbol_hash)) hash = Fsymbol_hash (key); else if (TABLE(tab)->hash_fun == rep_VAL(&Seq_hash)) hash = Feq_hash (key); else if (TABLE(tab)->hash_fun == rep_VAL(&Sequal_hash)) hash = Fequal_hash (key, Qnil); else { rep_GC_root gc_tab; rep_PUSHGC (gc_tab, tab); hash = rep_call_lisp1 (TABLE(tab)->hash_fun, key); rep_POPGC; } return rep_INT(hash); } static inline int hash_key_to_bin (repv tab, hash_value hash) { return hash % TABLE(tab)->total_buckets; } static inline rep_bool compare (repv tab, repv val1, repv val2) { repv ret; rep_GC_root gc_tab; rep_PUSHGC (gc_tab, tab); ret = rep_call_lisp2 (TABLE(tab)->compare_fun, val1, val2); rep_POPGC; return ret != Qnil; } static node * lookup (repv tab, repv key) { hash_value hv; node *ptr; int index; if (TABLE(tab)->total_buckets == 0) return 0; hv = hash_key (tab, key); index = hash_key_to_bin (tab, hv); for (ptr = TABLE(tab)->buckets[index]; ptr != 0; ptr = ptr->next) { if (ptr->hash == hv && compare (tab, key, ptr->key)) return ptr; } return 0; } DEFUN("table-ref", Ftable_ref, Stable_ref, (repv tab, repv key), rep_Subr2) /* ::doc:rep.data.tables#table-ref:: table-ref TABLE KEY Return the value stored in hash table TABLE indexed by object KEY. Returns false if no such value exists. ::end:: */ { node *n; rep_DECLARE1(tab, TABLEP); n = lookup (tab, key); return n ? n->value : Qnil; } DEFUN("table-bound-p", Ftable_bound_p, Stable_bound_p, (repv tab, repv key), rep_Subr2) /* ::doc:rep.data.tables#table-bound-p:: table-bound-p TABLE KEY Returns true if the hash table TABLE contains a value associated with KEY. ::end:: */ { node *n; rep_DECLARE1(tab, TABLEP); n = lookup (tab, key); return n ? Qt : Qnil; } DEFUN("table-set", Ftable_set, Stable_set, (repv tab, repv key, repv value), rep_Subr3) /* ::doc:rep.data.tables#table-set:: table-set TABLE KEY VALUE Associate VALUE with KEY in hash table TABLE. Returns VALUE. ::end:: */ { node *n; rep_DECLARE1(tab, TABLEP); n = lookup (tab, key); if (n == 0) { int bin; n = rep_alloc (sizeof (node)); rep_data_after_gc += sizeof (node); n->key = key; n->value = value; n->hash = hash_key (tab, key); TABLE(tab)->total_nodes++; if (TABLE(tab)->total_nodes >= 2 * TABLE(tab)->total_buckets) { int old_size, new_size, i; node **new_bins, **old_bins; old_bins = TABLE(tab)->buckets; old_size = TABLE(tab)->total_buckets; /* The (misguided?) idea is to set number of buckets as (2^N) - 1, then increase N each time we get twice as many keys as buckets. Start at N=5 */ if (old_size == 0) new_size = 31; else new_size = (old_size + 1) * 2 - 1; new_bins = rep_alloc (sizeof (node *) * new_size); rep_data_after_gc += sizeof (node *) * new_size; memset (new_bins, 0, sizeof (node *) * new_size); TABLE(tab)->buckets = new_bins; TABLE(tab)->total_buckets = new_size; for (i = 0; i < old_size; i++) { node *ptr, *next; for (ptr = old_bins[i]; ptr != 0; ptr = next) { int index = hash_key_to_bin (tab, ptr->hash); next = ptr->next; ptr->next = new_bins[index]; new_bins[index] = ptr; } } if (old_size > 0) rep_free (old_bins); } bin = hash_key_to_bin (tab, n->hash); n->next = TABLE(tab)->buckets[bin]; TABLE(tab)->buckets[bin] = n; if (TABLE(tab)->guardian) Fprimitive_guardian_push (TABLE(tab)->guardian, n->key); } n->value = value; return value; } DEFUN("table-unset", Ftable_unset, Stable_unset, (repv tab, repv key), rep_Subr2) /* ::doc:rep.data.tables#table-unset:: table-unset TABLE KEY Remove any value stored in TABLE associated with KEY. ::end:: */ { node *n; rep_DECLARE1(tab, TABLEP); n = lookup (tab, key); if (n != 0) { int bin = hash_key_to_bin (tab, n->hash); node **ptr; for (ptr = &(TABLE(tab)->buckets[bin]); *ptr != 0; ptr = &((*ptr)->next)) { if (*ptr == n) { *ptr = n->next; rep_free (n); TABLE(tab)->total_nodes--; return Qt; } } } return Qnil; } DEFUN("table-walk", Ftable_walk, Stable_walk, (repv fun, repv tab), rep_Subr2) /* ::doc:rep.data.tables#table-walk:: table-walk FUNCTION TABLE Call FUNCTION for every key-value pair stored in hash table TABLE. For each pair, the function is called with arguments `(KEY VALUE)'. ::end:: */ { rep_GC_root gc_tab, gc_fun; int i; rep_DECLARE1(tab, TABLEP); rep_PUSHGC (gc_tab, tab); rep_PUSHGC (gc_fun, fun); for (i = 0; i < TABLE(tab)->total_buckets; i++) { node *n; for (n = TABLE(tab)->buckets[i]; n != 0; n = n->next) { if (!rep_call_lisp2 (fun, n->key, n->value)) break; } } rep_POPGC; rep_POPGC; return rep_throw_value ? rep_NULL : Qnil; } DEFUN ("table-size", Ftable_size, Stable_size, (repv tab), rep_Subr1) /* ::doc:rep.data.tables#table-size:: table-size TABLE Returns the number of items currently stored in TABLE. ::end:: */ { rep_DECLARE1 (tab, TABLEP); return rep_make_long_int (TABLE (tab)->total_nodes); } DEFUN("tables-after-gc", Ftables_after_gc, Stables_after_gc, (void), rep_Subr0) { table *x; for (x = all_tables; x != 0; x = x->next) { if (x->guardian) { repv key; while ((key = Fprimitive_guardian_pop (x->guardian)) != Qnil) { rep_GC_root gc_key; rep_PUSHGC (gc_key, key); Ftable_unset (rep_VAL (x), key); rep_POPGC; } } } return Qnil; } /* dl hooks */ repv rep_dl_init (void) { repv tem; table_type = rep_register_new_type ("table", 0, table_print, table_print, table_sweep, table_mark, 0, 0, 0, 0, 0, 0, 0); tem = Fsymbol_value (Qafter_gc_hook, Qt); if (rep_VOIDP (tem)) tem = Qnil; Fset (Qafter_gc_hook, Fcons (rep_VAL(&Stables_after_gc), tem)); tem = rep_push_structure ("rep.data.tables"); /* ::alias:tables rep.data.tables:: */ rep_alias_structure ("tables"); rep_ADD_SUBR(Smake_table); rep_ADD_SUBR(Smake_weak_table); rep_ADD_SUBR(Sstring_hash); rep_ADD_SUBR(Ssymbol_hash); rep_ADD_SUBR(Seq_hash); rep_ADD_SUBR(Sequal_hash); rep_ADD_SUBR(Stablep); rep_ADD_SUBR(Stable_ref); rep_ADD_SUBR(Stable_bound_p); rep_ADD_SUBR(Stable_set); rep_ADD_SUBR(Stable_unset); rep_ADD_SUBR(Stable_walk); rep_ADD_SUBR(Stable_size); rep_ADD_INTERNAL_SUBR(Stables_after_gc); return rep_pop_structure (tem); } librep-0.90.2/src/symbols.c0000644000175200017520000011214311245011153014503 0ustar chrischris/* symbols.c -- Lisp symbol handling Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #define NDEBUG /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include #include #include /* The number of hash buckets in each rep_obarray, this is a prime number. */ #define rep_OBSIZE 509 #define rep_KEY_OBSIZE 127 #define rep_FUNARGBLK_SIZE 204 /* ~4k */ /* Closure allocation blocks */ typedef struct rep_funarg_block_struct { struct rep_funarg_block_struct *next; rep_ALIGN_CELL(rep_funarg data[rep_FUNARGBLK_SIZE]); } rep_funarg_block; /* Main storage of symbols. */ repv rep_obarray, rep_keyword_obarray; /* Plist storage */ static repv plist_structure; DEFSYM(t, "t"); DEFSYM(documentation, "documentation"); DEFSYM(permanent_local, "permanent-local"); /* Function vectors to implement local symbols through. */ repv (*rep_deref_local_symbol_fun)(repv sym) = 0; repv (*rep_set_local_symbol_fun)(repv sym, repv val) = 0; /* This value is stored in the cells of a symbol to denote a void object. */ rep_ALIGN_CELL(static rep_cell void_object) = { rep_Void }; repv rep_void_value = rep_VAL(&void_object); /* The special value which signifies the end of a hash-bucket chain. It can be any Lisp object which isn't a symbol. */ #define OB_NIL rep_VAL(&void_object) /* Used to mark lexical bindings */ rep_ALIGN_CELL(static rep_cell lextag) = { rep_Void }; #define LEXTAG rep_VAL(&lextag) static rep_funarg_block *funarg_block_chain; static rep_funarg *funarg_freelist; int rep_allocated_funargs, rep_used_funargs; /* support for scheme boolean type */ repv rep_scm_t, rep_scm_f; repv rep_undefined_value; /* Symbol management */ DEFUN("make-symbol", Fmake_symbol, Smake_symbol, (repv name), rep_Subr1) /* ::doc:rep.lang.symbols#make-symbol:: make-symbol NAME Returns a new, uninterned, symbol with print-name NAME. It's value and function definition are both void and it has a nil property-list. ::end:: */ { rep_DECLARE1(name, rep_STRINGP); return rep_make_tuple (rep_Symbol, rep_NULL, name); } static void symbol_sweep(void) { /* Need to clear mark bits of dumped symbols, since they're mutable */ if (rep_dumped_symbols_start != rep_dumped_symbols_end) { rep_symbol *s; for(s = rep_dumped_symbols_start; s < rep_dumped_symbols_end; s++) { if(rep_GC_CELL_MARKEDP(rep_VAL(s))) rep_GC_CLR_CELL(rep_VAL(s)); } } } static int symbol_cmp(repv v1, repv v2) { if(rep_TYPE(v1) == rep_TYPE(v2)) { if (v1 == v2) return 0; else return rep_value_cmp (rep_SYM(v1)->name, rep_SYM(v2)->name); } else return 1; } static void symbol_princ(repv strm, repv obj) { rep_stream_puts(strm, rep_PTR(rep_SYM(obj)->name), -1, rep_TRUE); } static void symbol_print(repv strm, repv obj) { /* output a maximum of 2n chars for a symbol name of length n */ char *buf = alloca (rep_STRING_LEN (rep_SYM (obj)->name) * 2); register char *out = buf; register char *s; rep_bool seen_digit = rep_FALSE; if (rep_SYMBOL_LITERAL_P (obj)) { symbol_princ (strm, obj); return; } s = rep_STR (rep_SYM (obj)->name); switch (*s++) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': seen_digit = rep_TRUE; case '-': case '+': case '.': pass1: switch (*s++) { case 0: if (seen_digit) *out++ = '\\'; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': seen_digit = rep_TRUE; case '/': case '.': goto pass1; } } s = rep_STR (rep_SYM (obj)->name); while (1) { char c = *s++; switch (c) { case 0: goto out; case ' ': case '\t': case '\n': case '\f': case '(': case ')': case '[': case ']': case '\'': case '"': case ';': case '\\': case '|': case ',': case '`': *out++ = '\\'; break; case '#': if (!(rep_KEYWORDP (obj) && s-1 == rep_STR (rep_SYM (obj)->name))) *out++ = '\\'; break; default: if (iscntrl (c)) *out++ = '\\'; break; } *out++ = c; } out: rep_stream_puts (strm, buf, out - buf, rep_FALSE); } void rep_intern_static(repv *symp, repv name) { if((*symp = Fintern(name, Qnil))) rep_mark_static(symp); else abort(); } static inline unsigned long hash(char *str) { register unsigned long value = 0; while(*str) value = (value * 33) + *str++; return(value); } DEFUN("make-obarray", Fmake_obarray, Smake_obarray, (repv size), rep_Subr1) /* ::doc:rep.lang.symbols#make-obarray:: make-obarray SIZE Creates a new structure for storing symbols in. This is basically a vector with a few slight differences (all elements initialised to a special value). ::end:: */ { rep_DECLARE1(size, rep_INTP); return(Fmake_vector(size, OB_NIL)); } DEFUN("find-symbol", Ffind_symbol, Sfind_symbol, (repv name, repv ob), rep_Subr2) /* ::doc:rep.lang.symbols#find-symbol:: find-symbol NAME [OBARRAY] Returns the symbol with print-name NAME, found by searching OBARRAY (or the default `rep_obarray' if nil), or nil if no such symbol exists. ::end:: */ { int vsize; rep_DECLARE1(name, rep_STRINGP); if(!rep_VECTORP(ob)) ob = rep_obarray; if((vsize = rep_VECT_LEN(ob)) == 0) return(Qnil); ob = rep_VECT(ob)->array[hash(rep_STR(name)) % vsize]; while(rep_SYMBOLP(ob)) { if(!strcmp(rep_STR(name), rep_STR(rep_SYM(ob)->name))) return(ob); ob = rep_SYM(ob)->next; } return(Qnil); } DEFSTRING(already_interned, "Symbol is already interned"); DEFUN("intern-symbol", Fintern_symbol, Sintern_symbol, (repv sym, repv ob), rep_Subr2) /* ::doc:rep.lang.symbols#intern-symbol:: intern-symbol SYMBOL [OBARRAY] Stores SYMBOL in OBARRAY (or the default). If SYMBOL has already been interned somewhere an error is signalled. ::end:: */ { int vsize, hashid; rep_DECLARE1(sym, rep_SYMBOLP); if(rep_SYM(sym)->next != rep_NULL) { Fsignal(Qerror, rep_list_2(rep_VAL(&already_interned), sym)); return rep_NULL; } if(!rep_VECTORP(ob)) ob = rep_obarray; if((vsize = rep_VECT_LEN(ob)) == 0) return rep_NULL; hashid = hash(rep_STR(rep_SYM(sym)->name)) % vsize; rep_SYM(sym)->next = rep_VECT(ob)->array[hashid]; rep_VECT(ob)->array[hashid] = sym; return(sym); } DEFUN("intern", Fintern, Sintern, (repv name, repv ob), rep_Subr2) /* ::doc:rep.lang.symbols#intern:: intern NAME [OBARRAY] If a symbol with print-name exists in OBARRAY (or the default) return it. Else use `(make-symbol NAME)' to create a new symbol, intern that into the OBARRAY, then return it. ::end:: */ { repv sym; rep_DECLARE1(name, rep_STRINGP); if(!(sym = Ffind_symbol(name, ob)) || (rep_NILP(sym))) { sym = Fmake_symbol(name); if(sym) return(Fintern_symbol(sym, ob)); } return(sym); } DEFUN("unintern", Funintern, Sunintern, (repv sym, repv ob), rep_Subr2) /* ::doc:rep.lang.symbols#unintern:: unintern SYMBOL [OBARRAY] Removes SYMBOL from OBARRAY (or the default). Use this with caution. ::end:: */ { repv list; int vsize, hashid; rep_DECLARE1(sym, rep_SYMBOLP); if(!rep_VECTORP(ob)) ob = rep_obarray; if((vsize = rep_VECT_LEN(ob)) == 0) return rep_NULL; hashid = hash(rep_STR(rep_SYM(sym)->name)) % vsize; list = rep_VECT(ob)->array[hashid]; rep_VECT(ob)->array[hashid] = OB_NIL; while(rep_SYMBOLP(list)) { repv nxt = rep_SYM(list)->next; if(list != sym) { rep_SYM(list)->next = rep_VECT(ob)->array[hashid]; rep_VECT(ob)->array[hashid] = rep_VAL(list); } list = nxt; } rep_SYM(sym)->next = rep_NULL; return(sym); } /* Closures */ DEFUN("make-closure", Fmake_closure, Smake_closure, (repv fun, repv name), rep_Subr2) /* ::doc:rep.lang.interpreter#make-closure:: make-closure FUNCTION &optional NAME Return a functional object which makes the closure of FUNCTION and the current environment. ::end:: */ { rep_funarg *f; if(!funarg_freelist) { rep_funarg_block *sb = rep_ALLOC_CELL(sizeof(rep_funarg_block)); if(sb) { int i; rep_allocated_funargs += rep_FUNARGBLK_SIZE; sb->next = funarg_block_chain; funarg_block_chain = sb; for(i = 0; i < (rep_FUNARGBLK_SIZE - 1); i++) sb->data[i].car = rep_VAL(&sb->data[i + 1]); sb->data[i].car = rep_VAL(funarg_freelist); funarg_freelist = sb->data; } } f = funarg_freelist; funarg_freelist = rep_FUNARG (f->car); rep_data_after_gc += sizeof (rep_funarg); f->car = rep_Funarg; f->fun = fun; f->name = name; f->env = rep_env; f->structure = rep_structure; return rep_VAL (f); } DEFUN("closure-function", Fclosure_function, Sclosure_function, (repv funarg), rep_Subr1) /* ::doc:rep.lang.interpreter#closure-function:: closure-function FUNARG Return the function value associated with the closure FUNARG. ::end:: */ { rep_DECLARE1(funarg, rep_FUNARGP); return rep_FUNARG(funarg)->fun; } DEFUN("set-closure-function", Fset_closure_function, Sset_closure_function, (repv funarg, repv fun), rep_Subr2) /* ::doc:rep.lang.interpreter#set-closure-function:: set-closure-function FUNARG FUNCTION Set the function value in the closure FUNARG to FUNCTION. ::end:: */ { rep_DECLARE1(funarg, rep_FUNARGP); rep_FUNARG(funarg)->fun = fun; return fun; } DEFUN("closure-structure", Fclosure_structure, Sclosure_structure, (repv funarg), rep_Subr1) /* ::doc:rep.structures#closure-function:: closure-function FUNARG Return the structure associated with the closure FUNARG. ::end:: */ { rep_DECLARE1(funarg, rep_FUNARGP); return rep_FUNARG(funarg)->structure; } DEFUN ("set-closure-structure", Fset_closure_structure, Sset_closure_structure, (repv closure, repv structure), rep_Subr2) { rep_DECLARE1 (closure, rep_FUNARGP); rep_DECLARE2 (structure, rep_STRUCTUREP); rep_FUNARG (closure)->structure = structure; return Qnil; } DEFUN("closure-name", Fclosure_name, Sclosure_name, (repv funarg), rep_Subr1) /* ::doc:rep.lang.interpreter#closure-name:: closure-name FUNARG Return the name associated with the closure FUNARG. ::end:: */ { rep_DECLARE1(funarg, rep_FUNARGP); return rep_FUNARG(funarg)->name; } DEFUN("closurep", Fclosurep, Sclosurep, (repv arg), rep_Subr1) /* ::doc:rep.lang.interpreter#closurep:: funargp ARG Returns t if ARG is a closure ::end:: */ { return rep_FUNARGP(arg) ? Qt : Qnil; } DEFUN("set-special-environment", Fset_special_environment, Sset_special_environment, (repv env, repv structure), rep_Subr2) /* ::doc:rep.structures#set-special-environment:: set-special-environment ENV STRUCTURE ::end:: */ { rep_DECLARE2 (structure, rep_STRUCTUREP); rep_STRUCTURE (structure)->special_env = env; return Qt; } static void funarg_sweep (void) { rep_funarg_block *sb = funarg_block_chain; funarg_freelist = NULL; rep_used_funargs = 0; while(sb) { int i; rep_funarg_block *nxt = sb->next; for(i = 0; i < rep_FUNARGBLK_SIZE; i++) { /* if on the freelist then the CELL_IS_8 bit will be unset (since the pointer is long aligned) */ if (rep_CELL_CONS_P(rep_VAL(&sb->data[i])) || !rep_GC_CELL_MARKEDP(rep_VAL(&sb->data[i]))) { sb->data[i].car = rep_VAL(funarg_freelist); funarg_freelist = &sb->data[i]; } else { rep_GC_CLR_CELL(rep_VAL(&sb->data[i])); rep_used_funargs++; } } sb = nxt; } } /* Returns (SYM . VALUE) if a lexical binding, or nil */ static repv search_environment (repv sym) { register repv env; for (env = rep_env; env != Qnil; env = rep_CDR (env)) { if (rep_CONSP (rep_CAR (env)) && rep_CAAR(env) == LEXTAG && rep_CADAR(env) == sym) { return rep_CDAR (env); } } return Qnil; } /* this is also in lispmach.c and fluids.c */ static inline repv inlined_search_special_bindings (repv sym) { register repv env; for (env = rep_special_bindings; env != Qnil; env = rep_CDR (env)) { if (rep_CAAR(env) == sym) return rep_CAR (env); } return Qnil; } static repv search_special_bindings (repv sym) { return inlined_search_special_bindings (sym); } static inline int inlined_search_special_environment (repv sym) { register repv env = rep_SPECIAL_ENV; while (rep_CONSP(env) && rep_CAR(env) != sym) env = rep_CDR(env); if (rep_CONSP(env)) return 1; else if (env == Qt) return -1; else return 0; } static int search_special_environment__ (repv sym) { return inlined_search_special_environment (sym); } static inline int search_special_environment (repv sym) { if (rep_SPECIAL_ENV == Qt) return -1; else return search_special_environment__ (sym); } repv rep_call_with_closure (repv closure, repv (*fun)(repv arg), repv arg) { repv ret = rep_NULL; if (rep_FUNARGP (closure)) { struct rep_Call lc; lc.fun = lc.args = Qnil; rep_PUSH_CALL (lc); rep_USE_FUNARG (closure); ret = fun (arg); rep_POP_CALL (lc); } return ret; } /* Symbol binding */ repv rep_bind_special (repv oldList, repv symbol, repv newVal) { if (inlined_search_special_environment (symbol)) { rep_special_bindings = Fcons (Fcons (symbol, newVal), rep_special_bindings); oldList = rep_MARK_SPEC_BINDING (oldList); } else Fsignal (Qvoid_value, rep_LIST_1(symbol)); return oldList; } /* This give SYMBOL a new value, saving the old one onto the front of the list OLDLIST. OLDLIST is structured like (NSPECIALS . NLEXICALS) Returns the new version of OLDLIST. */ repv rep_bind_symbol(repv oldList, repv symbol, repv newVal) { if (oldList == Qnil) oldList = rep_NEW_FRAME; if (rep_SYM(symbol)->car & rep_SF_SPECIAL) { /* special binding */ oldList = rep_bind_special (oldList, symbol, newVal); } else { rep_env = Fcons (Fcons (LEXTAG, Fcons (symbol, newVal)), rep_env); oldList = rep_MARK_LEX_BINDING (oldList); } return oldList; } /* Undoes what the above function does. Returns the number of special bindings undone. */ int rep_unbind_symbols(repv oldList) { if (oldList != Qnil) { register repv tem; int lexicals, specials; int i; assert (rep_INTP(oldList)); lexicals = rep_LEX_BINDINGS (oldList); specials = rep_SPEC_BINDINGS (oldList); tem = rep_env; for (i = lexicals; i > 0; i--) tem = rep_CDR (tem); rep_env = tem; tem = rep_special_bindings; for (i = specials; i > 0; i--) { tem = rep_CDR (tem); } rep_special_bindings = tem; assert (rep_special_bindings != rep_void_value); assert (rep_env != rep_void_value); return specials; } else return 0; } repv rep_add_binding_to_env (repv env, repv sym, repv value) { return Fcons (Fcons (LEXTAG, Fcons (sym, value)), env); } /* More lisp functions */ DEFUN("defvar", Fdefvar, Sdefvar, (repv args, repv tail_posn), rep_SF) /* ::doc:rep.lang.interpreter#defvar:: defvar NAME [DEFAULT-VALUE [DOC-STRING]] Define a special variable called NAME whose standard value is DEFAULT- VALUE. If NAME is already bound to a value (that's not an autoload definition) it is left as it is, otherwise DEFAULT-VALUE is evaluated and the special value of NAME is bound to the result. If DOC-STRING is given, and is a string, it will be used to set the `documentation' property of the symbol NAME. (If the symbol NAME is marked buffer-local the default value of the variable will be set (if necessary) not the local value.) ::end:: */ { if(rep_CONSP(args)) { int spec; repv sym = rep_CAR(args), val; rep_bool need_to_eval; repv tmp = Fdefault_boundp(sym); if(!tmp) return rep_NULL; if (rep_CONSP(rep_CDR(args))) { val = rep_CADR(args); args = rep_CDDR (args); } else { val = Qnil; args = Qnil; } need_to_eval = rep_TRUE; if(!rep_NILP(tmp)) { /* Variable is bound, see if it's an autoload defn to overwrite. */ repv val = Fsymbol_value (sym, Qt); if (rep_FUNARGP(val)) { val = rep_FUNARG(val)->fun; if(rep_CONSP(val) && rep_CAR(val) == Qautoload) { Fmakunbound (sym); tmp = Qnil; } } } /* Only allowed to defvar in restricted environments if the symbol hasn't yet been defvar'd or it's weak */ spec = search_special_environment (sym); if (spec == 0 && (rep_SYM(sym)->car & rep_SF_DEFVAR) && !(rep_SYM(sym)->car & rep_SF_WEAK)) { return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */ } /* if initially making it special, check for a lexical binding in the current module */ if (!(rep_SYM(sym)->car & rep_SF_SPECIAL)) { repv tem = rep_get_initial_special_value (sym); if (tem) { val = tem; need_to_eval = rep_FALSE; tmp = Qnil; } } /* Only set the [default] value if its not boundp or the definition is weak and we're currently unrestricted */ if(rep_NILP(tmp) || ((rep_SYM(sym)->car & rep_SF_WEAK) && !(rep_SYM(sym)->car & rep_SF_WEAK_MOD) && rep_SPECIAL_ENV == Qt)) { if (need_to_eval) { rep_GC_root gc_sym, gc_args; rep_PUSHGC (gc_sym, sym); rep_PUSHGC (gc_args, args); val = Feval (val); rep_POPGC; rep_POPGC; if (!val) return rep_NULL; } Fstructure_define (rep_specials_structure, sym, val); } rep_SYM(sym)->car |= rep_SF_SPECIAL | rep_SF_DEFVAR; if (spec == 0) { /* defvar'ing an undefvar'd variable from a restricted environment sets it as weak, and adds it to the env */ rep_SYM(sym)->car |= rep_SF_WEAK; rep_SPECIAL_ENV = Fcons (sym, rep_SPECIAL_ENV); } else if (rep_SPECIAL_ENV == Qt && (rep_SYM(sym)->car & rep_SF_WEAK)) { /* defvar'ing a weak variable from an unrestricted environment removes the weak status, but marks it as `was weak, but now strong'. This prevents exploits such as: [restricted special environment] (defvar special-var "/bin/rm") [unrestricted environment] (defvar special-var "ls") [back in restricted environment] (setq special-var "/bin/rm") --> error Setting the variable the first time (since it's unbound) adds it to the restricted environment, but defvar'ing effectively removes it */ rep_SYM(sym)->car &= ~rep_SF_WEAK; rep_SYM(sym)->car |= rep_SF_WEAK_MOD; } if(rep_CONSP(args)) { repv doc = rep_CAR(args); if (rep_STRINGP (doc)) { if (Fput(sym, Qdocumentation, doc) == rep_NULL) return rep_NULL; } } return sym; } else return rep_signal_missing_arg (1); } DEFUN("symbol-value", Fsymbol_value, Ssymbol_value, (repv sym, repv no_err), rep_Subr2) /* ::doc:rep.lang.symbols#symbol-value:: symbol-value SYMBOL Returns the value of SYMBOL, if SYMBOL is flagged as having buffer-local values look for one of those first. ::end:: */ /* Second argument (NO-ERR) means don't signal an error if the value is void. */ { /* Some of this function is hardcoded into the OP_REFQ instruction in lispmach.c */ repv val = rep_void_value; rep_DECLARE1(sym, rep_SYMBOLP); if (rep_SYM(sym)->car & rep_SF_SPECIAL) { int spec = inlined_search_special_environment (sym); /* modified-weak specials can only be accessed from an unrestricted environment */ if (spec < 0 || (spec > 0 && !(rep_SYM(sym)->car & rep_SF_WEAK_MOD))) { if(rep_SYM(sym)->car & rep_SF_LOCAL) val = (*rep_deref_local_symbol_fun)(sym); if (val == rep_void_value) { repv tem = inlined_search_special_bindings (sym); if (tem != Qnil) val = rep_CDR (tem); else val = F_structure_ref (rep_specials_structure, sym); } } } else { /* lexical variable */ repv tem = search_environment (sym); if (tem != Qnil) val = rep_CDR(tem); else val = F_structure_ref (rep_structure, sym); } if (rep_SYM(sym)->car & rep_SF_DEBUG) rep_single_step_flag = rep_TRUE; if(no_err == Qnil && rep_VOIDP(val)) return Fsignal(Qvoid_value, rep_LIST_1(sym)); else return val; } DEFUN("default-value", Fdefault_value, Sdefault_value, (repv sym, repv no_err), rep_Subr2) /* ::doc:rep.lang.symbols#default-value:: default-value SYMBOL Returns the default value of the symbol SYMBOL. This will be the value of SYMBOL in buffers or windows which do not have their own local value. ::end:: */ { repv val = rep_void_value; rep_DECLARE1(sym, rep_SYMBOLP); if (rep_SYM(sym)->car & rep_SF_SPECIAL) { int spec = search_special_environment (sym); if (spec < 0 || (spec > 0 && !(rep_SYM(sym)->car & rep_SF_WEAK_MOD))) { repv tem = search_special_bindings (sym); if (tem != Qnil) val = rep_CDR (tem); else val = F_structure_ref (rep_specials_structure, sym); } } else val = F_structure_ref (rep_structure, sym); if(no_err == Qnil && rep_VOIDP(val)) return Fsignal(Qvoid_value, rep_LIST_1(sym)); else return val; } static repv do_set (repv sym, repv val, repv (*setter)(repv st, repv var, repv val)) { /* Some of this function is hardcoded into the OP_SETQ instruction in lispmach.c */ rep_DECLARE1(sym, rep_SYMBOLP); if (rep_SYM(sym)->car & rep_SF_SPECIAL) { int spec = inlined_search_special_environment (sym); if (spec) { repv tem; /* Not allowed to set `modified' variables unless our environment includes all variables implicitly */ if (spec > 0 && rep_SYM(sym)->car & rep_SF_WEAK_MOD) return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */ if(rep_SYM(sym)->car & rep_SF_LOCAL) { repv tem = (*rep_set_local_symbol_fun)(sym, val); if (tem != rep_NULL) return tem; /* Fall through and set the default value. */ } tem = inlined_search_special_bindings (sym); if (tem != Qnil) rep_CDR (tem) = val; else val = Fstructure_define (rep_specials_structure, sym, val); } else val = Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */ } else { /* lexical binding */ repv tem = search_environment (sym); if (tem != Qnil) rep_CDR(tem) = val; else val = setter (rep_structure, sym, val); } return val; } /* backwards compatibility for C callers */ repv Fset (repv s, repv v) { return do_set (s, v, Fstructure_define); }; DEFUN_INT("set", Freal_set, Sset, (repv s, repv v), rep_Subr2, "vVariable:" rep_DS_NL "xNew value of %s:") /* ::doc:rep.lang.symbols#set:: set SYMBOL repv Sets the value of SYMBOL to repv. If SYMBOL has a buffer-local binding in the current buffer or `make-variable-buffer-local' has been called on SYMBOL the buffer-local value in the current buffer is set. Returns repv. ::end:: */ { return do_set (s, v, Fstructure_set); } DEFUN("set-default", Fset_default, Sset_default, (repv sym, repv val), rep_Subr2) /* ::doc:rep.lang.symbols#set-default:: set-default SYMBOL VALUE Sets the default value of SYMBOL to VALUE, then returns VALUE. ::end:: */ { rep_DECLARE1(sym, rep_SYMBOLP); if (rep_SYM (sym)->car & rep_SF_SPECIAL) { int spec = search_special_environment (sym); if (spec) { repv tem; if (spec > 0 && rep_SYM(sym)->car & rep_SF_WEAK_MOD) return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */ tem = search_special_bindings (sym); if (tem != Qnil) rep_CDR (tem) = val; else val = Fstructure_define (rep_specials_structure, sym, val); } else return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */ } else Fstructure_set (rep_structure, sym, val); return val; } DEFUN("setplist", Fsetplist, Ssetplist, (repv sym, repv prop), rep_Subr2) /* ::doc:rep.lang.symbols#setplist:: setplist SYMBOL PROP-LIST Sets the property list of SYMBOL to PROP-LIST, returns PROP-LIST. ::end:: */ { int spec; rep_DECLARE1(sym, rep_SYMBOLP); spec = search_special_environment (sym); if (spec == 0) return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */ Fstructure_define (plist_structure, sym, prop); return prop; } DEFUN("symbol-name", Fsymbol_name, Ssymbol_name, (repv sym), rep_Subr1) /* ::doc:rep.lang.symbols#symbol-name:: symbol-name SYMBOL Returns the print-name of SYMBOL. ::end:: */ { rep_DECLARE1(sym, rep_SYMBOLP); return(rep_SYM(sym)->name); } DEFUN("default-boundp", Fdefault_boundp, Sdefault_boundp, (repv sym), rep_Subr1) /* ::doc:rep.lang.symbols#default-boundp:: default-boundp SYMBOL Returns t if SYMBOL has a default value. ::end:: */ { rep_DECLARE1(sym, rep_SYMBOLP); if (rep_SYM(sym)->car & rep_SF_SPECIAL) { repv tem = search_special_bindings (sym); if (tem != Qnil) return rep_VOIDP (rep_CDR (tem)) ? Qnil : Qt; else { tem = F_structure_ref (rep_specials_structure, sym); return rep_VOIDP (tem) ? Qnil : Qt; } } else return Fstructure_bound_p (rep_structure, sym); } DEFUN("boundp", Fboundp, Sboundp, (repv sym), rep_Subr1) /* ::doc:rep.lang.symbols#boundp:: boundp SYMBOL Returns t if SYMBOL has a value as a variable. ::end:: */ { rep_DECLARE1(sym, rep_SYMBOLP); return(rep_VOIDP(Fsymbol_value(sym, Qt)) ? Qnil : Qt); } DEFUN("symbol-plist", Fsymbol_plist, Ssymbol_plist, (repv sym), rep_Subr1) /* ::doc:rep.lang.symbols#symbol-plist:: symbol-plist SYMBOL Returns the property-list of SYMBOL. ::end:: */ { int spec; repv plist; rep_DECLARE1(sym, rep_SYMBOLP); spec = search_special_environment (sym); if (spec == 0) return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */ plist = F_structure_ref (plist_structure, sym); return rep_VOIDP (plist) ? Qnil : plist; } DEFUN("gensym", Fgensym, Sgensym, (void), rep_Subr0) /* ::doc:rep.lang.symbols#gensym:: gensym Returns a new (non-interned) symbol with a unique print name. ::end:: */ { static int counter; char buf[20]; counter++; #ifdef HAVE_SNPRINTF snprintf(buf, sizeof(buf), "G%04d", counter); #else sprintf(buf, "G%04d", counter); #endif return(Fmake_symbol(rep_string_dup(buf))); } DEFUN("symbolp", Fsymbolp, Ssymbolp, (repv sym), rep_Subr1) /* ::doc:rep.lang.symbols#symbolp:: symbolp ARG Returns t if ARG is a symbol. ::end:: */ { return(rep_SYMBOLP(sym) ? Qt : Qnil); } DEFUN("setq", Fsetq, Ssetq, (repv args, repv tail_posn), rep_SF) /* ::doc:rep.lang.interpreter#setq:: setq [SYMBOL FORM] ... Sets the value of each SYMBOL to the value of its corresponding FORM evaluated, returns the value of the last evaluation. ::end:: */ { repv res = Qnil; rep_GC_root gc_args; rep_PUSHGC(gc_args, args); while(rep_CONSP(args) && rep_CONSP(rep_CDR(args)) && rep_SYMBOLP(rep_CAR(args))) { if(!(res = Feval(rep_CAR(rep_CDR(args))))) goto end; if(!Freal_set(rep_CAR(args), res)) { res = rep_NULL; goto end; } args = rep_CDR(rep_CDR(args)); } end: rep_POPGC; return(res); } DEFUN ("%define", F_define, S_define, (repv args, repv tail_posn), rep_SF) /* ::doc:rep.lang.interpreter#%define:: %define SYMBOL FORM [DOC-STRING] Evaluate FORM, then create a top-level binding of SYMBOL whose value is the result of the evaluation. If such a binding already exists, it will be overwritten. ::end:: */ { repv var, value, doc = Qnil; rep_GC_root gc_var, gc_doc; if (!rep_assign_args (args, 2, 3, &var, &value, &doc)) return rep_NULL; rep_PUSHGC (gc_var, var); rep_PUSHGC (gc_doc, doc); value = Feval (value); rep_POPGC; rep_POPGC; if (value == rep_NULL) return rep_NULL; value = Fstructure_define (rep_structure, var, value); if (value != rep_NULL) { if (doc != Qnil) { repv prop = rep_documentation_property (rep_structure); if (prop != Qnil) { if (Fput (var, prop, doc) == rep_NULL) value = rep_NULL; } } } return rep_undefined_value; } DEFUN("makunbound", Fmakunbound, Smakunbound, (repv sym), rep_Subr1) /* ::doc:rep.lang.symbols#makunbound:: makunbound SYMBOL Make SYMBOL have no value as a variable. ::end:: */ { return Freal_set (sym, rep_void_value); } DEFUN("get", Fget, Sget, (repv sym, repv prop), rep_Subr2) /* ::doc:rep.lang.symbols#get:: get SYMBOL PROPERTY Returns the value of SYMBOL's property PROPERTY. See `put'. ::end:: */ { repv plist; rep_DECLARE1(sym, rep_SYMBOLP); plist = F_structure_ref (plist_structure, sym); if (rep_VOIDP (plist)) return Qnil; while(rep_CONSP(plist) && rep_CONSP(rep_CDR(plist))) { if(rep_CAR(plist) == prop || (!rep_SYMBOLP(prop) && rep_value_cmp (rep_CAR(plist), prop) == 0)) { return(rep_CAR(rep_CDR(plist))); } plist = rep_CDR(rep_CDR(plist)); } return(Qnil); } DEFUN("put", Fput, Sput, (repv sym, repv prop, repv val), rep_Subr3) /* ::doc:rep.lang.symbols#put:: put SYMBOL PROPERTY repv Sets the value of SYMBOL's property PROPERTY to repv, this value can be retrieved with the `get' function. ::end:: */ { repv plist, old; int spec; rep_DECLARE1(sym, rep_SYMBOLP); spec = search_special_environment (sym); if (spec == 0) return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */ old = F_structure_ref (plist_structure, sym); if (rep_VOIDP (old)) old = Qnil; plist = old; while(rep_CONSP(plist) && rep_CONSP(rep_CDR(plist))) { if(rep_CAR(plist) == prop || (!rep_SYMBOLP(prop) && rep_value_cmp (rep_CAR(plist), prop) == 0)) { if(!rep_CONS_WRITABLE_P(rep_CDR(plist))) { /* Can't write into a dumped cell; need to cons onto the head. */ break; } rep_CAR(rep_CDR(plist)) = val; return val; } plist = rep_CDR(rep_CDR(plist)); } Fstructure_define (plist_structure, sym, Fcons (prop, Fcons (val, old))); return val; } DEFUN("apropos", Fapropos, Sapropos, (repv re, repv pred, repv ob), rep_Subr3) /* ::doc:rep.lang.symbols#apropos:: apropos REGEXP [PREDICATE] [OBARRAY] Returns a list of symbols from OBARRAY (or the default) whose print-name matches the regular-expression REGEXP. If PREDICATE is given and non-nil, each symbol which matches is applied to the function PREDICATE, if the value is non-nil it is considered a match. ::end:: */ { rep_regexp *prog; rep_DECLARE1(re, rep_STRINGP); if(!rep_VECTORP(ob)) ob = rep_obarray; prog = rep_regcomp(rep_STR(re)); if(prog) { repv last = Qnil; int i, len = rep_VECT_LEN(ob); rep_GC_root gc_last, gc_ob, gc_pred; rep_PUSHGC(gc_last, last); rep_PUSHGC(gc_ob, ob); rep_PUSHGC(gc_pred, pred); for(i = 0; i < len; i++) { repv chain = rep_VECT(ob)->array[i]; while(rep_SYMBOLP(chain)) { if(rep_regexec(prog, rep_STR(rep_SYM(chain)->name))) { if(pred && !rep_NILP(pred)) { repv tmp; if(!(tmp = rep_funcall(pred, rep_LIST_1(chain), rep_FALSE)) || rep_NILP(tmp)) { goto next; } } last = Fcons(chain, last); } next: chain = rep_SYM(chain)->next; } } rep_POPGC; rep_POPGC; rep_POPGC; free(prog); return(last); } return rep_NULL; } DEFUN("make-variable-special", Fmake_variable_special, Smake_variable_special, (repv sym), rep_Subr1) /* ::doc:rep.lang.symbols#make-variable-special:: make-variable-special SYMBOL Mark SYMBOL as being a special (dynamically-bound) variable. ::end:: */ { int spec; rep_DECLARE1(sym, rep_SYMBOLP); spec = search_special_environment (sym); if (spec == 0) return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */ if (!(rep_SYM(sym)->car & rep_SF_SPECIAL)) { repv tem = rep_get_initial_special_value (sym); if (tem) Fstructure_define (rep_specials_structure, sym, tem); } rep_SYM(sym)->car |= rep_SF_SPECIAL; return sym; } DEFUN("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, (repv sym), rep_Subr1) /* ::doc:rep.lang.symbols#special-variable-p:: special-variable-p SYMBOL Returns t if SYMBOL is a special variable (dynamically scoped). ::end:: */ { rep_DECLARE1(sym, rep_SYMBOLP); return (rep_SYM(sym)->car & rep_SF_SPECIAL) ? Qt : Qnil; } DEFUN_INT("trace", Ftrace, Strace, (repv sym), rep_Subr1, "aFunction to trace") /* ::doc:rep.lang.debug#trace:: trace SYMBOL Flag that whenever SYMBOL is evaluated (as a variable or a function) the debugger is entered. ::end:: */ { rep_DECLARE1(sym, rep_SYMBOLP); rep_SYM(sym)->car |= rep_SF_DEBUG; return(sym); } DEFUN_INT("untrace", Funtrace, Suntrace, (repv sym), rep_Subr1, "aFunction to untrace") /* ::doc:rep.lang.debug#untrace:: untrace SYMBOL Cancel the effect of (trace SYMBOL). ::end:: */ { rep_DECLARE1(sym, rep_SYMBOLP); rep_SYM(sym)->car &= ~rep_SF_DEBUG; return(sym); } DEFUN("obarray", Fobarray, Sobarray, (repv val), rep_Subr1) /* ::doc:rep.lang.symbols#obarray:: obarray [NEW-VALUE] ::end:: */ { if(val != Qnil) { rep_DECLARE1(val, rep_VECTORP); rep_obarray = val; } return rep_obarray; } DEFUN("make-keyword", Fmake_keyword, Smake_keyword, (repv in), rep_Subr1) /* ::doc:rep.lang.symbols#make-keyword:: make-keyword SYMBOL Return the keyword symbol that should be used in argument lists to provide the mark the value of the argument called SYMBOL. An error is signalled if SYMBOL is itself a keyword. ::end:: */ { repv str, name, key; int name_len; rep_DECLARE (1, in, rep_SYMBOLP (in) && !rep_KEYWORDP (in)); name = rep_SYM (in)->name; name_len = rep_STRING_LEN (name); str = rep_make_string (name_len + 3); rep_STR (str)[0] = '#'; rep_STR (str)[1] = ':'; memcpy (rep_STR (str) + 2, rep_STR (name), name_len); rep_STR (str)[name_len+2] = 0; key = Fintern (str, rep_keyword_obarray); rep_SYM (key)->car |= rep_SF_KEYWORD; return key; } DEFUN ("keywordp", Fkeywordp, Skeywordp, (repv arg), rep_Subr1) /* ::doc:rep.lang.symbols#keywordp:: keywordp ARG Return true if ARG is a keyword symbol. ::end:: */ { return rep_KEYWORDP (arg) ? Qt : Qnil; } int rep_pre_symbols_init(void) { rep_register_type(rep_Symbol, "symbol", symbol_cmp, symbol_princ, symbol_print, symbol_sweep, 0, 0, 0, 0, 0, 0, 0, 0); rep_obarray = Fmake_obarray(rep_MAKE_INT(rep_OBSIZE)); rep_keyword_obarray = Fmake_obarray(rep_MAKE_INT(rep_KEY_OBSIZE)); rep_register_type(rep_Funarg, "funarg", rep_ptr_cmp, rep_lisp_prin, rep_lisp_prin, funarg_sweep, 0, 0, 0, 0, 0, 0, 0, 0); if(rep_obarray && rep_keyword_obarray) { rep_mark_static(&rep_obarray); rep_mark_static(&rep_keyword_obarray); return rep_TRUE; } else return rep_FALSE; } void rep_symbols_init(void) { DEFSTRING (hash_f, "#f"); DEFSTRING (hash_t, "#t"); DEFSTRING (hash_undefined, "#undefined"); repv tem; rep_pre_datums_init (); /* initializes Qnil */ rep_INTERN(t); rep_pre_structures_init (); rep_USE_DEFAULT_ENV; rep_special_bindings = Qnil; rep_mark_static (&rep_env); rep_mark_static (&rep_special_bindings); plist_structure = Fmake_structure (Qnil, Qnil, Qnil, Qnil); rep_mark_static (&plist_structure); rep_INTERN(documentation); rep_INTERN(permanent_local); rep_scm_f = Fmake_symbol (rep_VAL (&hash_f)); rep_scm_t = Fmake_symbol (rep_VAL (&hash_t)); rep_undefined_value = Fmake_symbol (rep_VAL (&hash_undefined)); rep_SYM(rep_scm_f)->car |= rep_SF_LITERAL; rep_SYM(rep_scm_t)->car |= rep_SF_LITERAL; rep_SYM(rep_undefined_value)->car |= rep_SF_LITERAL; rep_mark_static (&rep_scm_f); rep_mark_static (&rep_scm_t); rep_mark_static (&rep_undefined_value); tem = rep_push_structure ("rep.lang.symbols"); rep_ADD_SUBR(Smake_symbol); rep_ADD_SUBR(Smake_obarray); rep_ADD_SUBR(Sfind_symbol); rep_ADD_SUBR(Sintern_symbol); rep_ADD_SUBR(Sintern); rep_ADD_SUBR(Sunintern); rep_ADD_SUBR(Ssymbol_value); rep_ADD_SUBR_INT(Sset); rep_ADD_SUBR(Ssetplist); rep_ADD_SUBR(Ssymbol_name); rep_ADD_SUBR(Sdefault_value); rep_ADD_SUBR(Sdefault_boundp); rep_ADD_SUBR(Sset_default); rep_ADD_SUBR(Sboundp); rep_ADD_SUBR(Ssymbol_plist); rep_ADD_SUBR(Sgensym); rep_ADD_SUBR(Ssymbolp); rep_ADD_SUBR(Smakunbound); rep_ADD_SUBR(Sget); rep_ADD_SUBR(Sput); rep_ADD_SUBR(Sapropos); rep_ADD_SUBR(Smake_variable_special); rep_ADD_SUBR(Sspecial_variable_p); rep_ADD_SUBR(Sobarray); rep_ADD_SUBR(Smake_keyword); rep_ADD_SUBR(Skeywordp); rep_pop_structure (tem); tem = rep_push_structure ("rep.lang.interpreter"); rep_ADD_SUBR(Ssetq); rep_ADD_SUBR(S_define); rep_ADD_SUBR(Sdefvar); rep_ADD_SUBR(Smake_closure); rep_ADD_SUBR(Sclosure_function); rep_ADD_SUBR(Sset_closure_function); rep_ADD_SUBR(Sclosure_name); rep_ADD_SUBR(Sclosurep); rep_pop_structure (tem); tem = rep_push_structure ("rep.structures"); rep_ADD_SUBR(Sclosure_structure); rep_ADD_SUBR(Sset_closure_structure); rep_ADD_SUBR(Sset_special_environment); rep_pop_structure (tem); tem = rep_push_structure ("rep.lang.debug"); rep_ADD_SUBR_INT(Strace); rep_ADD_SUBR_INT(Suntrace); rep_pop_structure (tem); } librep-0.90.2/src/structures.c0000644000175200017520000012426611245011153015247 0ustar chrischris/* structures.c -- rep's module system Copyright (C) 2000 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* Uncomment the next line to print cache miss ratios */ /* #define DEBUG 1 */ /* The cache type */ #define SINGLE_SA_CACHE 1 /* Notes: rep's module system is based on the Scheme48 system, which itself takes ideas from Standard ML and Xerox scheme. Modules are known as structures (from SML) and may be anonymous or named (as with functions, but in a separate namespace), but only named structures may be imported or accessed. Each structure is basically a separate global namespace, with a number of variable bindings. Each closure contains a reference to the structure it was instantiated in, providing the source for referencing any unbound variables. Each structure presents an interface to any structures that import its bindings. This interface is simply the list of symbols whose bindings may be referenced from outside. Structures may either `open' or `access' other structures; when opening a structure all its exported bindings are immediately referenceable from the importing structures. Exported bindings from accessed structures are referenced using the `structure-ref' form Structures are implemented as first-class objects, but only a second- class view is presented to most lisp code, this is to enable static analysis of package imports and exports at compile time Here is the module language grammar adapted from Rees' memo: -> (define-structure
*) (define-interface ) -> (structure *) -> (export *) (compound-interface *) -> (*) -> (open *) (access *) Most files will just contain a single `(define-structure ...)' form. E.g.: (define-structure foo (export foo) (open rep) (defun foo (x) (1+ x))) As Rees points out, this changes load from being used for its side effects to being used for its value, the created structure. For backwards compatibility, the `require' form now works with both simple files and files containing module definitions. E.g. if a file called `foo.jl' contains the above example, then doing "(require 'foo)" would open the module in the current environment. Special variables have their own isolated namespace (the structure called `%specials') and thus their names can still clash across structures.. */ #define _GNU_SOURCE /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include #ifdef NEED_MEMORY_H # include #endif #define MIN_BUCKETS 8 #define MAX_MULTIPLIER 2 int rep_structure_type; static rep_struct *all_structures; #define rep_INTERFACEP(v) rep_LISTP(v) /* the currently active namespace */ repv rep_structure; /* the `default' namespace, where all rep language bindings go */ repv rep_default_structure; /* the namespace for special variables */ repv rep_specials_structure; /* the structure namespace */ static repv rep_structures_structure; DEFSYM(features, "features"); DEFSYM(_structures, "%structures"); DEFSYM(_meta, "%meta"); DEFSYM(rep, "rep"); DEFSYM(_specials, "%specials"); DEFSYM(_user_structure_, "*user-structure*"); DEFSYM(rep_structures, "rep.structures"); DEFSYM(rep_lang_interpreter, "rep.lang.interpreter"); DEFSYM(rep_vm_interpreter, "rep.vm.interpreter"); DEFSYM(external, "external"); DEFSYM(local, "local"); static rep_struct_node *lookup_or_add (rep_struct *s, repv var); /* cached lookups */ #ifdef DEBUG /* Hits and misses are obvious. Collisions occur when a miss ejects data from the cache, conflicts when a miss ejects data for the _same_ symbol. */ static int ref_cache_hits, ref_cache_misses, ref_cache_collisions, ref_cache_conflicts; static void print_cache_stats (void) { fprintf (stderr, "ref cache miss ratio: %g\n", (double) ref_cache_misses / (ref_cache_hits + ref_cache_misses)); fprintf (stderr, " - collisions: %g\n", (double) ref_cache_collisions / ref_cache_misses); fprintf (stderr, " - conflicts: %g\n", (double) ref_cache_conflicts / ref_cache_misses); } #endif #if defined SINGLE_DM_CACHE /* This is a very simple cache; a single direct-mapped table, indexed by symbol address */ #define CACHE_SETS 256 #define CACHE_HASH(x) (((x) >> 4) % CACHE_SETS) struct cache_line { rep_struct *s; rep_struct_node *n; }; static struct cache_line ref_cache[CACHE_SETS]; static inline void enter_cache (rep_struct *s, rep_struct_node *binding) { unsigned int hash = CACHE_HASH (binding->symbol); if (ref_cache[hash].s != 0) { #ifdef DEBUG if (ref_cache[hash].n->symbol == binding->symbol) ref_cache_conflicts++; else ref_cache_collisions++; #endif } ref_cache[hash].s = s; ref_cache[hash].n = binding; } static inline rep_struct_node * lookup_cache (rep_struct *s, repv var) { unsigned int hash = CACHE_HASH (var); if (ref_cache[hash].s == s && ref_cache[hash].n->symbol == var) { #ifdef DEBUG ref_cache_hits++; #endif return ref_cache[hash].n; } else { #ifdef DEBUG ref_cache_misses++; #endif return 0; } } static inline void cache_invalidate_symbol (repv symbol) { unsigned int hash = CACHE_HASH (symbol); if (ref_cache[hash].s != 0 && ref_cache[hash].n->symbol == symbol) ref_cache[hash].s = 0; } static void cache_invalidate_struct (rep_struct *s) { int i; for (i = 0; i < CACHE_SETS; i++) { if (ref_cache[i].s == s) ref_cache[i].s = 0; } } static inline void cache_flush (void) { /* assumes null pointer == all zeros.. */ memset (ref_cache, 0, sizeof (ref_cache)); } #elif defined SINGLE_SA_CACHE /* The above doesn't work so well now that there are more modules, moving to 4-way set-associative eliminates significant conflict misses in most cases. */ #define CACHE_SETS 128 #define CACHE_HASH(x) (((x) >> 3) % CACHE_SETS) #define CACHE_ASSOC 4 struct cache_line { rep_struct *s; rep_struct_node *n; int age; }; static struct cache_line ref_cache[CACHE_SETS][CACHE_ASSOC]; static int ref_age; static inline void enter_cache (rep_struct *s, rep_struct_node *binding) { unsigned int hash = CACHE_HASH (binding->symbol); int i, oldest_i, oldest_age = INT_MAX; for (i = 0; i < CACHE_ASSOC; i++) { if (ref_cache[hash][i].s == 0) { oldest_i = i; break; } else if (ref_cache[hash][i].age < oldest_age) { oldest_i = i; oldest_age = ref_cache[hash][i].age; } } assert (oldest_i < CACHE_ASSOC); #ifdef DEBUG if (ref_cache[hash][oldest_i].s != 0) { if (ref_cache[hash][oldest_i].n->symbol == binding->symbol) ref_cache_conflicts++; else ref_cache_collisions++; } #endif ref_cache[hash][oldest_i].s = s; ref_cache[hash][oldest_i].n = binding; ref_cache[hash][oldest_i].age = ++ref_age; } static inline rep_struct_node * lookup_cache (rep_struct *s, repv var) { unsigned int hash = CACHE_HASH (var); int i; for (i = 0; i < CACHE_ASSOC; i++) { if (ref_cache[hash][i].s == s && ref_cache[hash][i].n->symbol == var) { #ifdef DEBUG ref_cache_hits++; #endif ref_cache[hash][i].age++; return ref_cache[hash][i].n; } } #ifdef DEBUG ref_cache_misses++; #endif return 0; } static inline void cache_invalidate_symbol (repv symbol) { unsigned int hash = CACHE_HASH (symbol); int i; for (i = 0; i < CACHE_ASSOC; i++) { if (ref_cache[hash][i].s != 0 && ref_cache[hash][i].n->symbol == symbol) { ref_cache[hash][i].s = 0; } } } static void cache_invalidate_struct (rep_struct *s) { int i, j; for (i = 0; i < CACHE_SETS; i++) { for (j = 0; j < CACHE_ASSOC; j++) { if (ref_cache[i][j].s == s) ref_cache[i][j].s = 0; } } } static inline void cache_flush (void) { /* assumes null pointer == all zeros.. */ memset (ref_cache, 0, sizeof (ref_cache)); } #else /* SINGLE_SA_CACHE */ /* no cache at all */ static inline void enter_cache (rep_struct *s, rep_struct_node *binding) { } static inline rep_struct_node * lookup_cache (rep_struct *s, repv var) { #ifdef DEBUG ref_cache_misses++; #endif return 0; } static inline void cache_invalidate_symbol (repv symbol) { } static void cache_invalidate_struct (rep_struct *s) { } static void cache_flush (void) { } #endif /* !SINGLE_DM_CACHE */ /* type hooks */ static void structure_mark (repv x) { int i; for (i = 0; i < rep_STRUCTURE(x)->total_buckets; i++) { rep_struct_node *n; for (n = rep_STRUCTURE(x)->buckets[i]; n != 0; n = n->next) { rep_MARKVAL(n->symbol); rep_MARKVAL(n->binding); } } rep_MARKVAL (rep_STRUCTURE (x)->name); rep_MARKVAL (rep_STRUCTURE (x)->inherited); rep_MARKVAL (rep_STRUCTURE (x)->imports); rep_MARKVAL (rep_STRUCTURE (x)->accessible); rep_MARKVAL (rep_STRUCTURE (x)->special_env); } static void free_structure (rep_struct *x) { int i; cache_invalidate_struct (x); for (i = 0; i < x->total_buckets; i++) { rep_struct_node *n, *next; for (n = x->buckets[i]; n != 0; n = next) { next = n->next; rep_free (n); } } if (x->total_buckets > 0) rep_free (x->buckets); rep_FREE_CELL (x); } static void structure_sweep (void) { rep_struct *x = all_structures; all_structures = 0; while (x != 0) { rep_struct *next = x->next; if (!rep_GC_CELL_MARKEDP (rep_VAL(x))) free_structure (x); else { rep_GC_CLR_CELL (rep_VAL(x)); x->next = all_structures; all_structures = x; } x = next; } } static void structure_print (repv stream, repv arg) { if (rep_STRUCTURE (arg)->name == Qnil) rep_stream_puts (stream, "#", -1, rep_FALSE); else { rep_stream_puts (stream, "#name); rep_stream_putc (stream, '>'); } } /* utilities */ /* Return true iff structure S exports a binding of symbol VAR that it inherits from one of its opened structures */ static rep_bool structure_exports_inherited_p (rep_struct *s, repv var) { if (s->car & rep_STF_EXPORT_ALL) return rep_TRUE; else { repv tem = s->inherited; while (rep_CONSP (tem)) { if (rep_CAR (tem) == var) return rep_TRUE; tem = rep_CDR (tem); } return rep_FALSE; } } /* Scan for an immediate binding of symbol VAR in structure S, or return a null pointer if no such binding */ static inline rep_struct_node * lookup (rep_struct *s, repv var) { /* this is also in OP_REFG in lispmach.c */ rep_struct_node *n; if (s->total_buckets != 0) { for (n = s->buckets[rep_STRUCT_HASH (var, s->total_buckets)]; n != 0; n = n->next) { if (n->symbol == var) return n; } } return 0; } static rep_struct_node * lookup_or_add (rep_struct *s, repv var) { rep_struct_node *n = lookup (s, var); if (n == 0) { if (s->total_buckets == 0) { s->total_buckets = MIN_BUCKETS; s->buckets = rep_alloc (sizeof (rep_struct_node *) * s->total_buckets); memset (s->buckets, 0, sizeof (rep_struct_node *) * s->total_buckets); rep_data_after_gc += sizeof (rep_struct_node *) * s->total_buckets; } if (s->total_bindings > s->total_buckets * MAX_MULTIPLIER) { int new_total = s->total_buckets * 2; rep_struct_node **buckets = rep_alloc (new_total * sizeof (rep_struct_node *)); int i; memset (buckets, 0, new_total * sizeof (rep_struct_node *)); rep_data_after_gc += new_total * sizeof (rep_struct_node *); for (i = 0; i < s->total_buckets; i++) { rep_struct_node *next; for (n = s->buckets[i]; n != 0; n = next) { next = n->next; n->next = buckets[rep_STRUCT_HASH (n->symbol, new_total)]; buckets[rep_STRUCT_HASH (n->symbol, new_total)] = n; } } s->total_buckets = new_total; rep_free (s->buckets); s->buckets = buckets; } n = rep_alloc (sizeof (rep_struct_node)); rep_data_after_gc += sizeof (rep_struct_node); n->symbol = var; n->is_constant = 0; n->is_exported = (s->car & rep_STF_EXPORT_ALL) != 0; n->next = s->buckets[rep_STRUCT_HASH (var, s->total_buckets)]; s->buckets[rep_STRUCT_HASH (var, s->total_buckets)] = n; s->total_bindings++; if (structure_exports_inherited_p (s, var)) { n->is_exported = 1; s->inherited = Fdelq (var, s->inherited); } cache_invalidate_symbol (var); } return n; } static void remove_binding (rep_struct *s, repv var) { if (s->total_buckets != 0) { rep_struct_node **n; for (n = &(s->buckets[rep_STRUCT_HASH (var, s->total_buckets)]); *n != 0; n = &((*n)->next)) { if ((*n)->symbol == var) { rep_struct_node *next = (*n)->next; rep_free (*n); *n = next; cache_invalidate_symbol (var); return; } } } } /* Scan for a binding of symbol VAR under structure S, or return null. This also searches the exports of any structures that S has opened */ static rep_struct_node * lookup_recursively (repv s, repv var) { if (rep_SYMBOLP (s)) s = Fget_structure (s); if (s && rep_STRUCTUREP (s) && !(rep_STRUCTURE (s)->car & rep_STF_EXCLUSION)) { rep_struct_node *n; n = lookup (rep_STRUCTURE (s), var); if (n != 0) return n->is_exported ? n : 0; rep_STRUCTURE (s)->car |= rep_STF_EXCLUSION; if (structure_exports_inherited_p (rep_STRUCTURE (s), var)) n = rep_search_imports (rep_STRUCTURE (s), var); rep_STRUCTURE (s)->car &= ~rep_STF_EXCLUSION; return n; } else return 0; } rep_struct_node * rep_search_imports (rep_struct *s, repv var) { rep_struct_node *n = lookup_cache (s, var); if (n != 0) return n; else { repv imports = s->imports; while (rep_CONSP (imports)) { n = lookup_recursively (rep_CAR (imports), var); if (n != 0) { enter_cache (s, n); return n; } imports = rep_CDR (imports); } return 0; } } /* lisp functions */ DEFUN("get-structure", Fget_structure, Sget_structure, (repv name), rep_Subr1) /* ::doc:rep.structures#get-structure:: get-structure NAME Return the structure called NAME (a symbol), or return `nil' if no such structure. ::end:: */ { rep_struct_node *n; rep_DECLARE1 (name, rep_SYMBOLP); n = lookup (rep_STRUCTURE (rep_structures_structure), name); return n ? n->binding : Qnil; } DEFUN("name-structure", Fname_structure, Sname_structure, (repv structure, repv name), rep_Subr2) /* ::doc:rep.structures#name-structure:: name-structure STRUCTURE NAME Assign the name NAME (a symbol) to structure object STRUCTURE. ::end:: */ { rep_DECLARE1 (structure, rep_STRUCTUREP); if (name != Qnil) { rep_DECLARE2 (name, rep_SYMBOLP); Fstructure_define (rep_structures_structure, name, structure); /* XXX I'm not sure about this..? */ if (rep_STRUCTURE (structure)->name == Qnil) rep_STRUCTURE (structure)->name = name; } else if (rep_STRUCTURE (structure)->name != Qnil) { /* remove the name->structure relation */ Fstructure_define (rep_structures_structure, rep_STRUCTURE (structure)->name, Qnil); } cache_flush (); return name; } /* environment of thunks are modified! */ DEFUN ("make-structure", Fmake_structure, Smake_structure, (repv sig, repv header_thunk, repv body_thunk, repv name), rep_Subr4) /* ::doc:rep.structures#make-structure:: make-structure INTERFACE CONFIG-THUNK BODY-THUNK [NAME] Create and return a new structure. If NAME is a non-nil symbol the structure will take that name. The new structure will be advertised as exporting bindings defined by INTERFACE (currently just a list of symbols). If CONFIG-THUNK is non-nil it is a zero-parameter function to be called to define the configuration of the structure (currently it's opened and accessed structures.) This thunk will be evaluated in the environment of the new structure, but with only the `%meta' (module-configuration) structure opened. If BODY-THUNK is non-nil it is a zero-parameter function to be called to define the values of the bindings exported by the structure. It will be evaluated in the environment of the new structure. Note that the captured state of the closures CONFIG-THUNK and BODY-THUNK may be modified by this function! ::end:: */ { rep_struct *s; repv s_; rep_GC_root gc_s; rep_GC_root gc_body; rep_DECLARE1 (sig, rep_INTERFACEP); if (header_thunk != Qnil) rep_DECLARE2 (header_thunk, rep_FUNARGP); if (body_thunk != Qnil) rep_DECLARE3 (body_thunk, rep_FUNARGP); if (name != Qnil) rep_DECLARE4 (name, rep_SYMBOLP); s = rep_ALLOC_CELL (sizeof (rep_struct)); rep_data_after_gc += sizeof (rep_struct); s->car = rep_structure_type; s->inherited = sig; s->name = name; s->total_buckets = s->total_bindings = 0; s->imports = Qnil; s->accessible = Qnil; s->special_env = Qt; if (rep_structure != rep_NULL) s->apply_bytecode = rep_STRUCTURE (rep_structure)->apply_bytecode; else s->apply_bytecode = 0; s->next = all_structures; all_structures = s; s_ = rep_VAL (s); rep_PUSHGC (gc_s, s_); if (s->name != Qnil) Fname_structure (rep_VAL (s), s->name); rep_PUSHGC (gc_body, body_thunk); if (header_thunk != Qnil) { repv tem; s->imports = Fcons (Q_meta, s->imports); rep_FUNARG (header_thunk)->structure = s_; tem = rep_call_lisp0 (header_thunk); s->imports = Fdelq (Q_meta, s->imports); if (tem == rep_NULL) s = 0; } rep_POPGC; if (s != 0 && body_thunk != Qnil) { repv tem; rep_FUNARG (body_thunk)->structure = s_; tem = rep_call_lisp0 (body_thunk); if (tem == rep_NULL) s = 0; } rep_POPGC; if (s != 0) return rep_VAL (s); else { /* initialization failed. */ s = rep_STRUCTURE (s_); if (s->name != Qnil) Fname_structure (rep_VAL (s), Qnil); return rep_NULL; } } DEFUN ("%structure-ref", F_structure_ref, S_structure_ref, (repv structure, repv var), rep_Subr2) /* ::doc:rep.structures#%structure-ref:: %structure-ref STRUCTURE VAR Return the value of the binding of symbol VAR in structure object STRUCTURE or any inner opened structures. Returns a void value if no such binding. ::end::*/ { rep_struct *s; rep_struct_node *n; rep_DECLARE1 (structure, rep_STRUCTUREP); rep_DECLARE2 (var, rep_SYMBOLP); s = rep_STRUCTURE (structure); /* this is also in OP_REFG in lispmach.c */ n = lookup (s, var); if (n == 0) n = rep_search_imports (s, var); return (n != 0) ? n->binding : rep_void_value; } DEFUN ("structure-bound-p", Fstructure_bound_p, Sstructure_bound_p, (repv structure, repv var), rep_Subr2) /* ::doc:rep.structures#structure-bound-p:: structure-bound-p STRUCTURE VAR Return `t' if symbol VAR has a non-void binding in STRUCTURE. ::end:: */ { repv tem = F_structure_ref (structure, var); if (tem != rep_NULL) tem = rep_VOIDP (tem) ? Qnil : Qt; return tem; } DEFUN ("structure-set", Fstructure_set, Sstructure_set, (repv structure, repv var, repv value), rep_Subr3) /* ::doc:rep.structures#structure-set:: structure-set STRUCTURE VAR VALUE Set the value of the binding of symbol VAR in structure object STRUCTURE to VALUE. If no such binding exists, an error is signalled. ::end:: */ { rep_struct *s; rep_struct_node *n; rep_DECLARE1 (structure, rep_STRUCTUREP); rep_DECLARE2 (var, rep_SYMBOLP); s = rep_STRUCTURE (structure); if (!rep_VOIDP (value)) { if (!(s->car & rep_STF_SET_BINDS)) n = lookup (s, var); else n = lookup_or_add (s, var); if (n != 0) { if (!n->is_constant) { n->binding = value; return value; } else return Fsignal (Qsetting_constant, rep_LIST_1 (var)); } else return Fsignal(Qvoid_value, rep_LIST_1(var)); } else { remove_binding (s, var); return Qnil; } } DEFUN ("structure-define", Fstructure_define, Sstructure_define, (repv structure, repv var, repv value), rep_Subr3) /* ::doc:rep.structures#structure-define:: structure-define STRUCTURE VAR VALUE Set the value of the binding of symbol VAR in structure object STRUCTURE to VALUE. If no such binding exists, one is created. ::end:: */ { rep_struct *s; rep_struct_node *n; rep_DECLARE1 (structure, rep_STRUCTUREP); rep_DECLARE2 (var, rep_SYMBOLP); s = rep_STRUCTURE (structure); if (!rep_VOIDP (value)) { n = lookup_or_add (s, var); if (!n->is_constant) { n->binding = value; return value; } else return Fsignal(Qsetting_constant, rep_LIST_1(var)); } else { remove_binding (s, var); return Qnil; } } DEFUN ("external-structure-ref", Fexternal_structure_ref, Sexternal_structure_ref, (repv name, repv var), rep_Subr2) /* ::doc:rep.structures#external-structure-ref:: external-structure-ref STRUCT-NAME VAR Return the value of the binding of symbol VAR within the structure called STRUCT-NAME. This structure must have previously been marked as accessible by the current structure (by using the `access' module configuration directive). Signals an error if no such binding exists. ::end:: */ { repv tem, val = rep_void_value; rep_DECLARE1 (name, rep_SYMBOLP); rep_DECLARE2 (var, rep_SYMBOLP); /* XXX caching here? */ tem = Fmemq (name, rep_STRUCTURE (rep_structure)->accessible); if (tem == Qnil) tem = Fmemq (name, rep_STRUCTURE (rep_structure)->imports); if (tem && tem != Qnil) { rep_struct_node *n = lookup_recursively (name, var); if (n != 0) val = n->binding; } if (!rep_VOIDP (val)) return val; else return Fsignal (Qvoid_value, rep_LIST_1 (var)); } DEFUN ("structure-name", Fstructure_name, Sstructure_name, (repv structure), rep_Subr1) /* ::doc:rep.structures#structure-name:: structure-name STRUCTURE Returns the name of structure object STRUCTURE. ::end:: */ { rep_DECLARE1 (structure, rep_STRUCTUREP); return rep_STRUCTURE (structure)->name; } DEFUN ("structure-interface", Fstructure_interface, Sstructure_interface, (repv structure), rep_Subr1) /* ::doc:rep.structures#structure-interface:: structure-interface STRUCTURE Returns the interface of structure object STRUCTURE. ::end:: */ { rep_struct *s; repv list; int i; rep_DECLARE1 (structure, rep_STRUCTUREP); s = rep_STRUCTURE (structure); list = s->inherited; for (i = 0; i < s->total_buckets; i++) { rep_struct_node *n; for (n = s->buckets[i]; n != 0; n = n->next) { if (n->is_exported) list = Fcons (n->symbol, list); } } return list; } DEFUN ("structure-exports-p", Fstructure_exports_p, Sstructure_exports_p, (repv structure, repv var), rep_Subr2) /* ::doc:rep.structures#structure-exports-p:: structure-exports-p STRUCTURE VAR Returns true if structure object STRUCTURE exports a binding of symbol VAR. ::end:: */ { rep_struct_node *n; rep_DECLARE1 (structure, rep_STRUCTUREP); rep_DECLARE2 (var, rep_SYMBOLP); n = lookup (rep_STRUCTURE (structure), var); if (n != 0) return n->is_exported ? Qlocal : Qnil; else return (structure_exports_inherited_p (rep_STRUCTURE (structure), var) ? Qexternal : Qnil); } DEFUN ("structure-imports", Fstructure_imports, Sstructure_imports, (repv structure), rep_Subr1) /* ::doc:rep.structures#structure-imports:: structure-imports STRUCTURE Returns the list of structure names opened by structure object STRUCTURE. ::end:: */ { rep_DECLARE1 (structure, rep_STRUCTUREP); return rep_STRUCTURE (structure)->imports; } DEFUN ("structure-accessible", Fstructure_accessible, Sstructure_accessible, (repv structure), rep_Subr1) /* ::doc:rep.structures#structure-accessible:: structure-accessible STRUCTURE Returns the list of structure names accessed by structure object STRUCTURE. ::end:: */ { rep_DECLARE1 (structure, rep_STRUCTUREP); return rep_STRUCTURE (structure)->accessible; } DEFUN ("set-interface", Fset_interface, Sset_interface, (repv structure, repv sig), rep_Subr2) /* ::doc:rep.structures#set-interface:: set-interface STRUCTURE INTERFACE Set the interface of structure object STRUCTURE to INTERFACE. ::end:: */ { rep_struct *s; int i; rep_DECLARE1 (structure, rep_STRUCTUREP); rep_DECLARE2 (sig, rep_INTERFACEP); s = rep_STRUCTURE (structure); s->inherited = Fcopy_sequence (sig); s->car &= ~rep_STF_EXPORT_ALL; for (i = 0; i < s->total_buckets; i++) { rep_struct_node *n; for (n = s->buckets[i]; n != 0; n = n->next) { if (structure_exports_inherited_p (s, n->symbol)) { n->is_exported = 1; s->inherited = Fdelq (n->symbol, s->inherited); } else n->is_exported = 0; } } cache_flush (); return Qt; } DEFUN("structure-file", Fstructure_file, Sstructure_file, (repv name), rep_Subr1) /* ::doc:rep.structures#structure-file:: structure-file NAME Return a string that would be used to locate a structure called NAME (a symbol). ::end:: */ { if (rep_SYMBOLP (name)) name = rep_SYM (name)->name; rep_DECLARE1 (name, rep_STRINGP); return rep_structure_file (name); } DEFUN("intern-structure", Fintern_structure, Sintern_structure, (repv name), rep_Subr1) /* ::doc:rep.structures#intern-structure:: intern-structure STRUCT-NAME Return the structure called STRUCT-NAME. If no such structure exists, attempt to load it. ::end:: */ { repv tem; rep_DECLARE1 (name, rep_SYMBOLP); tem = Fget_structure (name); if (tem == Qnil) { repv old = rep_structure; rep_GC_root gc_name, gc_old; /* We need to load the file from within a well-defined structure, not just the current one. Look for the value of the *root-structure* variable first, then fall back to the default structure */ rep_structure = rep_default_structure; tem = Fsymbol_value (Q_user_structure_, Qt); if (!rep_VOIDP (tem)) { tem = Fget_structure (tem); if (rep_STRUCTUREP (tem)) rep_structure = tem; } rep_PUSHGC (gc_old, old); rep_PUSHGC (gc_name, name); tem = Fload (Fstructure_file (name), Qnil, Qnil, Qnil, Qnil); rep_POPGC; rep_POPGC; rep_structure = old; if (tem != rep_NULL && !rep_STRUCTUREP (tem)) tem = Qnil; } return tem; } DEFSTRING (no_struct, "No such structure"); DEFUN ("open-structures", Fopen_structures, Sopen_structures, (repv args), rep_Subr1) /* ::doc:rep.structures#open-structures:: open-structures STRUCT-NAMES Mark that the current structures has opened the list of structures named in the list STRUCT-NAMES. ::end:: */ { rep_struct *dst = rep_STRUCTURE (rep_structure); rep_GC_root gc_args; repv ret = Qnil; rep_DECLARE1 (args, rep_LISTP); rep_PUSHGC (gc_args, args); while (rep_CONSP (args)) { repv tem = Fmemq (rep_CAR (args), dst->imports); if (tem == Qnil) { repv s = rep_CAR (args); if (rep_SYMBOLP (s)) s = Fintern_structure (s); if (!s || !rep_STRUCTUREP (s)) { ret = Fsignal (Qerror, rep_list_2 (rep_VAL (&no_struct), rep_CAR (args))); break; } dst->imports = Fcons (rep_CAR (args), dst->imports); } args = rep_CDR (args); } rep_POPGC; cache_flush (); return ret; } DEFUN ("access-structures", Faccess_structures, Saccess_structures, (repv args), rep_Subr1) /* ::doc:rep.structures#access-structures:: access-structures STRUCT-NAMES Mark that the current structures may access the list of structures named in the list STRUCT-NAMES. ::end:: */ { rep_struct *dst = rep_STRUCTURE (rep_structure); rep_GC_root gc_args; repv ret = Qnil; rep_DECLARE1 (args, rep_LISTP); rep_PUSHGC (gc_args, args); while (rep_CONSP (args)) { repv tem = Fmemq (rep_CAR (args), dst->accessible); if (tem == Qnil) { repv s = Fintern_structure (rep_CAR (args)); if (s == rep_NULL || !rep_STRUCTUREP (s)) { ret = Fsignal (Qerror, rep_list_2 (rep_VAL (&no_struct), rep_CAR (args))); break; } dst->accessible = Fcons (rep_CAR (args), dst->accessible); } args = rep_CDR (args); } rep_POPGC; cache_flush (); return ret; } DEFUN ("current-structure", Fcurrent_structure, Scurrent_structure, (void), rep_Subr0) /* ::doc:rep.structures#current-structure:: current-structure Return the current structure object. ::end:: */ { return rep_structure; } DEFUN ("structurep", Fstructurep, Sstructurep, (repv arg), rep_Subr1) /* ::doc:rep.structures#structurep:: structurep ARG Return `t' if ARG is a structure object. ::end:: */ { return rep_STRUCTUREP (arg) ? Qt : Qnil; } DEFUN ("eval", Freal_eval, Seval_real, (repv form, repv structure, repv env), rep_Subr3) /* ::doc:rep.structures#eval:: eval FORM [STRUCTURE] Return the result of evaluating FORM inside structure object STRUCTURE (with a null lexical environment). ::end:: */ { repv result; repv old = rep_structure, old_env = rep_env; rep_GC_root gc_old, gc_old_env; if (structure == Qnil) structure = rep_structure; rep_DECLARE2 (structure, rep_STRUCTUREP); rep_PUSHGC (gc_old, old); rep_PUSHGC (gc_old_env, old_env); rep_structure = structure; rep_env = env; result = Feval (form); rep_structure = old; rep_env = old_env; rep_POPGC; rep_POPGC; return result; } DEFUN ("structure-walk", Fstructure_walk, Sstructure_walk, (repv fun, repv structure), rep_Subr2) /* ::doc:rep.structures#structure-walk:: structure-walk FUNCTION STRUCTURE Call FUNCTION for each binding in structure object STRUCTURE. The function is called with two arguments, the variable and the binding's value. ::end:: */ { rep_GC_root gc_fun, gc_structure; repv ret = Qnil; rep_struct *s; int i; rep_DECLARE2 (structure, rep_STRUCTUREP); s = rep_STRUCTURE (structure); rep_PUSHGC (gc_fun, fun); rep_PUSHGC (gc_structure, structure); for (i = 0; i < s->total_buckets; i++) { rep_struct_node *n; for (n = s->buckets[i]; n != 0; n = n->next) { if (!rep_VOIDP (n->binding)) { ret = rep_call_lisp2 (fun, n->symbol, n->binding); if (!ret) goto out; } } } out: rep_POPGC; rep_POPGC; return ret; } #ifdef DEBUG DEFUN ("structure-stats", Fstructure_stats, Sstructure_stats, (repv structure), rep_Subr1) { rep_struct *s; int i, empties = 0; rep_DECLARE1 (structure, rep_STRUCTUREP); s = rep_STRUCTURE (structure); for (i = 0; i < s->total_buckets; i++) { if (s->buckets[i] == 0) empties++; } printf ("%d buckets, %d of which are empty,\n%g bindings per non-empty bucket\n", s->total_buckets, empties, (double) s->total_bindings / (s->total_buckets - empties)); return Qt; } #endif DEFUN ("make-binding-immutable", Fmake_binding_immutable, Smake_binding_immutable, (repv var), rep_Subr1) /* ::doc:rep.structures#make-binding-immutable:: make-binding-immutable VAR Flag that the binding of symbol VAR in the current structure may not be changed. ::end:: */ { rep_struct_node *n; rep_DECLARE1(var, rep_SYMBOLP); n = lookup (rep_STRUCTURE (rep_structure), var); if (n != 0) { n->is_constant = 1; return var; } else return Fsignal (Qvoid_value, rep_LIST_1 (var)); } DEFUN ("binding-immutable-p", Fbinding_immutable_p, Sbinding_immutable_p, (repv var, repv structure), rep_Subr2) /* ::doc:rep.structures#binding-immutable-p:: binding-immutable-p VAR [STRUCTURE] Return `t' if the binding of symbol VAR in the STRUCTURE has been made constant. ::end:: */ { rep_struct_node *n; rep_DECLARE1(var, rep_SYMBOLP); if (structure != Qnil) rep_DECLARE2(structure, rep_STRUCTUREP); else structure = rep_structure; n = lookup (rep_STRUCTURE (structure), var); if (n == 0) n = rep_search_imports (rep_STRUCTURE (structure), var); return (n != 0 && n->is_constant) ? Qt : Qnil; } repv Fexport_binding (repv var) { rep_struct *s; rep_struct_node *n; rep_DECLARE1 (var, rep_SYMBOLP); s = rep_STRUCTURE (rep_structure); n = lookup (s, var); if (n != 0) { if (!n->is_exported) { n->is_exported = 1; cache_invalidate_symbol (var); } } else if (!structure_exports_inherited_p (s, var)) { s->inherited = Fcons (var, s->inherited); cache_invalidate_symbol (var); } return Qnil; } DEFUN ("export-bindings", Fexport_bindings, Sexport_bindings, (repv vars), rep_Subr1) { rep_DECLARE1 (vars, rep_LISTP); while (rep_CONSP (vars)) { if (Fexport_binding (rep_CAR (vars)) == rep_NULL) return rep_NULL; vars = rep_CDR (vars); } return Qnil; } /* features */ DEFUN("featurep", Ffeaturep, Sfeaturep, (repv feature), rep_Subr1) /* ::doc:rep.structures#featurep:: featurep FEATURE Return non-nil if feature FEATURE has already been loaded by the current structure. ::end:: */ { repv value; rep_DECLARE1 (feature, rep_SYMBOLP); value = F_structure_ref (rep_structure, Qfeatures); return rep_VOIDP (value) ? Qnil : Fmemq (feature, value); } DEFUN("provide", Fprovide, Sprovide, (repv feature), rep_Subr1) /* ::doc:rep.structures#provide:: provide FEATURE Show that the feature FEATURE (a symbol) has been loaded in the current structure. ::end:: */ { repv value, tem; rep_DECLARE1 (feature, rep_SYMBOLP); value = F_structure_ref (rep_structure, Qfeatures); if (rep_VOIDP (value)) value = Qnil; tem = Fmemq (feature, value); if (tem && tem == Qnil) value = Fcons (feature, value); Fstructure_define (rep_structure, Qfeatures, value); return feature; } DEFUN_INT("require", Frequire, Srequire, (repv feature), rep_Subr1, "SFeature to load:") /* ::doc:rep.structures#require:: require FEATURE If FEATURE (a symbol) has not already been loaded, load it. The file loaded is either FILE (if given), or the print name of FEATURE. ::end:: */ { repv tem; rep_struct *dst = rep_STRUCTURE (rep_structure); rep_DECLARE1 (feature, rep_SYMBOLP); if (Ffeaturep (feature) != Qnil) return feature; /* Need to do all this locally, since the file providing the feature/module has to be loaded into the _current_ structure (in case it contains bare code). %intern-structure OTOH always loads into *root-structure*, since it's often called with only the %meta structure imported */ tem = Fmemq (feature, dst->imports); if (tem == Qnil) { tem = Fget_structure (feature); if (!rep_STRUCTUREP (tem)) { rep_GC_root gc_feature; rep_PUSHGC (gc_feature, feature); tem = Fload (Fstructure_file (feature), Qnil, Qnil, Qnil, Qnil); rep_POPGC; if (tem == rep_NULL) return rep_NULL; if (rep_STRUCTUREP (tem)) Fname_structure (tem, feature); } if (rep_STRUCTUREP (tem)) { dst->imports = Fcons (feature, dst->imports); Fprovide (feature); cache_flush (); } } return Qt; } /* C interface for structure building */ repv rep_push_structure_name (repv name) { if (rep_STRINGP (name)) name = Fintern (name, Qnil); if (rep_SYMBOLP (name)) { repv s = Fget_structure (name); repv old = rep_structure; if (s == Qnil) s = Fmake_structure (Qnil, Qnil, Qnil, name); rep_structure = s; return old; } else return Qnil; } repv rep_push_structure (const char *name) { return rep_push_structure_name (rep_string_dup (name)); } repv rep_pop_structure (repv old) { if (rep_STRUCTUREP (old)) { repv new = rep_structure; rep_structure = old; return new; } else return Qnil; } void rep_alias_structure (const char *name) { repv sym = Fintern (rep_string_dup (name), Qnil); Fname_structure (rep_structure, sym); } repv rep_bootstrap_structure (const char *s) { repv name = rep_string_dup (s); repv tem = rep_push_structure_name (name); repv ret; /* Allow the bootstrap code to manipulate modules.. */ { rep_struct *tem = rep_STRUCTURE (rep_structure); if (tem->name != Qrep_structures) tem->imports = Fcons (Qrep_structures, tem->imports); if (tem->name != Qrep_lang_interpreter) tem->imports = Fcons (Qrep_lang_interpreter, tem->imports); tem->imports = Fcons (Qrep_vm_interpreter, tem->imports); } ret = Fload (Fstructure_file (name), Qnil, Qnil, Qnil, Qnil); rep_pop_structure (tem); return ret; } repv rep_add_subr(rep_xsubr *subr, rep_bool export) { repv sym = Fintern (subr->name, Qnil); if (sym) { rep_struct *s = rep_STRUCTURE (rep_structure); rep_struct_node *n = lookup_or_add (s, sym); n->binding = rep_VAL (subr); n->is_exported = export; } return sym; } DEFUN("structure-exports-all", Fstructure_exports_all, Sstructure_exports_all, (repv s, repv status), rep_Subr2) { rep_DECLARE1 (s, rep_STRUCTUREP); if (status) rep_STRUCTURE (s)->car |= rep_STF_EXPORT_ALL; else rep_STRUCTURE (s)->car &= ~rep_STF_EXPORT_ALL; return s; } DEFUN("structure-set-binds", Fstructure_set_binds, Sstructure_set_binds, (repv s, repv status), rep_Subr2) { rep_DECLARE1 (s, rep_STRUCTUREP); if (status) rep_STRUCTURE (s)->car |= rep_STF_SET_BINDS; else rep_STRUCTURE (s)->car &= ~rep_STF_SET_BINDS; return s; } void rep_structure_exports_all (repv s, rep_bool status) { Fstructure_exports_all (s, status ? Qt : Qnil); } void rep_structure_set_binds (repv s, rep_bool status) { Fstructure_set_binds (s, status ? Qt : Qnil); } static repv invalid_apply_bytecode (repv subr, int nargs, repv *args) { return Fsignal (Qinvalid_function, rep_LIST_1 (subr)); } DEFUN("structure-install-vm", Fstructure_install_vm, Sstructure_install_vm, (repv structure, repv vm), rep_Subr2) { rep_struct *s; rep_DECLARE1 (structure, rep_STRUCTUREP); s = rep_STRUCTURE (structure); if (vm == Qnil) { s->apply_bytecode = invalid_apply_bytecode; return Qnil; } else { rep_DECLARE (2, vm, Ffunctionp (vm) != Qnil); return rep_call_lisp1 (vm, structure); } } /* This is a horrible kludge :-( The problem is that we are used to doing (setq foo-special 42) in rc files, even though foo-special is yet to be marked special. So the binding gets made in the current structure, and is then ignored when the variable finally gets defvar'd. So my solution is to mark a structure as the `user' structure (by storing its name in the variable *user-structure*), then check this structure for bindings when defvar'ing variables This function may not gc */ repv rep_get_initial_special_value (repv sym) { repv user = F_structure_ref (rep_specials_structure, Q_user_structure_); if (!rep_VOIDP (user)) { repv s = Fget_structure (user); if (rep_STRUCTUREP (s)) { repv old = F_structure_ref (s, sym); if (!rep_VOIDP (old)) { Fstructure_define (s, sym, rep_void_value); cache_invalidate_symbol (sym); return old; } } } return rep_NULL; } repv rep_documentation_property (repv structure) { repv name = rep_STRUCTURE (structure)->name; char *buf; if (!rep_SYMBOLP (name)) return Qnil; name = rep_SYM (name)->name; buf = alloca (rep_STRING_LEN (name) + 32); sprintf (buf, "documentation#%s", rep_STR (name)); return Fintern (rep_string_dup (buf), Qnil); } /* init */ void rep_pre_structures_init (void) { rep_structure_type = rep_register_new_type ("structure", 0, structure_print, structure_print, structure_sweep, structure_mark, 0, 0, 0, 0, 0, 0, 0); rep_default_structure = Fmake_structure (Qnil, Qnil, Qnil, Qnil); rep_specials_structure = Fmake_structure (Qnil, Qnil, Qnil, Qnil); rep_structures_structure = Fmake_structure (Qnil, Qnil, Qnil, Qnil); } void rep_structures_init (void) { repv tem = rep_push_structure ("rep.structures"); rep_ADD_SUBR (Smake_structure); rep_ADD_SUBR (S_structure_ref); rep_ADD_SUBR (Sstructure_bound_p); rep_ADD_SUBR (Sstructure_set); rep_ADD_SUBR (Sstructure_define); rep_ADD_SUBR (Sexternal_structure_ref); rep_ADD_SUBR (Sstructure_name); rep_ADD_SUBR (Sstructure_interface); rep_ADD_SUBR (Sstructure_exports_p); rep_ADD_SUBR (Sstructure_imports); rep_ADD_SUBR (Sstructure_accessible); rep_ADD_SUBR (Sset_interface); rep_ADD_SUBR (Sget_structure); rep_ADD_SUBR (Sname_structure); rep_ADD_SUBR (Sstructure_file); rep_ADD_SUBR (Sintern_structure); rep_ADD_SUBR (Sopen_structures); rep_ADD_SUBR (Saccess_structures); rep_ADD_SUBR (Scurrent_structure); rep_ADD_SUBR (Sstructurep); rep_ADD_SUBR (Seval_real); rep_ADD_SUBR (Sstructure_walk); #ifdef DEBUG rep_ADD_SUBR (Sstructure_stats); #endif rep_ADD_SUBR (Smake_binding_immutable); rep_ADD_SUBR (Sbinding_immutable_p); rep_ADD_SUBR (Sexport_bindings); rep_ADD_SUBR (Sstructure_exports_all); rep_ADD_SUBR (Sstructure_set_binds); rep_ADD_SUBR (Sstructure_install_vm); rep_pop_structure (tem); tem = rep_push_structure ("rep.module-system"); rep_ADD_SUBR (Sfeaturep); rep_ADD_SUBR (Sprovide); rep_ADD_SUBR_INT (Srequire); rep_pop_structure (tem); rep_INTERN (features); rep_INTERN (_structures); rep_INTERN (_meta); rep_INTERN (rep); rep_INTERN (_specials); rep_INTERN_SPECIAL (_user_structure_); rep_INTERN (rep_structures); rep_INTERN (rep_lang_interpreter); rep_INTERN (rep_vm_interpreter); rep_INTERN (external); rep_INTERN (local); rep_mark_static (&rep_structure); rep_mark_static (&rep_default_structure); rep_mark_static (&rep_specials_structure); rep_mark_static (&rep_structures_structure); Fname_structure (rep_default_structure, Qrep); Fname_structure (rep_specials_structure, Q_specials); Fname_structure (rep_structures_structure, Q_structures); #ifdef DEBUG atexit (print_cache_stats); #endif } librep-0.90.2/src/streams.c0000644000175200017520000007210711245011153014476 0ustar chrischris/* streams.c -- Lisp stream handling Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* These are the Lisp objects which are classed as streams: FILE: [rw] MARK: [rw] advance pos attribute of mark afterwards BUFFER: [rw] from cursor pos (NUMBER . STRING): [r] from the NUMBER'th char of STRING (STRING . ACTUAL-LENGTH): [w] to after INDEX (BUFFER . POS): [rw] from BUFFER, POS is advanced (BUFFER . t): [w] end of BUFFER FUNCTION: [rw] call FUNCTION, when reading FUNCTION is expected to return the next character, when writing it is called with one arg, either character or string. PROCESS: [w] write to the stdin of the PROCESS if it's running t: [w] display in status line Note that when using any of the three BUFFER stream types, the buffer's restriction is respected. */ #define _GNU_SOURCE /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include #include #include #ifdef NEED_MEMORY_H # include #endif DEFSYM(format_hooks_alist, "format-hooks-alist"); /* ::doc:format-hooks-alist:: Alist of (CHAR . FUNCTION) defining extra format conversions for the format function. FUNCTION is called as (FUNCTION repv), and should return the string to be inserted. ::end:: */ int rep_stream_getc(repv stream) { int c = EOF; if(rep_NILP(stream) && !(stream = Fsymbol_value(Qstandard_input, Qnil))) return c; switch(rep_TYPE(stream)) { repv res; rep_type *t; case rep_Cons: res = rep_CAR(stream); if(rep_INTP(res) && rep_STRINGP(rep_CDR(stream))) { if (rep_INT(res) < rep_STRING_LEN(rep_CDR(stream))) { c = (int) ((unsigned char *)rep_STR(rep_CDR(stream)))[rep_INT(res)]; rep_CAR(stream) = rep_MAKE_INT(rep_INT(res) + 1); } else c = EOF; break; } else if(res == Qlambda) goto function; else { t = rep_get_data_type(rep_TYPE(rep_CAR(stream))); if (t->getc != 0) c = (t->getc)(stream); else Fsignal(Qinvalid_stream, rep_LIST_1(stream)); } break; case rep_Funarg: function: if((res = rep_call_lisp0(stream)) && rep_INTP(res)) c = rep_INT(res); break; default: if (rep_FILEP(stream)) { if(rep_NILP(rep_FILE(stream)->name)) c = EOF; else if(rep_LOCAL_FILE_P(stream)) c = getc(rep_FILE(stream)->file.fh); else c = rep_stream_getc (rep_FILE(stream)->file.stream); if (c == '\n') rep_FILE (stream)->line_number++; break; } t = rep_get_data_type(rep_TYPE(stream)); if (t->getc != 0) c = (t->getc)(stream); else Fsignal(Qinvalid_stream, rep_LIST_1(stream)); } return c; } /* Puts back one character, it will be read next call to streamgetc on this stream. Note that some types of stream don't actually use c, they just rewind pointers. Never call this unless you *have* *successfully* read from the stream previously. (few checks are performed here, I assume they were made in streamgetc()). */ int rep_stream_ungetc(repv stream, int c) { int rc = rep_FALSE; if(rep_NILP(stream) && !(stream = Fsymbol_value(Qstandard_input, Qnil))) return(rc); top: switch(rep_TYPE(stream)) { repv tmp; rep_type *t; case rep_Cons: tmp = rep_CAR(stream); if(rep_INTP(tmp) && rep_STRINGP(rep_CDR(stream))) { rep_CAR(stream) = rep_MAKE_INT(rep_INT(tmp) - 1); rc = rep_TRUE; break; } else if(tmp == Qlambda) goto function; else { t = rep_get_data_type(rep_TYPE(tmp)); if (t->ungetc != 0) (t->ungetc)(stream, c); else Fsignal(Qinvalid_stream, rep_LIST_1(stream)); } break; case rep_Funarg: function: tmp = rep_MAKE_INT(c); if((tmp = rep_call_lisp1(stream, tmp)) && !rep_NILP(tmp)) rc = rep_TRUE; break; default: if (rep_FILEP(stream)) { if (c == '\n') rep_FILE (stream)->line_number--; if(rep_LOCAL_FILE_P(stream)) c = ungetc(c, rep_FILE(stream)->file.fh); else { stream = rep_FILE(stream)->file.stream; goto top; } break; } t = rep_get_data_type(rep_TYPE(stream)); if (t->ungetc != 0) (t->ungetc)(stream, c); } return(rc); } int rep_stream_putc(repv stream, int c) { int rc = -1; if (stream == Qnil && !(stream = Fsymbol_value (Qstandard_output, Qnil))) goto bottom; top: switch (rep_TYPE (stream)) { repv args, res, new; int len; char tmps[2]; rep_type *t; case rep_Cons: args = rep_CAR (stream); if (rep_STRINGP (args) && rep_STRING_WRITABLE_P(args) && rep_INTP (rep_CDR (stream))) { int actuallen = rep_INT (rep_CDR (stream)); len = rep_STRING_LEN (args); if (len + 1 >= actuallen) { int newlen = actuallen < 16 ? 32 : actuallen * 2; new = rep_make_string (newlen + 1); if (new == rep_NULL) break; memcpy (rep_STR (new), rep_STR (args), len); rep_CAR (stream) = new; rep_CDR(stream) = rep_MAKE_INT (newlen); args = new; } ((unsigned char *)rep_STR (args))[len] = (unsigned char) c; rep_STR (args)[len+1] = 0; rep_set_string_len (args, len + 1); rc = 1; break; } else if (args == Qlambda) goto function; else { t = rep_get_data_type (rep_TYPE (rep_CAR (stream))); if (t->putc != 0) rc = (t->putc) (stream, c); else Fsignal (Qinvalid_stream, rep_LIST_1 (stream)); } break; case rep_Symbol: if (stream == Qt) { tmps[0] = (char) c; tmps[1] = 0; if (rep_message_fun != 0) (*rep_message_fun) (rep_append_message, tmps, 1); rc = 1; } break; case rep_Funarg: function: res = rep_call_lisp1 (stream, rep_MAKE_INT (c)); if(res != rep_NULL) rc = 1; break; default: if (rep_FILEP (stream)) { if (rep_NILP (rep_FILE (stream)->name)) return rep_unbound_file_error (stream); else if (rep_LOCAL_FILE_P (stream)) { if (putc (c, rep_FILE(stream)->file.fh) != EOF) rc = 1; } else { stream = rep_FILE (stream)->file.stream; goto top; } } else { t = rep_get_data_type (rep_TYPE (stream)); if (t->putc != 0) rc = (t->putc) (stream, c); else Fsignal (Qinvalid_stream, rep_LIST_1 (stream)); } } bottom: if (rc != 1) { if (!rep_FILEP (stream) || (rep_FILE (stream)->car & rep_LFF_SILENT_ERRORS) == 0) { Fsignal (Qend_of_stream, rep_LIST_1 (stream)); } return 0; } else return 1; } int rep_stream_puts(repv stream, void *data, int bufLen, rep_bool isValString) { char *buf; int rc = -1; if(stream == Qnil && !(stream = Fsymbol_value (Qstandard_output, Qnil))) goto bottom; buf = isValString ? rep_STR (data) : data; if (bufLen == -1) bufLen = isValString ? rep_STRING_LEN (rep_VAL (data)) : strlen (buf); top: switch (rep_TYPE (stream)) { repv args, res, new; int len, newlen; rep_type *t; case rep_Cons: args = rep_CAR (stream); if (rep_STRINGP (args) && rep_STRING_WRITABLE_P (args) && rep_INTP (rep_CDR (stream))) { int actuallen = rep_INT (rep_CDR (stream)); len = rep_STRING_LEN (args); newlen = len + bufLen + 1; if (actuallen <= newlen) { int tmp = actuallen < 16 ? 32 : actuallen * 2; if (tmp > newlen) newlen = tmp; new = rep_make_string (newlen + 1); if (new == rep_NULL) break; memcpy (rep_STR (new), rep_STR (args), len); rep_CAR (stream) = new; rep_CDR (stream) = rep_MAKE_INT (newlen); args = new; } memcpy (rep_STR (args) + len, buf, bufLen); rep_STR (args)[len + bufLen] = 0; rep_set_string_len (args, len + bufLen); rc = bufLen; break; } else if (args == Qlambda) goto function; else { t = rep_get_data_type (rep_TYPE (rep_CAR (stream))); if (t->puts != 0) rc = (t->puts) (stream, data, bufLen, isValString); else Fsignal (Qinvalid_stream, rep_LIST_1(stream)); } break; case rep_Symbol: if (stream == Qt) { if (rep_message_fun != 0) (*rep_message_fun) (rep_append_message, buf, bufLen); rc = bufLen; } break; case rep_Funarg: function: if (isValString) args = rep_VAL (data); else args = rep_string_dupn (buf, bufLen); res = rep_call_lisp1(stream, args); if (res != rep_NULL) { /* Output filters don't bother to return anything sane, so lets just assume they always handle everything.. I should really spec these things fully.. */ rc = bufLen; } break; default: if (rep_FILEP(stream)) { if (rep_NILP (rep_FILE (stream)->name)) return rep_unbound_file_error (stream); else if (rep_LOCAL_FILE_P (stream)) rc = fwrite (buf, 1, bufLen, rep_FILE (stream)->file.fh); else { stream = rep_FILE (stream)->file.stream; goto top; } break; } t = rep_get_data_type (rep_TYPE(stream)); if (t->puts != 0) rc = (t->puts) (stream, data, bufLen, isValString); else Fsignal (Qinvalid_stream, rep_LIST_1 (stream)); } bottom: if (rc != bufLen) { if (!rep_FILEP (stream) || (rep_FILE (stream)->car & rep_LFF_SILENT_ERRORS) == 0) { Fsignal (Qend_of_stream, rep_LIST_1 (stream)); } return 0; } else return bufLen; } /* Read an escape sequence from STREAM. C_P should contain the first character of the escape *not* the escape character. Supported sequences are, n newline r carriage return f form feed t horizontal tab v vertical tab a bell ^C control code of C 012 octal character code x12 hex character code Otherwise the character is returned as-is. */ int rep_stream_read_esc (repv stream, int *c_p) { char c; switch (*c_p) { case 'n': c = '\n'; break; case 'r': c = '\r'; break; case 'f': c = '\f'; break; case 't': c = '\t'; break; case 'v': c = '\v'; break; case 'a': c = '\a'; break; case '^': c = toupper (rep_stream_getc (stream)) ^ 0x40; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': c = *c_p - '0'; *c_p = rep_stream_getc (stream); if ((*c_p >= '0') && (*c_p <= '7')) { c = (c * 8) + (*c_p - '0'); *c_p = rep_stream_getc (stream); if ((*c_p >= '0') && (*c_p <= '7')) { c = (c * 8) + (*c_p - '0'); break; } else return c; } else return c; case 'x': c = 0; while (1) { *c_p = rep_stream_getc (stream); if (!isxdigit (*c_p)) return c; if ((*c_p >= '0') && (*c_p <= '9')) c = (c * 16) + (*c_p - '0'); else c = (c * 16) + (toupper (*c_p) - 'A') + 10; } default: c = *c_p; } *c_p = rep_stream_getc (stream); return(c); } DEFUN("write", Fwrite, Swrite, (repv stream, repv data, repv len), rep_Subr3) /* ::doc:rep.io.streams#write:: write STREAM DATA [LENGTH] Writes DATA, which can either be a string or a character, to the stream STREAM, returning the number of characters actually written. If DATA is a string LENGTH can define how many characters to write. ::end:: */ { int actual; switch (rep_TYPE (data)) { rep_bool vstring; void *arg; case rep_Int: actual = rep_stream_putc (stream, rep_INT(data)); break; case rep_String: if (rep_INTP (len)) { actual = rep_INT (len); if (actual > rep_STRING_LEN (data)) return rep_signal_arg_error(len, 3); if (actual == rep_STRING_LEN (data)) { arg = rep_PTR (data); vstring = rep_TRUE; } else { arg = rep_STR (data); vstring = rep_FALSE; } } else { actual = rep_STRING_LEN (data); vstring = rep_TRUE; arg = rep_PTR (data); } actual = rep_stream_puts (stream, arg, actual, vstring); break; default: return rep_signal_arg_error (data, 2); } return !rep_INTERRUPTP ? rep_MAKE_INT (actual) : rep_NULL; } DEFUN("read-char", Fread_char, Sread_char, (repv stream), rep_Subr1) /* ::doc:rep.io.streams#read-char:: read-char STREAM Reads the next character from the input-stream STREAM, if no more characters are available returns nil. ::end:: */ { int rc = rep_stream_getc (stream); if(rc != EOF) return rep_MAKE_INT (rc); else return Qnil; } DEFUN("peek-char", Fpeek_char, Speek_char, (repv stream), rep_Subr1) /* ::doc:rep.io.streams#peek-char:: peek-char STREAM Returns the next character from the input-stream STREAM, *without* removing that character from the head of the stream. If no more characters are available returns nil. ::end:: */ { int c = rep_stream_getc (stream); if (c != EOF) { rep_stream_ungetc (stream, c); return rep_MAKE_INT (c); } else return Qnil; } DEFUN("read-chars", Fread_chars, Sread_chars, (repv stream, repv count), rep_Subr2) /* ::doc:rep.io.streams#read-chars:: read-chars STREAM COUNT Read upto COUNT characters from the input stream STREAM, returning a string containing the characters. If EOF is read before reading COUNT characters, the returned string will contain the characters read up to that point. If no characters are read, nil will be returned. ::end:: */ { char *buf; int len; rep_DECLARE2 (count, rep_INTP); buf = alloca (rep_INT (count)); if (rep_FILEP (stream) && rep_LOCAL_FILE_P (stream)) { /* Special case for local file streams. */ len = fread (buf, sizeof (char), rep_INT (count), rep_FILE (stream)->file.fh); /* XXX one possibility is to scan for newlines in the buffer.. */ rep_FILE (stream)->car |= rep_LFF_BOGUS_LINE_NUMBER; } else { int c; len = 0; while (len < rep_INT(count) && (c = rep_stream_getc (stream)) != EOF) { buf[len++] = c; } } if (len > 0) return rep_string_dupn (buf, len); else return Qnil; } DEFUN("read-line", Fread_line, Sread_line, (repv stream), rep_Subr1) /* ::doc:rep.io.streams#read-line:: read-line STREAM Read one line of text from STREAM. ::end:: */ { char buf[400]; if (rep_FILEP(stream) && rep_LOCAL_FILE_P (stream)) { /* Special case for file streams. We can read a line in one go. */ if (fgets (buf, sizeof (buf), rep_FILE (stream)->file.fh)) return rep_string_dup (buf); else return Qnil; } else { char *bufp = buf; int len = 0, c; while ((c = rep_stream_getc (stream)) != EOF) { *bufp++ = (char) c; len++; if ((len >= sizeof (buf) - 1) || (c == '\n')) break; } if (len == 0) return Qnil; return rep_string_dupn (buf, len); } } DEFUN("copy-stream", Fcopy_stream, Scopy_stream, (repv source, repv dest), rep_Subr2) /* ::doc:rep.io.streams#copy-stream:: copy-stream SOURCE-STREAM DEST-STREAM Copy all characters from SOURCE-STREAM to DEST-STREAM until an EOF is read. Returns the number of characters copied. ::end:: */ { int len = 0, c; char buf[BUFSIZ+1]; int i = 0; while ((c = rep_stream_getc (source)) != EOF) { if (i == BUFSIZ) { buf[i] = 0; rep_stream_puts (dest, buf, BUFSIZ, rep_FALSE); rep_TEST_INT; if (rep_INTERRUPTP) return rep_NULL; i = 0; } buf[i++] = c; len++; } if (i != 0) { buf[i] = 0; rep_stream_puts (dest, buf, i, rep_FALSE); } return !rep_INTERRUPTP ? rep_MAKE_INT (len) : rep_NULL; } DEFUN("read", Fread, Sread, (repv stream), rep_Subr1) /* ::doc:rep.io.streams#read:: read [STREAM] Reads one lisp-object from the input-stream STREAM (or the value of the variable `standard-input' if STREAM is unspecified) and return it. ::end:: */ { repv res; int c; if(stream == Qnil && !(stream = Fsymbol_value (Qstandard_input, Qnil))) { rep_signal_arg_error (stream, 1); return rep_NULL; } c = rep_stream_getc (stream); if (c == EOF) res = Fsignal (Qend_of_stream, rep_LIST_1(stream)); else res = rep_readl (stream, &c); /* If an error occurred leave stream where it is. */ if (res && c != EOF) rep_stream_ungetc (stream, c); return res; } DEFUN("print", Fprint, Sprint, (repv obj, repv stream), rep_Subr2) /* ::doc:rep.io.streams#print:: print OBJECT [STREAM] First outputs a newline, then prints a text representation of OBJECT to STREAM (or the contents of the variable `standard-output') in a form suitable for `read'. ::end:: */ { if(stream == Qnil && !(stream = Fsymbol_value (Qstandard_output, Qnil))) { rep_signal_arg_error (stream, 1); return rep_NULL; } rep_stream_putc (stream, '\n'); rep_print_val (stream, obj); return !rep_INTERRUPTP ? obj : rep_NULL; } DEFUN("prin1", Fprin1, Sprin1, (repv obj, repv stream), rep_Subr2) /* ::doc:rep.io.streams#prin1:: prin1 OBJECT [STREAM] Prints a text representation of OBJECT to STREAM (or the contents of the variable `standard-output') in a form suitable for `read'. ::end:: */ { if(stream == Qnil && !(stream = Fsymbol_value (Qstandard_output, Qnil))) { rep_signal_arg_error (stream, 1); return rep_NULL; } rep_print_val (stream, obj); return !rep_INTERRUPTP ? obj : rep_NULL; } DEFUN("princ", Fprinc, Sprinc, (repv obj, repv stream), rep_Subr2) /* ::doc:rep.io.streams#princ:: princ OBJECT [STREAM] Prints a text representation of OBJECT to STREAM (or the contents of the variable standard-output), no strange characters are quoted and no quotes are printed around strings. ::end:: */ { if(stream == Qnil && !(stream = Fsymbol_value (Qstandard_output, Qnil))) { rep_signal_arg_error (stream, 1); return rep_NULL; } rep_princ_val (stream, obj); return !rep_INTERRUPTP ? obj : rep_NULL; } DEFUN("format", Fformat, Sformat, (repv args), rep_SubrN) /* ::doc:rep.io.streams#format:: format STREAM FORMAT-STRING ARGS... Writes a string created from the format specification FORMAT-STRING and the argument-values ARGS to the stream, STREAM. If STREAM is nil a string is created and returned. FORMAT-STRING is a template for the result, any `%' characters introduce a substitution, using the next unused ARG. The substitutions have the following syntax, %[FLAGS][FIELD-WIDTH][.PRECISION]CONVERSION FIELD-WIDTH is a positive decimal integer, defining the size in characters of the substitution output. PRECISION is only valid when printing floating point numbers. CONVERSION is a character defining how to convert the corresponding ARG to text. The default options are: d Output ARG as a decimal integer x, X Output ARG as a hexadecimal integer o Output ARG as an octal integer c Output ARG as a character s Output the result of `(princ ARG)' S Output the result of `(prin1 ARG)' FLAGS is a sequence of zero or more of the following characters, - Left justify substitution within field ^ Truncate substitution at size of field 0 Pad the field with zeros instead of spaces + For d, x, and o conversions, output a leading plus sign if ARG is positive ` ' (A space) For d, x, and o conversions, if the result doesn't start with a plus or minus sign, output a leading space The list of CONVERSIONS can be extended through the format-hooks-alist variable; the strings created by these extra conversions are formatted as if by the `s' conversion. Note that the FIELD-WIDTH and all flags currently have no effect on the `S' conversion, (or the `s' conversion when the ARG isn't a string). ::end:: */ { char *fmt, *last_fmt; rep_bool make_string; repv stream, format, extra_formats = rep_NULL; rep_GC_root gc_stream, gc_format, gc_args, gc_extra_formats; char c; int this_arg = 0; if (!rep_CONSP (args)) return rep_signal_missing_arg (1); stream = rep_CAR (args); args = rep_CDR (args); if (stream == Qnil) { stream = Fcons (rep_string_dupn ("", 0), rep_MAKE_INT (0)); make_string = rep_TRUE; } else make_string = rep_FALSE; if (!rep_CONSP (args)) return rep_signal_missing_arg (2); format = rep_CAR (args); args = rep_CDR (args); rep_DECLARE2 (format, rep_STRINGP); fmt = rep_STR (format); rep_PUSHGC (gc_stream, stream); rep_PUSHGC (gc_format, format); rep_PUSHGC (gc_args, args); rep_PUSHGC (gc_extra_formats, extra_formats); last_fmt = fmt; while ((c = *fmt++) && !rep_INTERRUPTP) { if (c == '%') { rep_bool left_justify = rep_FALSE, truncate_field = rep_FALSE; rep_bool pad_zeros = rep_FALSE; char leading_char = 0; int field_width = 0, precision = 0; char *tem; if (last_fmt != fmt - 1) { rep_stream_puts (stream, last_fmt, fmt - last_fmt - 1, rep_FALSE); if (rep_INTERRUPTP) goto exit; } /* Parse the `n$' prefix */ tem = fmt; while (1) { switch (*tem++) { int arg; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': break; case '$': arg = atoi (fmt); if (arg > 0) { this_arg = arg - 1; fmt = tem; } goto parse_flags; default: goto parse_flags; } } parse_flags: /* Then scan for flags */ c = *fmt++; while (1) { switch (c) { case '-': left_justify = rep_TRUE; break; case '^': truncate_field = rep_TRUE; break; case '0': pad_zeros = rep_TRUE; break; case '+': case ' ': leading_char = c; break; default: goto parse_field_width; } c = *fmt++; } /* Now look for the field width */ parse_field_width: while(isdigit (c)) { field_width = field_width * 10 + (c - '0'); c = *fmt++; } /* Now precision */ if (c == '.') { c = *fmt++; while (c && isdigit (c)) { precision = precision * 10 + (c - '0'); c = *fmt++; } } else precision = -1; /* Finally, the format specifier */ if(c == '%') rep_stream_putc (stream, '%'); else { repv fun; repv val = Fnth (rep_MAKE_INT (this_arg), args); rep_bool free_str = rep_FALSE; if (val == rep_NULL) goto exit; switch (c) { int radix, len, actual_len; char buf[256], *ptr; case 'c': rep_stream_putc (stream, rep_INT (val)); break; case 'x': case 'X': radix = 16; goto do_number; case 'o': radix = 8; goto do_number; case 'd': radix = 10; do_number: ptr = rep_print_number_to_string (val, radix, precision); if (ptr == 0) break; free_str = rep_TRUE; len = strlen (ptr); goto string_out; case 's': unquoted: if (!rep_STRINGP (val) || (left_justify && field_width == 0)) { rep_princ_val (stream, val); break; } ptr = rep_STR (val); len = rep_STRING_LEN (val); string_out: actual_len = len; if (leading_char) { if (*ptr != '-') actual_len++; else leading_char = 0; } if (field_width == 0 || actual_len >= field_width) { if (leading_char) rep_stream_putc (stream, leading_char); rep_stream_puts (stream, ptr, truncate_field ? (field_width - (leading_char != 0)) : len, rep_FALSE); } else { int slen = MIN (field_width - actual_len, sizeof (buf)); memset (buf, !pad_zeros ? ' ' : '0', slen); if (left_justify) { if (leading_char) rep_stream_putc (stream, leading_char); rep_stream_puts (stream, ptr, len, rep_FALSE); } rep_stream_puts (stream, buf, slen, rep_FALSE); if (!left_justify) { if (leading_char) rep_stream_putc (stream, leading_char); rep_stream_puts (stream, ptr, len, rep_FALSE); } } if (free_str) free (ptr); break; case 'S': rep_print_val (stream, val); break; default: if (extra_formats == rep_NULL) { extra_formats = Fsymbol_value (Qformat_hooks_alist, Qt); } if (rep_CONSP (extra_formats) && (fun = Fassq (rep_MAKE_INT (c), extra_formats)) && rep_CONSP (fun)) { val = rep_call_lisp1 (rep_CDR (fun), val); if (val == rep_NULL) goto exit; else { if (val == Qnil) val = rep_null_string (); goto unquoted; } } else { DEFSTRING (err, "Unknown format conversion"); Fsignal (Qerror, rep_list_2 (rep_VAL (&err), rep_MAKE_INT (c))); goto exit; } } this_arg++; } last_fmt = fmt; } } if (last_fmt != fmt - 1) rep_stream_puts (stream, last_fmt, fmt - last_fmt - 1, rep_FALSE); if (make_string) { if (rep_STRING_LEN (rep_CAR (stream)) != rep_INT (rep_CDR (stream))) { /* Truncate the stream to it's actual length. */ stream = Fcopy_sequence (rep_CAR (stream)); } else stream = rep_CAR (stream); } exit: rep_POPGC; rep_POPGC; rep_POPGC; rep_POPGC; return !rep_INTERRUPTP ? stream : rep_NULL; } DEFUN("make-string-input-stream", Fmake_string_input_stream, Smake_string_input_stream, (repv string, repv start), rep_Subr2) /* ::doc:rep.io.streams#make-string-input-stream:: make-string-input-stream STRING [START] Returns a input stream, it will supply, in order, the characters in STRING, starting from START (or the beginning of the string). ::end:: */ { rep_DECLARE1 (string, rep_STRINGP); return (Fcons (rep_INTP (start) ? start : rep_MAKE_INT (0), string)); } DEFUN("make-string-output-stream", Fmake_string_output_stream, Smake_string_output_stream, (void), rep_Subr0) /* ::doc:rep.io.streams#make-string-output-stream:: make-string-output-stream Returns an output stream which will accumulate the characters written to it for the use of the `get-output-stream-string' function. ::end:: */ { return (Fcons (rep_string_dupn ("", 0), rep_MAKE_INT (0))); } DEFUN("get-output-stream-string", Fget_output_stream_string, Sget_output_stream_string, (repv strm), rep_Subr1) /* ::doc:rep.io.streams#get-output-stream-string:: get-output-stream-string STRING-OUTPUT-STREAM Returns a string containing the characters written to the stream STRING- OUTPUT-STREAM (created by `make-string-output-stream'). The stream is then reset so that the next call to this function with this stream will only return the new characters. ::end:: */ { repv string; if (!rep_CONSP (strm) || !rep_STRINGP (rep_CAR(strm)) || !rep_INTP (rep_CDR(strm))) { return rep_signal_arg_error (strm, 1); } if (rep_STRING_LEN (rep_CAR (strm)) != rep_INT (rep_CDR (strm))) { /* Truncate the string to it's actual length. */ string = Fcopy_sequence (rep_CAR (strm)); } else string = rep_CAR (strm); /* Reset the stream. */ rep_CAR (strm) = rep_string_dupn ("", 0); rep_CDR (strm) = rep_MAKE_INT (0); return string; } DEFUN("input-stream-p", Finput_stream_p, Sinput_stream_p, (repv arg), rep_Subr1) /* ::doc:rep.io.streams#input-stream-p:: input-stream-p ARG Returns t if ARG is an input stream. ::end:: */ { repv res = Qnil; switch (rep_TYPE (arg)) { repv car, cdr; rep_type *t; case rep_Funarg: res = Qt; break; case rep_Cons: car = rep_CAR (arg); cdr = rep_CDR (arg); if (rep_INTP (car) && rep_STRINGP (cdr)) res = Qt; else { t = rep_get_data_type (rep_TYPE (car)); if (t->getc && t->ungetc) res = Qt; } break; default: if (rep_FILEP (arg)) res = Qt; /* XXX broken */ else { t = rep_get_data_type (rep_TYPE (arg)); if (t->getc && t->ungetc) res = Qt; } } return res; } DEFUN("output-stream-p", Foutput_stream_p, Soutput_stream_p, (repv arg), rep_Subr1) /* ::doc:rep.io.streams#output-stream-p:: output-stream-p ARG Returns t if ARG is an output stream. ::end:: */ { repv res = Qnil; switch (rep_TYPE (arg)) { repv car, cdr; rep_type *t; case rep_Symbol: if (arg == Qt) res = Qt; break; case rep_Funarg: res = Qt; break; case rep_Cons: car = rep_CAR (arg); cdr = rep_CDR (arg); if (rep_INTP (cdr) && rep_STRINGP (car)) res = Qt; else { t = rep_get_data_type (rep_TYPE (car)); if (t->putc && t->puts) res = Qt; } break; default: if (rep_FILEP (arg)) res = Qt; /* XXX broken */ else { t = rep_get_data_type (rep_TYPE (arg)); if (t->putc && t->puts) res = Qt; } } return res; } void rep_streams_init (void) { repv tem = rep_push_structure ("rep.io.streams"); rep_INTERN_SPECIAL(format_hooks_alist); rep_ADD_SUBR(Swrite); rep_ADD_SUBR(Sread_char); rep_ADD_SUBR(Speek_char); rep_ADD_SUBR(Sread_chars); rep_ADD_SUBR(Sread_line); rep_ADD_SUBR(Scopy_stream); rep_ADD_SUBR(Sread); rep_ADD_SUBR(Sprint); rep_ADD_SUBR(Sprin1); rep_ADD_SUBR(Sprinc); rep_ADD_SUBR(Sformat); rep_ADD_SUBR(Smake_string_input_stream); rep_ADD_SUBR(Smake_string_output_stream); rep_ADD_SUBR(Sget_output_stream_string); rep_ADD_SUBR(Sinput_stream_p); rep_ADD_SUBR(Soutput_stream_p); rep_pop_structure (tem); } librep-0.90.2/src/sockets.c0000644000175200017520000004514211245011153014472 0ustar chrischris/* sockets.c -- BSD sockets plugin $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "repint.h" #include #include #include #include #include #include #include #include #include #ifdef HAVE_UNISTD_H # include #endif #if !defined (AF_LOCAL) && defined (AF_UNIX) # define AF_LOCAL AF_UNIX #endif #if !defined (PF_LOCAL) && defined (PF_UNIX) # define PF_LOCAL PF_UNIX #endif #ifdef DEBUG # define DB(x) printf x #else # define DB(x) #endif typedef struct rep_socket_struct rep_socket; static rep_socket *socket_list; static int socket_type; struct rep_socket_struct { repv car; rep_socket *next; int sock; int namespace, style; repv addr, port; repv p_addr, p_port; repv stream, sentinel; }; #define IS_ACTIVE (1 << (rep_CELL16_TYPE_BITS + 0)) #define IS_REGISTERED (1 << (rep_CELL16_TYPE_BITS + 1)) #define SOCKET_IS_ACTIVE(s) ((s)->car & IS_ACTIVE) #define SOCKET_IS_REGISTERED(s) ((s)->car & IS_REGISTERED) #define SOCKETP(x) rep_CELL16_TYPEP (x, socket_type) #define SOCKET(x) ((rep_socket *) rep_PTR (x)) #define ACTIVE_SOCKET_P(x) (SOCKETP (x) \ && (SOCKET_IS_ACTIVE (SOCKET (x)))) /* data structure management */ static rep_socket * make_socket_ (int sock_fd, int namespace, int style) { rep_socket *s = rep_ALLOC_CELL (sizeof (rep_socket)); rep_data_after_gc += sizeof (rep_socket); s->car = socket_type | IS_ACTIVE; s->sock = sock_fd; s->namespace = namespace; s->style = style; s->addr = rep_NULL; s->p_addr = rep_NULL; s->sentinel = s->stream = Qnil; s->next = socket_list; socket_list = s; rep_unix_set_fd_cloexec (sock_fd); DB (("made socket proxy for fd %d\n", s->sock)); return s; } static rep_socket * make_socket (int namespace, int style) { int sock_fd = socket (namespace, style, 0); if (sock_fd != -1) return make_socket_ (sock_fd, namespace, style); else return 0; } static void shutdown_socket (rep_socket *s) { if (s->sock >= 0) { close (s->sock); if (SOCKET_IS_REGISTERED (s)) rep_deregister_input_fd (s->sock); } DB (("shutdown socket fd %d\n", s->sock)); s->sock = -1; s->car &= ~IS_ACTIVE; } static void shutdown_socket_and_call_sentinel (rep_socket *s) { shutdown_socket (s); if (s->sentinel != Qnil) rep_call_lisp1 (s->sentinel, rep_VAL (s)); } static void delete_socket (rep_socket *s) { if (SOCKET_IS_ACTIVE (s)) shutdown_socket (s); rep_FREE_CELL (s); } static rep_socket * socket_for_fd (int fd) { rep_socket *s; for (s = socket_list; s != 0; s = s->next) { if (s->sock == fd) return s; } abort (); } /* clients */ static void client_socket_output (int fd) { rep_socket *s = socket_for_fd (fd); char buf[1025]; int actual; DB (("client_socket_output for %d\n", fd)); do { actual = read (fd, buf, 1024); if (actual > 0) { buf[actual] = 0; if (s->stream != Qnil) rep_stream_puts (s->stream, buf, actual, rep_FALSE); } } while (actual > 0 || (actual < 0 && errno == EINTR)); if (actual == 0 || (actual < 0 && errno != EWOULDBLOCK && errno != EAGAIN)) { /* assume EOF */ shutdown_socket_and_call_sentinel (s); } } static rep_socket * make_client_socket (int namespace, int style, void *addr, size_t length) { rep_socket *s = make_socket (namespace, style); if (s != 0) { if (connect (s->sock, addr, length) == 0) { rep_unix_set_fd_nonblocking (s->sock); rep_register_input_fd (s->sock, client_socket_output); s->car |= IS_REGISTERED; return s; } shutdown_socket (s); } return 0; } /* servers */ static void server_socket_output (int fd) { rep_socket *s = socket_for_fd (fd); DB (("server_socket_output for %d\n", fd)); if (s->stream != Qnil) rep_call_lisp1 (s->stream, rep_VAL (s)); } static rep_socket * make_server_socket (int namespace, int style, void *addr, size_t length) { rep_socket *s = make_socket (namespace, style); if (s != 0) { if (bind (s->sock, addr, length) == 0) { if (listen (s->sock, 5) == 0) { rep_unix_set_fd_nonblocking (s->sock); rep_register_input_fd (s->sock, server_socket_output); s->car |= IS_REGISTERED; return s; } } shutdown_socket (s); } return 0; } /* Unix domain sockets */ static repv make_local_socket (repv addr, rep_socket *(maker)(int, int, void *, size_t), repv stream, repv sentinel) { struct sockaddr_un name; size_t length; rep_socket *s; rep_GC_root gc_addr, gc_stream, gc_sentinel; repv local; rep_PUSHGC (gc_addr, addr); rep_PUSHGC (gc_stream, stream); rep_PUSHGC (gc_sentinel, sentinel); local = Flocal_file_name (addr); rep_POPGC; rep_POPGC; rep_POPGC; if (local == rep_NULL) return rep_NULL; if (!rep_STRINGP (local)) { DEFSTRING (err, "Not a local file"); return Fsignal (Qfile_error, rep_list_2 (rep_VAL (&err), addr)); } name.sun_family = AF_LOCAL; strncpy (name.sun_path, rep_STR (local), sizeof (name.sun_path)); length = (offsetof (struct sockaddr_un, sun_path) + strlen (name.sun_path) + 1); s = maker (PF_LOCAL, SOCK_STREAM, &name, length); if (s != 0) { s->addr = addr; s->sentinel = sentinel; s->stream = stream; return rep_VAL (s); } else return rep_signal_file_error (addr); } DEFUN ("socket-local-client", Fsocket_local_client, Ssocket_local_client, (repv addr, repv stream, repv sentinel), rep_Subr3) /* ::doc:rep.io.sockets#socket-local-client:: socket-local-client ADDRESS [STREAM] [SENTINEL] Create and return a socket connected to the unix domain socket at ADDRESS (a special node in the local filing system). All output from this socket will be copied to STREAM; when the socket is closed down remotely SENTINEL will be called with the socket as its single argument. ::end:: */ { rep_DECLARE (1, addr, rep_STRINGP (addr)); return make_local_socket (addr, make_client_socket, stream, sentinel); } DEFUN ("socket-local-server", Fsocket_local_server, Ssocket_local_server, (repv addr, repv callback, repv sentinel), rep_Subr3) /* ::doc:rep.io.sockets#socket-local-server:: socket-local-server ADDRESS [CALLBACK] [SENTINEL] Create and return a socket listening for connections on the unix domain socket at ADDRESS (a special node in the local filing system). When a connection is requested CALLBACK is called with the server socket as its sole argument. It must call `socket-accept' to make the connection. When the socket is shutdown remotely, SENTINEL is called with the socket as its only argument. ::end:: */ { rep_DECLARE (1, addr, rep_STRINGP (addr)); return make_local_socket (addr, make_server_socket, callback, sentinel); } /* Internet domain sockets */ static repv make_inet_socket (repv hostname, int port, rep_socket *(maker)(int, int, void *, size_t), repv stream, repv sentinel) { struct sockaddr_in name; struct hostent *hostinfo; rep_socket *s = 0; name.sin_family = AF_INET; name.sin_port = htons (port); if (rep_STRINGP (hostname)) { hostinfo = gethostbyname (rep_STR (hostname)); if (hostinfo != 0) name.sin_addr = * (struct in_addr *) hostinfo->h_addr; else { errno = ENOENT; return rep_signal_file_error (hostname); } } else name.sin_addr.s_addr = INADDR_ANY; s = maker (PF_INET, SOCK_STREAM, &name, sizeof (name)); if (s != 0) { s->sentinel = sentinel; s->stream = stream; return rep_VAL (s); } else return rep_signal_file_error (hostname); } DEFUN ("socket-client", Fsocket_client, Ssocket_client, (repv host, repv port, repv stream, repv sentinel), rep_Subr4) /* ::doc:rep.io.sockets#socket-client:: socket-client HOSTNAME PORT [STREAM] [SENTINEL] Create and return a socket connected to the socket on the host called HOSTNAME (a string) with port number PORT. All output from this socket will be copied to STREAM; when the socket is closed down remotely SENTINEL will be called with the socket as its single argument. ::end:: */ { rep_DECLARE (1, host, rep_STRINGP (host)); rep_DECLARE (2, port, rep_INTP (port)); return make_inet_socket (host, rep_INT (port), make_client_socket, stream, sentinel); } DEFUN ("socket-server", Fsocket_server, Ssocket_server, (repv host, repv port, repv callback, repv sentinel), rep_Subr4) /* ::doc:rep.io.sockets#socket-server:: socket-server [HOSTNAME] [PORT] [CALLBACK] [SENTINEL] Create and return a socket connected listening for connections on the host called HOSTNAME (a string) with port number PORT. If HOSTNAME is false, listen for any incoming addresses. If PORT is undefined a random port will be chosen. When a connection is requested CALLBACK is called with the server socket as its sole argument. It must call `socket-accept' to make the connection. When the socket is shutdown remotely, SENTINEL is called with the socket as its only argument. ::end:: */ { rep_DECLARE (1, host, rep_NILP (host) || rep_STRINGP (host)); rep_DECLARE (2, port, rep_NILP (port) || rep_INTP (port)); return make_inet_socket (host, rep_INTP (port) ? rep_INT (port) : 0, make_server_socket, callback, sentinel); } /* Misc lisp functions */ DEFUN ("close-socket", Fclose_socket, Sclose_socket, (repv sock), rep_Subr1) /* ::doc:rep.io.sockets#close-socket:: close-socket SOCKET Shutdown the connection associate with SOCKET. Note that this does not cause the SENTINEL function associated with SOCKET to run. ::end:: */ { rep_DECLARE (1, sock, SOCKETP (sock)); shutdown_socket (SOCKET (sock)); return Qnil; } DEFUN ("socket-accept", Fsocket_accept, Ssocket_accept, (repv sock, repv stream, repv sentinel), rep_Subr3) /* ::doc:rep.io.sockets#socket-accept:: socket-accept SOCKET [STREAM] [SENTINEL] Accept the pending connection request on server socket SOCKET. This will create and return a client socket forming the end point of the connection. Any output received will be copied to the output stream STREAM, when the connection is terminated remotely SENTINEL will be called with the closed socket as its sole argument. Note that this function must be called every time a connection request is received. If the server wants to reject the connection it should subsequently call `close-socket' on the created client. ::end:: */ { rep_socket *s; struct sockaddr_in in_name; struct sockaddr_un un_name; void *addr; socklen_t length; int new; rep_DECLARE (1, sock, ACTIVE_SOCKET_P (sock)); s = SOCKET (sock); if (s->namespace == PF_LOCAL) { addr = &un_name; length = sizeof (un_name); } else { addr = &in_name; length = sizeof (in_name); } new = accept (s->sock, addr, &length); if (new != -1) { rep_socket *client = make_socket_ (new, s->namespace, s->style); rep_unix_set_fd_nonblocking (new); rep_register_input_fd (new, client_socket_output); client->car |= IS_REGISTERED; client->stream = stream; client->sentinel = sentinel; return rep_VAL (client); } else return Qnil; } static void fill_in_address (rep_socket *s) { if (s->addr == rep_NULL) { if (s->namespace == PF_INET) { struct sockaddr_in name; socklen_t length = sizeof (name); if (getsockname (s->sock, (struct sockaddr *) &name, &length) == 0) { if (name.sin_addr.s_addr == INADDR_ANY) { /* Try to guess the ip address we're listening on */ char hname[128]; struct hostent *ent; gethostname (hname, sizeof (hname) - 1); ent = gethostbyname (hname); if (ent != 0) { struct in_addr *addr = ((struct in_addr *) ent->h_addr_list[0]); s->addr = rep_string_dup (inet_ntoa (*addr)); } else s->addr = rep_string_dup (inet_ntoa (name.sin_addr)); } else s->addr = rep_string_dup (inet_ntoa (name.sin_addr)); s->port = rep_MAKE_INT (ntohs (name.sin_port)); } } if (s->addr == rep_NULL) { s->addr = Qnil; s->port = Qnil; } } } static void fill_in_peer_address (rep_socket *s) { if (s->p_addr == rep_NULL) { if (s->namespace == PF_INET) { struct sockaddr_in name; socklen_t length = sizeof (name); if (getpeername (s->sock, (struct sockaddr *) &name, &length) == 0) { char *addr = inet_ntoa (name.sin_addr); if (addr != 0) { s->p_addr = rep_string_dup (addr); s->p_port = rep_MAKE_INT (ntohs (name.sin_port)); } } } if (s->p_addr == rep_NULL) { s->p_addr = Qnil; s->p_port = Qnil; } } } DEFUN ("socket-address", Fsocket_address, Ssocket_address, (repv sock), rep_Subr1) /* ::doc:rep.io.sockets#socket-address:: socket-address SOCKET Return the address associated with SOCKET, or false if this is unknown. ::end:: */ { rep_DECLARE (1, sock, SOCKETP (sock)); fill_in_address (SOCKET (sock)); return SOCKET (sock)->addr; } DEFUN ("socket-port", Fsocket_port, Ssocket_port, (repv sock), rep_Subr1) /* ::doc:rep.io.sockets#socket-port:: socket-port SOCKET Return the port associated with SOCKET, or false if this is unknown. ::end:: */ { rep_DECLARE (1, sock, SOCKETP (sock)); fill_in_address (SOCKET (sock)); return SOCKET (sock)->port; } DEFUN ("socket-peer-address", Fsocket_peer_address, Ssocket_peer_address, (repv sock), rep_Subr1) /* ::doc:rep.io.sockets#socket-peer-address:: socket-peer-address SOCKET Return the address of the peer connected to SOCKET, or false if this is unknown. ::end:: */ { rep_DECLARE (1, sock, SOCKETP (sock)); fill_in_peer_address (SOCKET (sock)); return SOCKET (sock)->p_addr; } DEFUN ("socket-peer-port", Fsocket_peer_port, Ssocket_peer_port, (repv sock), rep_Subr1) /* ::doc:rep.io.sockets#socket-peer-port:: socket-peer-port SOCKET Return the port of the peer connected to SOCKET, or false if this is unknown. ::end:: */ { rep_DECLARE (1, sock, SOCKETP (sock)); fill_in_peer_address (SOCKET (sock)); return SOCKET (sock)->p_port; } DEFUN ("accept-socket-output-1", Faccept_socket_output_1, Saccept_socket_output_1, (repv sock, repv secs, repv msecs), rep_Subr3) /* ::doc:rep.io.sockets#accept-socket-output-1:: accept-socket-output-1 SOCKET [SECS] [MSECS] Process any pending output from SOCKET (this includes connection requests, data transfer and shutdown notifications). Waits for SECS seconds and MSECS milliseconds. Returns true if the timeout was reached without any output being processed, otherwise returns false. ::end:: */ { rep_DECLARE (1, sock, ACTIVE_SOCKET_P (sock)); return (rep_accept_input_for_fds ((rep_INTP(secs) ? rep_INT(secs) * 1000 : 0) + (rep_INTP(msecs) ? rep_INT(msecs) : 0), 1, &SOCKET (sock)->sock)); } DEFUN ("socketp", Fsocketp, Ssocketp, (repv arg), rep_Subr1) /* ::doc:rep.io.sockets#socketp:: socketp ARG Return true if ARG is an unclosed socket object. ::end:: */ { return (SOCKETP (arg) && SOCKET_IS_ACTIVE (SOCKET (arg))) ? Qt : Qnil; } /* type hooks */ DEFSTRING (inactive_socket, "Inactive socket"); static rep_bool poll_for_input (int fd) { fd_set inputs; int ready; FD_ZERO (&inputs); FD_SET (fd, &inputs); ready = select (FD_SETSIZE, 0, &inputs, 0, 0); return ready == 1; } /* Returns the number of bytes actually written. */ static unsigned int blocking_write (rep_socket *s, char *data, unsigned int bytes) { unsigned int done = 0; if (!SOCKET_IS_ACTIVE (s)) { Fsignal (Qfile_error, rep_list_2 (rep_VAL (&inactive_socket), rep_VAL (s))); return -1; } do { int actual = write (s->sock, data + done, bytes - done); if (actual < 0) { if (errno == EAGAIN || errno == EWOULDBLOCK) { if (!poll_for_input (s->sock)) goto error; } else if (errno != EINTR) goto error; } else done += actual; } while (done < bytes); return done; error: rep_signal_file_error (rep_VAL (s)); shutdown_socket_and_call_sentinel (s); return -1; } static int socket_putc (repv stream, int c) { char data = c; return blocking_write (SOCKET (stream), &data, 1); } static int socket_puts (repv stream, void *data, int len, rep_bool is_lisp) { char *buf = is_lisp ? rep_STR(data) : data; return blocking_write (SOCKET (stream), buf, len); } static void socket_mark (repv val) { rep_MARKVAL (SOCKET (val)->addr); rep_MARKVAL (SOCKET (val)->stream); rep_MARKVAL (SOCKET (val)->sentinel); } static void socket_mark_active (void) { rep_socket *s; for (s = socket_list; s != 0; s = s->next) { if (SOCKET_IS_ACTIVE (s)) rep_MARKVAL (rep_VAL (s)); } } static void socket_sweep (void) { rep_socket *x = socket_list; socket_list = 0; while (x != 0) { rep_socket *next = x->next; if (!rep_GC_CELL_MARKEDP (rep_VAL (x))) delete_socket (x); else { rep_GC_CLR_CELL (rep_VAL (x)); x->next = socket_list; socket_list = x; } x = next; } } static void socket_print (repv stream, repv arg) { rep_stream_puts (stream, "#", -1, rep_FALSE); } /* dl hooks */ repv rep_dl_init (void) { repv tem = rep_push_structure ("rep.io.sockets"); socket_type = rep_register_new_type ("socket", 0, socket_print, socket_print, socket_sweep, socket_mark, socket_mark_active, 0, 0, socket_putc, socket_puts, 0, 0); rep_ADD_SUBR (Ssocket_local_client); rep_ADD_SUBR (Ssocket_local_server); rep_ADD_SUBR (Ssocket_client); rep_ADD_SUBR (Ssocket_server); rep_ADD_SUBR (Sclose_socket); rep_ADD_SUBR (Ssocket_accept); rep_ADD_SUBR (Ssocket_address); rep_ADD_SUBR (Ssocket_port); rep_ADD_SUBR (Ssocket_peer_address); rep_ADD_SUBR (Ssocket_peer_port); rep_ADD_SUBR (Saccept_socket_output_1); rep_ADD_SUBR (Ssocketp); rep_register_process_input_handler (client_socket_output); rep_register_process_input_handler (server_socket_output); return rep_pop_structure (tem); } void rep_dl_kill (void) { rep_socket *s; for (s = socket_list; s != 0; s = s->next) shutdown_socket (s); socket_list = 0; } librep-0.90.2/src/sdbm_tune.h0000644000175200017520000000123111245011153014773 0ustar chrischris/* * sdbm - ndbm work-alike hashed database library * tuning and portability constructs [not nearly enough] * author: oz@nexus.yorku.ca */ #define BYTESIZ 8 #ifdef SVID #include #endif #ifdef BSD42 #define SEEK_SET L_SET #define memset(s,c,n) bzero(s, n) /* only when c is zero */ #define memcpy(s1,s2,n) bcopy(s2, s1, n) #define memcmp(s1,s2,n) bcmp(s1,s2,n) #endif /* * important tuning parms (hah) */ #define SEEDUPS /* always detect duplicates */ #define BADMESS /* generate a message for worst case: cannot make room after SPLTMAX splits */ /* * misc */ #ifdef DEBUG #define debug(x) printf x #else #define debug(x) #endif librep-0.90.2/src/sdbm_pair.h0000644000175200017520000000055211245011153014760 0ustar chrischrisextern int sdbm_fitpair (char *, int); extern void sdbm_putpair (char *, datum, datum); extern datum sdbm_getpair (char *, datum); extern int sdbm_delpair (char *, datum); extern int sdbm_chkpage (char *); extern datum sdbm_getnkey (char *, int); extern void sdbm_splpage (char *, char *, long); #ifdef SEEDUPS extern int sdbm_duppair (char *, datum); #endif librep-0.90.2/src/sdbm_pair.c0000644000175200017520000001305511245011153014755 0ustar chrischris/* * sdbm - ndbm work-alike hashed database library * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). * author: oz@nexus.yorku.ca * status: public domain. * * page-level routines */ #include "sdbm.h" #include "sdbm_tune.h" #include "sdbm_pair.h" #ifndef BSD42 #include #endif #define exhash(item) sdbm_hash((item).dptr, (item).dsize) /* * forward */ static int seepair (char *, int, char *, int); /* * page format: * +------------------------------+ * ino | n | keyoff | datoff | keyoff | * +------------+--------+--------+ * | datoff | - - - ----> | * +--------+---------------------+ * | F R E E A R E A | * +--------------+---------------+ * | <---- - - - | data | * +--------+-----+----+----------+ * | key | data | key | * +--------+----------+----------+ * * calculating the offsets for free area: if the number * of entries (ino[0]) is zero, the offset to the END of * the free area is the block size. Otherwise, it is the * nth (ino[ino[0]]) entry's offset. */ int sdbm_fitpair(pag, need) char *pag; int need; { register int n; register int off; register int free; register short *ino = (short *) pag; off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ; free = off - (n + 1) * sizeof(short); need += 2 * sizeof(short); debug(("free %d need %d\n", free, need)); return need <= free; } void sdbm_putpair(pag, key, val) char *pag; datum key; datum val; { register int n; register int off; register short *ino = (short *) pag; off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ; /* * enter the key first */ off -= key.dsize; (void) memcpy(pag + off, key.dptr, key.dsize); ino[n + 1] = off; /* * now the data */ off -= val.dsize; (void) memcpy(pag + off, val.dptr, val.dsize); ino[n + 2] = off; /* * adjust item count */ ino[0] += 2; } datum sdbm_getpair(pag, key) char *pag; datum key; { register int i; register int n; datum val; register short *ino = (short *) pag; if ((n = ino[0]) == 0) return nullitem; if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0) return nullitem; val.dptr = pag + ino[i + 1]; val.dsize = ino[i] - ino[i + 1]; return val; } #ifdef SEEDUPS int sdbm_duppair(pag, key) char *pag; datum key; { register short *ino = (short *) pag; return ino[0] > 0 && seepair(pag, ino[0], key.dptr, key.dsize) > 0; } #endif datum sdbm_getnkey(pag, num) char *pag; int num; { datum key; register int off; register short *ino = (short *) pag; num = num * 2 - 1; if (ino[0] == 0 || num > ino[0]) return nullitem; off = (num > 1) ? ino[num - 1] : PBLKSIZ; key.dptr = pag + ino[num]; key.dsize = off - ino[num]; return key; } int sdbm_delpair(pag, key) char *pag; datum key; { register int n; register int i; register short *ino = (short *) pag; if ((n = ino[0]) == 0) return 0; if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0) return 0; /* * found the key. if it is the last entry * [i.e. i == n - 1] we just adjust the entry count. * hard case: move all data down onto the deleted pair, * shift offsets onto deleted offsets, and adjust them. * [note: 0 < i < n] */ if (i < n - 1) { register int m; register char *dst = pag + (i == 1 ? PBLKSIZ : ino[i - 1]); register char *src = pag + ino[i + 1]; register int zoo = dst - src; debug(("free-up %d ", zoo)); /* * shift data/keys down */ m = ino[i + 1] - ino[n]; #ifdef DUFF #define MOVB *--dst = *--src if (m > 0) { register int loop = (m + 8 - 1) >> 3; switch (m & (8 - 1)) { case 0: do { MOVB; case 7: MOVB; case 6: MOVB; case 5: MOVB; case 4: MOVB; case 3: MOVB; case 2: MOVB; case 1: MOVB; } while (--loop); } } #else #ifdef MEMMOVE memmove(dst, src, m); #else while (m--) *--dst = *--src; #endif #endif /* * adjust offset index up */ while (i < n - 1) { ino[i] = ino[i + 2] + zoo; i++; } } ino[0] -= 2; return 1; } /* * search for the key in the page. * return offset index in the range 0 < i < n. * return 0 if not found. */ static int seepair(pag, n, key, siz) char *pag; register int n; register char *key; register int siz; { register int i; register int off = PBLKSIZ; register short *ino = (short *) pag; for (i = 1; i < n; i += 2) { if (siz == off - ino[i] && memcmp(key, pag + ino[i], siz) == 0) return i; off = ino[i + 1]; } return 0; } void sdbm_splpage(pag, new, sbit) char *pag; char *new; long sbit; { datum key; datum val; register int n; register int off = PBLKSIZ; char cur[PBLKSIZ]; register short *ino = (short *) cur; (void) memcpy(cur, pag, PBLKSIZ); (void) memset(pag, 0, PBLKSIZ); (void) memset(new, 0, PBLKSIZ); n = ino[0]; for (ino++; n > 0; ino += 2) { key.dptr = cur + ino[0]; key.dsize = off - ino[0]; val.dptr = cur + ino[1]; val.dsize = ino[0] - ino[1]; /* * select the page pointer (by looking at sbit) and insert */ (void) sdbm_putpair((exhash(key) & sbit) ? new : pag, key, val); off = ino[1]; n -= 2; } debug(("%d split %d/%d\n", ((short *) cur)[0] / 2, ((short *) new)[0] / 2, ((short *) pag)[0] / 2)); } /* * check page sanity: * number of entries should be something * reasonable, and all offsets in the index should be in order. * this could be made more rigorous. */ int sdbm_chkpage(pag) char *pag; { register int n; register int off; register short *ino = (short *) pag; if ((n = ino[0]) < 0 || n > PBLKSIZ / sizeof(short)) return 0; if (n > 0) { off = PBLKSIZ; for (ino++; n > 0; ino += 2) { if (ino[0] > off || ino[1] > off || ino[1] > ino[0]) return 0; off = ino[1]; n -= 2; } } return 1; } librep-0.90.2/src/sdbm_hash.c0000644000175200017520000000163311245011153014744 0ustar chrischris/* * sdbm - ndbm work-alike hashed database library * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). * author: oz@nexus.yorku.ca * status: public domain. keep it that way. * * hashing routine */ #include "sdbm.h" /* * polynomial conversion ignoring overflows * [this seems to work remarkably well, in fact better * then the ndbm hash function. Replace at your own risk] * use: 65599 nice. * 65587 even better. */ long sdbm_hash(str, len) register char *str; register int len; { register unsigned long n = 0; #ifdef DUFF #define HASHC n = *str++ + 65599 * n if (len > 0) { register int loop = (len + 8 - 1) >> 3; switch(len & (8 - 1)) { case 0: do { HASHC; case 7: HASHC; case 6: HASHC; case 5: HASHC; case 4: HASHC; case 3: HASHC; case 2: HASHC; case 1: HASHC; } while (--loop); } } #else while (len--) n = *str++ + 65599 * n; #endif return n; } librep-0.90.2/src/sdbm.h0000644000175200017520000000403111245011153013741 0ustar chrischris/* * sdbm - ndbm work-alike hashed database library * based on Per-Ake Larson's Dynamic Hashing algorithms. BIT 18 (1978). * author: oz@nexus.yorku.ca * status: public domain. */ #define DBLKSIZ 4096 #define PBLKSIZ 1024 #define PAIRMAX 1008 /* arbitrary on PBLKSIZ-N */ #define SPLTMAX 10 /* maximum allowed splits */ /* for a single insertion */ #define DIRFEXT ".dir" #define PAGFEXT ".pag" typedef struct { int dirf; /* directory file descriptor */ int pagf; /* page file descriptor */ int flags; /* status/error flags, see below */ long maxbno; /* size of dirfile in bits */ long curbit; /* current bit number */ long hmask; /* current hash mask */ long blkptr; /* current block for nextkey */ int keyptr; /* current key for nextkey */ long blkno; /* current page to read/write */ long pagbno; /* current page in pagbuf */ char pagbuf[PBLKSIZ]; /* page file block buffer */ long dirbno; /* current block in dirbuf */ char dirbuf[DBLKSIZ]; /* directory file block buffer */ } SDBM; #define SDBM_RDONLY 0x1 /* data base open read-only */ #define SDBM_IOERR 0x2 /* data base I/O error */ /* * utility macros */ #define sdbm_rdonly(db) ((db)->flags & SDBM_RDONLY) #define sdbm_error(db) ((db)->flags & SDBM_IOERR) #define sdbm_clearerr(db) ((db)->flags &= ~SDBM_IOERR) /* ouch */ #define sdbm_dirfno(db) ((db)->dirf) #define sdbm_pagfno(db) ((db)->pagf) typedef struct { char *dptr; int dsize; } datum; extern datum nullitem; /* * flags to sdbm_store */ #define SDBM_INSERT 0 #define SDBM_REPLACE 1 /* * ndbm interface */ extern SDBM *sdbm_open (char *, int, int); extern void sdbm_close (SDBM *); extern datum sdbm_fetch (SDBM *, datum); extern int sdbm_delete (SDBM *, datum); extern int sdbm_store (SDBM *, datum, datum, int); extern datum sdbm_firstkey (SDBM *); extern datum sdbm_nextkey (SDBM *); /* * other */ extern SDBM *sdbm_prep (char *, char *, int, int); extern long sdbm_hash (char *, int); librep-0.90.2/src/sdbm.c0000644000175200017520000002521311245011153013741 0ustar chrischris/* * sdbm - ndbm work-alike hashed database library * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). * author: oz@nexus.yorku.ca * status: public domain. * * core routines */ #include "sdbm.h" #include "sdbm_tune.h" #include "sdbm_pair.h" #include #include #ifdef BSD42 #include #else #include #include #endif #include #include #include #ifdef __STDC__ #include #include #endif #ifndef NULL #define NULL 0 #endif /* * forward */ static int getdbit (SDBM *, long); static int setdbit (SDBM *, long); static int getpage (SDBM *, long); static datum getnext (SDBM *); static int makroom (SDBM *, long, int); /* * useful macros */ #define bad(x) ((x).dptr == NULL || (x).dsize <= 0) #define exhash(item) sdbm_hash((item).dptr, (item).dsize) #define ioerr(db) ((db)->flags |= SDBM_IOERR) #define OFF_PAG(off) (long) (off) * PBLKSIZ #define OFF_DIR(off) (long) (off) * DBLKSIZ static long masks[] = { 000000000000, 000000000001, 000000000003, 000000000007, 000000000017, 000000000037, 000000000077, 000000000177, 000000000377, 000000000777, 000000001777, 000000003777, 000000007777, 000000017777, 000000037777, 000000077777, 000000177777, 000000377777, 000000777777, 000001777777, 000003777777, 000007777777, 000017777777, 000037777777, 000077777777, 000177777777, 000377777777, 000777777777, 001777777777, 003777777777, 007777777777, 017777777777 }; datum nullitem = {NULL, 0}; SDBM * sdbm_open(file, flags, mode) register char *file; register int flags; register int mode; { register SDBM *db; register char *dirname; register char *pagname; register int n; if (file == NULL || !*file) return errno = EINVAL, (SDBM *) NULL; /* * need space for two seperate filenames */ n = strlen(file) * 2 + strlen(DIRFEXT) + strlen(PAGFEXT) + 2; if ((dirname = malloc((unsigned) n)) == NULL) return errno = ENOMEM, (SDBM *) NULL; /* * build the file names */ dirname = strcat(strcpy(dirname, file), DIRFEXT); pagname = strcpy(dirname + strlen(dirname) + 1, file); pagname = strcat(pagname, PAGFEXT); db = sdbm_prep(dirname, pagname, flags, mode); free((char *) dirname); return db; } SDBM * sdbm_prep(dirname, pagname, flags, mode) char *dirname; char *pagname; int flags; int mode; { register SDBM *db; struct stat dstat; if ((db = (SDBM *) malloc(sizeof(SDBM))) == NULL) return errno = ENOMEM, (SDBM *) NULL; db->flags = 0; db->hmask = 0; db->blkptr = 0; db->keyptr = 0; /* * adjust user flags so that WRONLY becomes RDWR, * as required by this package. Also set our internal * flag for RDONLY if needed. */ if (flags & O_WRONLY) flags = (flags & ~O_WRONLY) | O_RDWR; else if ((flags & 03) == O_RDONLY) db->flags = SDBM_RDONLY; /* * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ if ((db->pagf = open(pagname, flags, mode)) > -1) { if ((db->dirf = open(dirname, flags, mode)) > -1) { /* * need the dirfile size to establish max bit number. */ if (fstat(db->dirf, &dstat) == 0) { /* * zero size: either a fresh database, or one with a single, * unsplit data page: dirpage is all zeros. */ db->dirbno = (!dstat.st_size) ? 0 : -1; db->pagbno = -1; db->maxbno = dstat.st_size * BYTESIZ; (void) memset(db->pagbuf, 0, PBLKSIZ); (void) memset(db->dirbuf, 0, DBLKSIZ); /* * success */ return db; } (void) close(db->dirf); } (void) close(db->pagf); } free((char *) db); return (SDBM *) NULL; } void sdbm_close(db) register SDBM *db; { if (db == NULL) errno = EINVAL; else { (void) close(db->dirf); (void) close(db->pagf); free((char *) db); } } datum sdbm_fetch(db, key) register SDBM *db; datum key; { if (db == NULL || bad(key)) return errno = EINVAL, nullitem; if (getpage(db, exhash(key))) return sdbm_getpair(db->pagbuf, key); return ioerr(db), nullitem; } int sdbm_delete(db, key) register SDBM *db; datum key; { if (db == NULL || bad(key)) return errno = EINVAL, -1; if (sdbm_rdonly(db)) return errno = EPERM, -1; if (getpage(db, exhash(key))) { if (!sdbm_delpair(db->pagbuf, key)) return -1; /* * update the page file */ if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) return ioerr(db), -1; return 0; } return ioerr(db), -1; } int sdbm_store(db, key, val, flags) register SDBM *db; datum key; datum val; int flags; { int need; register long hash; if (db == NULL || bad(key)) return errno = EINVAL, -1; if (sdbm_rdonly(db)) return errno = EPERM, -1; need = key.dsize + val.dsize; /* * is the pair too big (or too small) for this database ?? */ if (need < 0 || need > PAIRMAX) return errno = EINVAL, -1; if (getpage(db, (hash = exhash(key)))) { /* * if we need to replace, delete the key/data pair * first. If it is not there, ignore. */ if (flags == SDBM_REPLACE) (void) sdbm_delpair(db->pagbuf, key); #ifdef SEEDUPS else if (sdbm_duppair(db->pagbuf, key)) return 1; #endif /* * if we do not have enough room, we have to split. */ if (!sdbm_fitpair(db->pagbuf, need)) if (!makroom(db, hash, need)) return ioerr(db), -1; /* * we have enough room or split is successful. insert the key, * and update the page file. */ (void) sdbm_putpair(db->pagbuf, key, val); if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) return ioerr(db), -1; /* * success */ return 0; } return ioerr(db), -1; } /* * makroom - make room by splitting the overfull page * this routine will attempt to make room for SPLTMAX times before * giving up. */ static int makroom(db, hash, need) register SDBM *db; long hash; int need; { long newp; char twin[PBLKSIZ]; char *pag = db->pagbuf; char *new = twin; register int smax = SPLTMAX; do { /* * split the current page */ (void) sdbm_splpage(pag, new, db->hmask + 1); /* * address of the new page */ newp = (hash & db->hmask) | (db->hmask + 1); /* * write delay, read avoidence/cache shuffle: * select the page for incoming pair: if key is to go to the new page, * write out the previous one, and copy the new one over, thus making * it the current page. If not, simply write the new page, and we are * still looking at the page of interest. current page is not updated * here, as dbm_store will do so, after it inserts the incoming pair. */ if (hash & (db->hmask + 1)) { if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) return 0; db->pagbno = newp; (void) memcpy(pag, new, PBLKSIZ); } else if (lseek(db->pagf, OFF_PAG(newp), SEEK_SET) < 0 || write(db->pagf, new, PBLKSIZ) < 0) return 0; if (!setdbit(db, db->curbit)) return 0; /* * see if we have enough room now */ if (sdbm_fitpair(pag, need)) return 1; /* * try again... update curbit and hmask as getpage would have * done. because of our update of the current page, we do not * need to read in anything. BUT we have to write the current * [deferred] page out, as the window of failure is too great. */ db->curbit = 2 * db->curbit + ((hash & (db->hmask + 1)) ? 2 : 1); db->hmask |= db->hmask + 1; if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) return 0; } while (--smax); /* * if we are here, this is real bad news. After SPLTMAX splits, * we still cannot fit the key. say goodnight. */ #ifdef BADMESS (void) write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44); #endif return 0; } /* * the following two routines will break if * deletions aren't taken into account. (ndbm bug) */ datum sdbm_firstkey(db) register SDBM *db; { if (db == NULL) return errno = EINVAL, nullitem; /* * start at page 0 */ if (lseek(db->pagf, OFF_PAG(0), SEEK_SET) < 0 || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) return ioerr(db), nullitem; db->pagbno = 0; db->blkptr = 0; db->keyptr = 0; return getnext(db); } datum sdbm_nextkey(db) register SDBM *db; { if (db == NULL) return errno = EINVAL, nullitem; return getnext(db); } /* * all important binary trie traversal */ static int getpage(db, hash) register SDBM *db; register long hash; { register int hbit; register long dbit; register long pagb; dbit = 0; hbit = 0; while (dbit < db->maxbno && getdbit(db, dbit)) dbit = 2 * dbit + ((hash & (1 << hbit++)) ? 2 : 1); debug(("dbit: %d...", dbit)); db->curbit = dbit; db->hmask = masks[hbit]; pagb = hash & db->hmask; /* * see if the block we need is already in memory. * note: this lookaside cache has about 10% hit rate. */ if (pagb != db->pagbno) { /* * note: here, we assume a "hole" is read as 0s. * if not, must zero pagbuf first. */ if (lseek(db->pagf, OFF_PAG(pagb), SEEK_SET) < 0 || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) return 0; if (!sdbm_chkpage(db->pagbuf)) return 0; db->pagbno = pagb; debug(("pag read: %d\n", pagb)); } return 1; } static int getdbit(db, dbit) register SDBM *db; register long dbit; { register long c; register long dirb; c = dbit / BYTESIZ; dirb = c / DBLKSIZ; if (dirb != db->dirbno) { if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) return 0; db->dirbno = dirb; debug(("dir read: %d\n", dirb)); } return db->dirbuf[c % DBLKSIZ] & (1 << dbit % BYTESIZ); } static int setdbit(db, dbit) register SDBM *db; register long dbit; { register long c; register long dirb; c = dbit / BYTESIZ; dirb = c / DBLKSIZ; if (dirb != db->dirbno) { if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) return 0; db->dirbno = dirb; debug(("dir read: %d\n", dirb)); } db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); if (dbit >= db->maxbno) db->maxbno += DBLKSIZ * BYTESIZ; if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) return 0; return 1; } /* * getnext - get the next key in the page, and if done with * the page, try the next page in sequence */ static datum getnext(db) register SDBM *db; { datum key; for (;;) { db->keyptr++; key = sdbm_getnkey(db->pagbuf, db->keyptr); if (key.dptr != NULL) return key; /* * we either run out, or there is nothing on this page.. * try the next one... If we lost our position on the * file, we will have to seek. */ db->keyptr = 0; if (db->pagbno != db->blkptr++) if (lseek(db->pagf, OFF_PAG(db->blkptr), SEEK_SET) < 0) break; db->pagbno = db->blkptr; if (read(db->pagf, db->pagbuf, PBLKSIZ) <= 0) break; if (!sdbm_chkpage(db->pagbuf)) break; } return ioerr(db), nullitem; } librep-0.90.2/src/sdbm.30000644000175200017520000002132011245011153013654 0ustar chrischris.\" $Id$ .TH SDBM 3 "1 March 1990" .SH NAME sdbm, dbm_open, dbm_prep, dbm_close, dbm_fetch, dbm_store, dbm_delete, dbm_firstkey, dbm_nextkey, dbm_hash, dbm_rdonly, dbm_error, dbm_clearerr, dbm_dirfno, dbm_pagfno \- data base subroutines .SH SYNOPSIS .nf .ft B #include .sp typedef struct { char *dptr; int dsize; } datum; .sp datum nullitem = { NULL, 0 }; .sp \s-1DBM\s0 *dbm_open(char *file, int flags, int mode) .sp \s-1DBM\s0 *dbm_prep(char *dirname, char *pagname, int flags, int mode) .sp void dbm_close(\s-1DBM\s0 *db) .sp datum dbm_fetch(\s-1DBM\s0 *db, key) .sp int dbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) .sp int dbm_delete(\s-1DBM\s0 *db, datum key) .sp datum dbm_firstkey(\s-1DBM\s0 *db) .sp datum dbm_nextkey(\s-1DBM\s0 *db) .sp long dbm_hash(char *string, int len) .sp int dbm_rdonly(\s-1DBM\s0 *db) int dbm_error(\s-1DBM\s0 *db) dbm_clearerr(\s-1DBM\s0 *db) int dbm_dirfno(\s-1DBM\s0 *db) int dbm_pagfno(\s-1DBM\s0 *db) .ft R .fi .SH DESCRIPTION .IX "database library" sdbm "" "\fLsdbm\fR" .IX dbm_open "" "\fLdbm_open\fR \(em open \fLsdbm\fR database" .IX dbm_prep "" "\fLdbm_prep\fR \(em prepare \fLsdbm\fR database" .IX dbm_close "" "\fLdbm_close\fR \(em close \fLsdbm\fR routine" .IX dbm_fetch "" "\fLdbm_fetch\fR \(em fetch \fLsdbm\fR database data" .IX dbm_store "" "\fLdbm_store\fR \(em add data to \fLsdbm\fR database" .IX dbm_delete "" "\fLdbm_delete\fR \(em remove data from \fLsdbm\fR database" .IX dbm_firstkey "" "\fLdbm_firstkey\fR \(em access \fLsdbm\fR database" .IX dbm_nextkey "" "\fLdbm_nextkey\fR \(em access \fLsdbm\fR database" .IX dbm_hash "" "\fLdbm_hash\fR \(em string hash for \fLsdbm\fR database" .IX dbm_rdonly "" "\fLdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode" .IX dbm_error "" "\fLdbm_error\fR \(em return \fLsdbm\fR database error condition" .IX dbm_clearerr "" "\fLdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition" .IX dbm_dirfno "" "\fLdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor" .IX dbm_pagfno "" "\fLdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor" .IX "database functions \(em \fLsdbm\fR" dbm_open "" \fLdbm_open\fP .IX "database functions \(em \fLsdbm\fR" dbm_prep "" \fLdbm_prep\fP .IX "database functions \(em \fLsdbm\fR" dbm_close "" \fLdbm_close\fP .IX "database functions \(em \fLsdbm\fR" dbm_fetch "" \fLdbm_fetch\fP .IX "database functions \(em \fLsdbm\fR" dbm_store "" \fLdbm_store\fP .IX "database functions \(em \fLsdbm\fR" dbm_delete "" \fLdbm_delete\fP .IX "database functions \(em \fLsdbm\fR" dbm_firstkey "" \fLdbm_firstkey\fP .IX "database functions \(em \fLsdbm\fR" dbm_nextkey "" \fLdbm_nextkey\fP .IX "database functions \(em \fLsdbm\fR" dbm_rdonly "" \fLdbm_rdonly\fP .IX "database functions \(em \fLsdbm\fR" dbm_error "" \fLdbm_error\fP .IX "database functions \(em \fLsdbm\fR" dbm_clearerr "" \fLdbm_clearerr\fP .IX "database functions \(em \fLsdbm\fR" dbm_dirfno "" \fLdbm_dirfno\fP .IX "database functions \(em \fLsdbm\fR" dbm_pagfno "" \fLdbm_pagfno\fP .LP This package allows an application to maintain a mapping of pairs in disk files. This is not to be considered a real database system, but is still useful in many simple applications built around fast retrieval of a data value from a key. This implementation uses an external hashing scheme, called Dynamic Hashing, as described by Per-Aake Larson in BIT 18 (1978) pp. 184-201. Retrieval of any item usually requires a single disk access. The application interface is compatible with the .IR ndbm (3) library. .LP An .B sdbm database is kept in two files usually given the extensions .B \.dir and .BR \.pag . The .B \.dir file contains a bitmap representing a forest of binary hash trees, the leaves of which indicate data pages in the .B \.pag file. .LP The application interface uses the .B datum structure to describe both .I keys and .IR value s. A .B datum specifies a byte sequence of .I dsize size pointed to by .IR dptr . If you use .SM ASCII strings as .IR key s or .IR value s, then you must decide whether or not to include the terminating .SM NUL byte which sometimes defines strings. Including it will require larger database files, but it will be possible to get sensible output from a .IR strings (1) command applied to the data file. .LP In order to allow a process using this package to manipulate multiple databases, the applications interface always requires a .IR handle , a .BR "DBM *" , to identify the database to be manipulated. Such a handle can be obtained from the only routines that do not require it, namely .BR dbm_open (\|) or .BR dbm_prep (\|). Either of these will open or create the two necessary files. The difference is that the latter allows explicitly naming the bitmap and data files whereas .BR dbm_open (\|) will take a base file name and call .BR dbm_prep (\|) with the default extensions. The .I flags and .I mode parameters are the same as for .BR open (2). .LP To free the resources occupied while a database handle is active, call .BR dbm_close (\|). .LP Given a handle, one can retrieve data associated with a key by using the .BR dbm_fetch (\|) routine, and associate data with a key by using the .BR dbm_store (\|) routine. .LP The values of the .I flags parameter for .BR dbm_store (\|) can be either .BR \s-1DBM_INSERT\s0 , which will not change an existing entry with the same key, or .BR \s-1DBM_REPLACE\s0 , which will replace an existing entry with the same key. Keys are unique within the database. .LP To delete a key and its associated value use the .BR dbm_delete (\|) routine. .LP To retrieve every key in the database, use a loop like: .sp .nf .ft B for (key = dbm_firstkey(db); key.dptr != NULL; key = dbm_nextkey(db)) ; .ft R .fi .LP The order of retrieval is unspecified. .LP If you determine that the performance of the database is inadequate or you notice clustering or other effects that may be due to the hashing algorithm used by this package, you can override it by supplying your own .BR dbm_hash (\|) routine. Doing so will make the database unintelligable to any other applications that do not use your specialized hash function. .sp .LP The following macros are defined in the header file: .IP .BR dbm_rdonly (\|) returns true if the database has been opened read\-only. .IP .BR dbm_error (\|) returns true if an I/O error has occurred. .IP .BR dbm_clearerr (\|) allows you to clear the error flag if you think you know what the error was and insist on ignoring it. .IP .BR dbm_dirfno (\|) returns the file descriptor associated with the bitmap file. .IP .BR dbm_pagfno (\|) returns the file descriptor associated with the data file. .SH SEE ALSO .IR open (2). .SH DIAGNOSTICS Functions that return a .B "DBM *" handle will use .SM NULL to indicate an error. Functions that return an .B int will use \-1 to indicate an error. The normal return value in that case is 0. Functions that return a .B datum will return .B nullitem to indicate an error. .LP As a special case of .BR dbm_store (\|), if it is called with the .B \s-1DBM_INSERT\s0 flag and the key already exists in the database, the return value will be 1. .LP In general, if a function parameter is invalid, .B errno will be set to .BR \s-1EINVAL\s0 . If a write operation is requested on a read-only database, .B errno will be set to .BR \s-1ENOPERM\s0 . If a memory allocation (using .IR malloc (3)) failed, .B errno will be set to .BR \s-1ENOMEM\s0 . For I/O operation failures .B errno will contain the value set by the relevant failed system call, either .IR read (2), .IR write (2), or .IR lseek (2). .SH AUTHOR .IP "Ozan S. Yigit" (oz@nexus.yorku.ca) .SH BUGS The sum of key and value data sizes must not exceed .B \s-1PAIRMAX\s0 (1008 bytes). .LP The sum of the key and value data sizes where several keys hash to the same value must fit within one bitmap page. .LP The .B \.pag file will contain holes, so its apparent size is larger than its contents. When copied through the filesystem the holes will be filled. .LP The contents of .B datum values returned are in volatile storage. If you want to retain the values pointed to, you must copy them immediately before another call to this package. .LP The only safe way for multiple processes to (read and) update a database at the same time, is to implement a private locking scheme outside this package and open and close the database between lock acquisitions. It is safe for multiple processes to concurrently access a database read-only. .SH APPLICATIONS PORTABILITY For complete source code compatibility with the Berkeley Unix .IR ndbm (3) library, the .B sdbm.h header file should be installed in .BR /usr/include/ndbm.h . .LP The .B nullitem data item, and the .BR dbm_prep (\|), .BR dbm_hash (\|), .BR dbm_rdonly (\|), .BR dbm_dirfno (\|), and .BR dbm_pagfno (\|) functions are unique to this package. librep-0.90.2/src/safemach.c0000644000175200017520000000626111245011153014565 0ustar chrischris/* safemach.c -- Untrusting VM interpreter $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" /* pull in the generic interpreter */ #define BC_APPLY_SELF safe_apply_bytecode #define ASSERT(expr) do { if (!(expr)) goto safemach_abort; } while (0) DEFSTRING (safemach_msg, "Illegal byte-code instruction"); #define EXTRA_VM_CODE \ safemach_abort: \ Fsignal (Qbytecode_error, rep_LIST_1 (rep_VAL (&safemach_msg)));\ HANDLE_ERROR; static repv safe_apply_bytecode (repv subr, int nargs, repv *args); #define OPTIMIZE_FOR_SPACE 1 #define BE_PARANOID 1 #include "lispmach.h" /* interface */ static repv safe_apply_bytecode (repv subr, int nargs, repv *args) { rep_DECLARE1 (subr, rep_COMPILEDP); return inline_apply_bytecode (subr, nargs, args); } DEFUN("safe-run-byte-code", Fsafe_run_byte_code, Ssafe_run_byte_code, (repv code, repv consts, repv stkreq), rep_Subr3) { int v_stkreq, b_stkreq, s_stkreq; if (rep_STRUCTUREP (code)) { /* install ourselves in this structure */ rep_STRUCTURE (code)->apply_bytecode = safe_apply_bytecode; return Qt; } rep_DECLARE1(code, rep_STRINGP); rep_DECLARE2(consts, rep_VECTORP); rep_DECLARE3(stkreq, rep_INTP); v_stkreq = rep_INT (stkreq) & 0x3ff; b_stkreq = (rep_INT (stkreq) >> 10) & 0x3ff; s_stkreq = rep_INT (stkreq) >> 20; return vm (code, consts, 0, 0, v_stkreq, b_stkreq, s_stkreq); } DEFUN("safe-validate-byte-code", Fsafe_validate_byte_code, Ssafe_validate_byte_code, (repv bc_major, repv bc_minor), rep_Subr2) { if(!rep_INTP(bc_major) || !rep_INTP(bc_minor) || rep_INT(bc_major) != BYTECODE_MAJOR_VERSION || rep_INT(bc_minor) > BYTECODE_MINOR_VERSION) { DEFSTRING (err, "File needs recompiling for current virtual machine"); return Fsignal (Qbytecode_error, rep_LIST_2 (rep_VAL (&err), Fsymbol_value (Qload_filename, Qt))); } else return Qt; } repv rep_dl_init (void) { repv tem = rep_push_structure ("rep.vm.safe-interpreter"); rep_ADD_SUBR (Ssafe_run_byte_code); rep_ADD_SUBR (Ssafe_validate_byte_code); return rep_pop_structure (tem); } librep-0.90.2/src/repsdbm.c0000644000175200017520000001477411245011153014462 0ustar chrischris/* repsdbm.c -- rep wrapper to libsdbm $Id$ */ #define _GNU_SOURCE #ifdef HAVE_CONFIG_H # include #endif #include "rep.h" #include "sdbm.h" #include static int dbm_type; #define rep_DBM(v) ((rep_dbm *) rep_PTR(v)) #define rep_DBMP(v) (rep_CELL16_TYPEP(v, dbm_type) && rep_DBM(v)->dbm != 0) typedef struct rep_dbm_struct { repv car; struct rep_dbm_struct *next; SDBM *dbm; repv path; repv access; repv mode; } rep_dbm; static rep_dbm *dbm_chain; DEFSYM(insert, "insert"); DEFSYM(replace, "replace"); DEFUN("sdbm-open", Fsdbm_open, Ssdbm_open, (repv file, repv flags, repv mode), rep_Subr3) /* ::doc:rep.io.db.sdbm#sdbm-open:: sdbm-open PATH ACCESS-TYPE [MODE] ::end:: */ { int uflags, umode; rep_dbm *dbm; rep_GC_root gc_flags, gc_mode; rep_PUSHGC(gc_flags, flags); rep_PUSHGC(gc_mode, mode); file = Flocal_file_name (file); rep_POPGC; rep_POPGC; if (!file) return file; rep_DECLARE1(file, rep_STRINGP); rep_DECLARE2(flags, rep_SYMBOLP); uflags = (flags == Qwrite ? O_RDWR | O_CREAT | O_TRUNC : (flags == Qappend ? O_RDWR | O_CREAT : O_RDONLY)); umode = rep_INTP(mode) ? rep_INT(mode) : 0666; dbm = rep_ALLOC_CELL (sizeof (rep_dbm)); if (dbm == 0) return rep_mem_error(); rep_data_after_gc += sizeof (rep_dbm); dbm->car = dbm_type; dbm->path = file; dbm->access = flags; dbm->mode = rep_MAKE_INT(umode); dbm->dbm = sdbm_open (rep_STR(file), uflags, umode); if (dbm->dbm != 0) { dbm->next = dbm_chain; dbm_chain = dbm; return rep_VAL(dbm); } else { rep_FREE_CELL (dbm); return rep_signal_file_error (file); } } DEFUN("sdbm-close", Fsdbm_close, Ssdbm_close, (repv dbm), rep_Subr1) /* ::doc:rep.io.db.sdbm#sdbm-close:: sdbm-close DBM ::end:: */ { rep_DECLARE1 (dbm, rep_DBMP); sdbm_close (rep_DBM(dbm)->dbm); rep_DBM(dbm)->dbm = 0; rep_DBM(dbm)->path = Qnil; rep_DBM(dbm)->access = Qnil; rep_DBM(dbm)->mode = Qnil; return Qt; } DEFUN("sdbm-fetch", Fsdbm_fetch, Ssdbm_fetch, (repv dbm, repv key), rep_Subr2) /* ::doc:rep.io.db.sdbm#sdbm-fetch:: sdbm-fetch DBM KEY ::end:: */ { datum dkey, dvalue; rep_DECLARE1 (dbm, rep_DBMP); rep_DECLARE2 (key, rep_STRINGP); dkey.dptr = rep_STR (key); dkey.dsize = rep_STRING_LEN (key); dvalue = sdbm_fetch (rep_DBM(dbm)->dbm, dkey); if (dvalue.dptr == 0) return Qnil; else return rep_string_dupn (dvalue.dptr, dvalue.dsize); } DEFUN("sdbm-store", Fsdbm_store, Ssdbm_store, (repv dbm, repv key, repv val, repv flags), rep_Subr4) /* ::doc:rep.io.db.sdbm#sdbm-store:: sdbm-store DBM KEY VALUE [FLAGS] ::end:: */ { int dflags; datum dkey, dvalue; rep_DECLARE1 (dbm, rep_DBMP); rep_DECLARE2 (key, rep_STRINGP); rep_DECLARE3 (val, rep_STRINGP); dkey.dptr = rep_STR (key); dkey.dsize = rep_STRING_LEN (key); dvalue.dptr = rep_STR (val); dvalue.dsize = rep_STRING_LEN (val); dflags = (flags == Qinsert ? SDBM_INSERT : SDBM_REPLACE); return (sdbm_store (rep_DBM(dbm)->dbm, dkey, dvalue, dflags) == 0 ? Qt : Qnil); } DEFUN("sdbm-delete", Fsdbm_delete, Ssdbm_delete, (repv dbm, repv key), rep_Subr2) /* ::doc:rep.io.db.sdbm#sdbm-delete:: sdbm-delete DBM KEY ::end:: */ { datum dkey; rep_DECLARE1 (dbm, rep_DBMP); rep_DECLARE2 (key, rep_STRINGP); dkey.dptr = rep_STR (key); dkey.dsize = rep_STRING_LEN (key) + 1; return sdbm_delete (rep_DBM(dbm)->dbm, dkey) == 0 ? Qt : Qnil; } DEFUN("sdbm-firstkey", Fsdbm_firstkey, Ssdbm_firstkey, (repv dbm), rep_Subr1) /* ::doc:rep.io.db.sdbm#sdbm-firstkey:: sdbm-firstkey DBM ::end:: */ { datum dkey; rep_DECLARE1 (dbm, rep_DBMP); dkey = sdbm_firstkey (rep_DBM(dbm)->dbm); if (dkey.dptr == 0) return Qnil; else return rep_string_dupn (dkey.dptr, dkey.dsize); } DEFUN("sdbm-nextkey", Fsdbm_nextkey, Ssdbm_nextkey, (repv dbm), rep_Subr1) /* ::doc:rep.io.db.sdbm#sdbm-nextkey:: sdbm-nextkey DBM ::end:: */ { datum dkey; rep_DECLARE1 (dbm, rep_DBMP); dkey = sdbm_nextkey (rep_DBM(dbm)->dbm); if (dkey.dptr == 0) return Qnil; else return rep_string_dupn (dkey.dptr, dkey.dsize); } DEFUN("sdbm-rdonly", Fsdbm_rdonly, Ssdbm_rdonly, (repv dbm), rep_Subr1) /* ::doc:rep.io.db.sdbm#sdbm-rdonly:: sdbm-rdonly DBM ::end:: */ { rep_DECLARE1 (dbm, rep_DBMP); return sdbm_rdonly (rep_DBM(dbm)->dbm) ? Qt : Qnil; } DEFUN("sdbm-error", Fsdbm_error, Ssdbm_error, (repv dbm), rep_Subr1) /* ::doc:rep.io.db.sdbm#sdbm-error:: sdbm-error DBM ::end:: */ { rep_DECLARE1 (dbm, rep_DBMP); return sdbm_error (rep_DBM(dbm)->dbm) ? Qt : Qnil; } DEFUN("sdbmp", Fsdbmp, Ssdbmp, (repv arg), rep_Subr1) /* ::doc:rep.io.db.sdbm#sdbmp:: sdbmp ARG Returns t if ARG is an sdbm object (created by `sdbm-open'). ::end:: */ { return rep_DBMP(arg) ? Qt : Qnil; } static void dbm_mark (repv val) { rep_MARKVAL (rep_DBM(val)->path); rep_MARKVAL (rep_DBM(val)->access); rep_MARKVAL (rep_DBM(val)->mode); } static void dbm_sweep (void) { rep_dbm *x = dbm_chain; dbm_chain = 0; while (x != 0) { rep_dbm *next = x->next; if (!rep_GC_CELL_MARKEDP (rep_VAL(x))) { if (x->dbm != 0) sdbm_close (x->dbm); rep_FREE_CELL (x); } else { rep_GC_CLR_CELL (rep_VAL(x)); x->next = dbm_chain; dbm_chain = x; } x = next; } } static void dbm_print (repv stream, repv dbm) { rep_stream_puts (stream, "#path)) rep_stream_puts (stream, rep_PTR(rep_DBM(dbm)->path), -1, rep_TRUE); else rep_stream_puts (stream, "nil", -1, rep_FALSE); rep_stream_putc (stream, '>'); } static int dbm_compare (repv v1, repv v2) { return (v1 == v2) ? 0 : 1; } repv rep_dl_init (void) { repv tem; dbm_type = rep_register_new_type ("sdbm", dbm_compare, dbm_print, dbm_print, dbm_sweep, dbm_mark, 0, 0, 0, 0, 0, 0, 0); rep_INTERN (insert); rep_INTERN (replace); tem = rep_push_structure ("rep.io.db.sdbm"); /* ::alias:sdbm rep.io.db.sdbm:: */ rep_alias_structure ("sdbm"); rep_ADD_SUBR(Ssdbm_open); rep_ADD_SUBR(Ssdbm_close); rep_ADD_SUBR(Ssdbm_fetch); rep_ADD_SUBR(Ssdbm_store); rep_ADD_SUBR(Ssdbm_delete); rep_ADD_SUBR(Ssdbm_firstkey); rep_ADD_SUBR(Ssdbm_nextkey); rep_ADD_SUBR(Ssdbm_rdonly); rep_ADD_SUBR(Ssdbm_error); rep_ADD_SUBR(Ssdbmp); return rep_pop_structure (tem); } void rep_dl_kill (void) { rep_dbm *db; for (db = dbm_chain; db != 0; db = db->next) { if (db->dbm != 0) Fsdbm_close (rep_VAL (db)); } } librep-0.90.2/src/repint_subrs.h0000644000175200017520000002036511245011153015543 0ustar chrischris/* repint_subrs.h -- library-local prototypes Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #ifndef REPINT_SUBRS_H #define REPINT_SUBRS_H /* from continuations.c */ extern void rep_continuations_init (void); /* from datums.c */ extern void rep_pre_datums_init (void); extern void rep_datums_init (void); /* from files.c */ extern void rep_files_init(void); extern void rep_files_kill(void); /* from find.c */ extern struct rep_saved_regexp_data *rep_saved_matches; extern void rep_string_modified (repv string); extern void rep_mark_regexp_data(void); extern void rep_find_init(void); extern void rep_find_kill(void); /* from fluids.c */ extern void rep_fluids_init (void); /* from lisp.c */ extern repv rep_scm_t, rep_scm_f; extern repv rep_readl(repv, int *); extern repv rep_eval (repv form, repv tail_posn); extern void rep_lisp_prin(repv, repv); extern void rep_string_princ(repv, repv); extern void rep_string_print(repv, repv); extern repv rep_copy_list(repv); extern rep_bool rep_compare_error(repv error, repv handler); extern void rep_lisp_init(void); extern rep_bool rep_single_step_flag; /* from lispcmds.c */ extern rep_xsubr Slambda; extern repv Qload_filename; extern repv Fcall_with_exception_handler (repv, repv); extern void rep_lispcmds_init(void); extern repv Flist_star (int argc, repv *argv); extern repv Fnconc_ (int argc, repv *argv); extern repv Fappend (int argc, repv *argv); extern repv Fvector (int argc, repv *argv); extern repv Fconcat (int, repv *); extern repv Fnum_eq (int, repv *); extern repv Fnum_noteq (int, repv *); extern repv Fgtthan (int, repv *); extern repv Fgethan (int, repv *); extern repv Fltthan (int, repv *); extern repv Flethan (int, repv *); /* from lispmach.c */ extern repv Qbytecode_error; extern repv Frun_byte_code(repv code, repv consts, repv stkreq); extern repv rep_apply_bytecode (repv subr, int nargs, repv *args); extern void rep_lispmach_init(void); extern void rep_lispmach_kill(void); /* from main.c */ extern char *rep_stack_bottom; extern void rep_deprecated (rep_bool *seen, const char *desc); /* from macros.c */ extern void rep_macros_before_gc (void); extern void rep_macros_clear_history (void); extern void rep_macros_init (void); /* from misc.c */ #ifndef HAVE_STPCPY extern char *stpcpy(char *, const char *); #endif #ifndef HAVE_STRNCASECMP extern int strncasecmp (const char *s1, const char *s2, size_t n); #endif extern void rep_misc_init(void); /* from numbers.c */ extern repv rep_parse_number (char *buf, unsigned int len, unsigned int radix, int sign, unsigned int type); extern void rep_numbers_init (void); extern repv Fplus(int, repv *); extern repv Fminus(int, repv *); extern repv Fproduct(int, repv *); extern repv Fdivide(int, repv *); extern repv Flogior(int, repv *); extern repv Flogxor(int, repv *); extern repv Flogand(int, repv *); extern repv Fmax(int, repv *); extern repv Fmin(int, repv *); extern repv Fgcd (int, repv *); /* from origin.c */ extern rep_bool rep_record_origins; extern void rep_record_origin (repv form, repv stream, long start_line); extern repv Flexical_origin (repv form); extern void rep_mark_origins (void); extern void rep_origin_init (void); /* from regsub.c */ extern void rep_default_regsub(int, rep_regsubs *, char *, char *, void *); extern int rep_default_regsublen(int, rep_regsubs *, char *, void *); /* from streams.c */ extern void rep_streams_init(void); /* from structures.c */ extern repv rep_default_structure, rep_specials_structure; extern repv Qfeatures, Q_structures, Q_meta, Qrep, Q_specials, Q_user_structure, Qrep_structures, Qrep_lang_interpreter, Qrep_vm_interpreter, Qexternal, Qinternal; extern rep_struct_node *rep_search_imports (rep_struct *s, repv var); extern repv Fmake_structure (repv, repv, repv, repv); extern repv F_structure_ref (repv, repv); extern repv Fstructure_set (repv, repv, repv); extern repv Fstructure_define (repv, repv, repv); extern repv Fstructure_bound_p (repv, repv); extern repv Fexternal_structure_ref (repv, repv); extern repv Fintern_structure (repv); extern repv Fget_structure (repv); extern repv Fexport_binding (repv var); extern repv rep_get_initial_special_value (repv sym); extern repv rep_documentation_property (repv structure); extern void rep_pre_structures_init (void); extern void rep_structures_init (void); /* from symbols.c */ extern repv rep_keyword_obarray; extern int rep_pre_symbols_init(void); extern void rep_symbols_init(void); extern int rep_allocated_funargs, rep_used_funargs; extern repv Freal_set (repv var, repv value); extern repv rep_bind_special (repv oldList, repv symbol, repv newVal); /* from tuples.c */ extern int rep_allocated_tuples, rep_used_tuples; extern void rep_sweep_tuples (void); extern void rep_tuples_kill(void); /* from values.c */ extern int rep_type_cmp(repv, repv); extern int rep_ptr_cmp(repv, repv); extern rep_cons_block *rep_cons_block_chain; extern rep_cons *rep_cons_freelist; extern int rep_allocated_cons, rep_used_cons; extern rep_cons *rep_allocate_cons (void); extern void rep_cons_free(repv); extern void rep_pre_values_init (void); extern void rep_values_init(void); extern void rep_values_kill (void); extern void rep_dumped_init(char *file); /* from weak-refs.c */ extern repv Fmake_weak_ref (repv value); extern repv Fweak_ref (repv ref); extern repv Fweak_ref_set (repv ref, repv value); extern void rep_scan_weak_refs (void); extern void rep_weak_refs_init (void); #ifdef rep_HAVE_UNIX /* from unix_dl.c */ extern repv rep_open_dl_library(repv file_name); extern void rep_mark_dl_data(void); extern void rep_kill_dl_libraries(void); extern int rep_intern_dl_library (repv file_name); extern void *rep_lookup_dl_symbol (int idx, const char *name); /* from unix_files.c */ extern repv rep_file_name_absolute_p(repv file); extern repv rep_expand_file_name(repv file); extern repv rep_canonical_file_name(repv file); extern repv rep_file_name_nondirectory(repv file); extern repv rep_file_name_directory(repv file); extern repv rep_file_name_as_directory(repv file); extern repv rep_directory_file_name(repv file); extern repv rep_delete_file(repv file); extern repv rep_rename_file(repv old, repv new_); extern repv rep_make_directory(repv dir); extern repv rep_delete_directory(repv dir); extern repv rep_copy_file(repv src, repv dst); extern repv rep_file_readable_p(repv file); extern repv rep_file_writable_p(repv file); extern repv rep_file_exists_p(repv file); extern repv rep_file_regular_p(repv file); extern repv rep_file_directory_p(repv file); extern repv rep_file_symlink_p(repv file); extern repv rep_file_owner_p(repv file); extern repv rep_file_nlinks(repv file); extern repv rep_file_size(repv file); extern repv rep_file_modes(repv file); extern repv rep_set_file_modes(repv file, repv modes); extern repv rep_file_modes_as_string(repv file); extern repv rep_file_modtime(repv file); extern repv rep_directory_files(repv dir_name); extern repv rep_read_symlink (repv file); extern repv rep_make_symlink (repv file, repv contents); extern repv rep_getpwd(void); extern repv rep_structure_file (repv in); /* from unix_main.c */ extern repv rep_user_login_name(void); extern repv rep_user_full_name(void); extern repv rep_user_home_directory(repv user); extern repv rep_system_name(void); extern void rep_pre_sys_os_init(void); extern void rep_sys_os_init(void); extern void rep_sys_os_kill(void); /* from unix_processes.c */ extern repv rep_system(char *command); extern void rep_proc_init(void); extern void rep_proc_kill(void); #ifndef HAVE_REALPATH /* from realpath.c */ extern char *realpath (const char *name, char *resolved); #endif #endif /* rep_HAVE_UNIX */ #endif /* REPINT_SUBRS_H */ librep-0.90.2/src/repint.h0000644000175200017520000001456511245011153014332 0ustar chrischris/* repint.h -- Main include file for library internal objects Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #ifndef REPINT_H #define REPINT_H #ifdef HAVE_CONFIG_H #include #endif /* Maximum/minimum macros. Don't use when X or Y have side-effects! */ #define MAX(x,y) (((x) > (y)) ? (x) : (y)) #define MIN(x,y) (((x) < (y)) ? (x) : (y)) #define POS(x) MAX(x, 0) #define ABS(x) MAX(x, -(x)) #define rep_INTERNAL 1 #include "rep.h" #ifndef ENABLE_BROKEN_DUMPING /* No point incurring the overhead if it's unnecessary */ # undef rep_CONS_WRITABLE_P # define rep_CONS_WRITABLE_P(x) rep_TRUE #endif #ifdef rep_HAVE_UNIX # include "unix_defs.h" #else # error "Need an operating system definition" #endif enum file_ops { op_file_name_absolute_p = 0, op_expand_file_name, op_local_file_name, op_canonical_file_name, op_file_name_nondirectory, op_file_name_directory, op_file_name_as_directory, op_directory_file_name, op_open_file, op_close_file, op_flush_file, op_seek_file, op_write_buffer_contents, /* these three for jade */ op_read_file_contents, op_insert_file_contents, op_delete_file, op_rename_file, op_make_directory, op_delete_directory, op_copy_file, op_copy_file_to_local_fs, op_copy_file_from_local_fs, op_file_readable_p, op_file_writable_p, op_file_exists_p, op_file_regular_p, op_file_directory_p, op_file_symlink_p, op_file_owner_p, op_file_nlinks, op_file_size, op_file_modes, op_set_file_modes, op_file_modes_as_string, op_file_modtime, op_directory_files, op_read_symlink, op_make_symlink, op_MAX }; struct blocked_op { struct blocked_op *next; repv handler; }; extern struct blocked_op *rep_blocked_ops[op_MAX]; /* module system */ typedef struct rep_struct_node_struct rep_struct_node; struct rep_struct_node_struct { rep_struct_node *next; repv symbol; repv binding; unsigned int is_constant : 1; unsigned int is_exported : 1; }; /* structure encapsulating a single namespace */ typedef struct rep_struct_struct rep_struct; struct rep_struct_struct { repv car; rep_struct *next; repv name; repv inherited; /* exported symbols that have no local binding */ int total_buckets, total_bindings; rep_struct_node **buckets; repv imports; repv accessible; /* A list of the special variables that may be accessed in this environment, or Qt to denote all specials. */ repv special_env; /* Bytecode interpreter to use when calling functions defined here. If null, call rep_apply_bytecode */ repv (*apply_bytecode) (repv subr, int nargs, repv *args); }; extern int rep_structure_type; #define rep_STRUCTUREP(v) rep_CELL16_TYPEP(v, rep_structure_type) #define rep_STRUCTURE(v) ((rep_struct *) rep_PTR(v)) /* If set, currently recursively searching this module for a binding */ #define rep_STF_EXCLUSION (1 << (rep_CELL16_TYPE_BITS + 0)) /* If set, all (local) bindings are exported by default. */ #define rep_STF_EXPORT_ALL (1 << (rep_CELL16_TYPE_BITS + 1)) /* If set, bindings can be created by setq et al. */ #define rep_STF_SET_BINDS (1 << (rep_CELL16_TYPE_BITS + 2)) #define rep_SPECIAL_ENV (rep_STRUCTURE(rep_structure)->special_env) #define rep_STRUCT_HASH(x,n) (((x) >> 3) % (n)) /* binding tracking */ #define rep_MARK_LEX_BINDING(x) (x + (1 << rep_VALUE_INT_SHIFT)) #define rep_MARK_SPEC_BINDING(x) (x + (1 << (16 + rep_VALUE_INT_SHIFT))) #define rep_LEX_BINDINGS(x) (rep_INT(x) & 0xffff) #define rep_SPEC_BINDINGS(x) (rep_INT(x) >> 16) #define rep_NEW_FRAME rep_MAKE_INT(0) #define rep_USE_FUNARG(f) \ do { \ rep_env = rep_FUNARG(f)->env; \ rep_structure = rep_FUNARG(f)->structure; \ } while (0) #define rep_USE_DEFAULT_ENV \ do { \ rep_env = Qnil; \ rep_structure = rep_default_structure; \ } while (0) /* call history */ /* Keeps a backtrace of all lisp functions called. */ struct rep_Call { struct rep_Call *next; repv fun; repv args; repv current_form; /* used for debugging, set by progn */ repv saved_env; repv saved_structure; }; #define rep_PUSH_CALL(lc) \ do { \ (lc).current_form = rep_NULL; \ (lc).saved_env = rep_env; \ (lc).saved_structure = rep_structure; \ (lc).next = rep_call_stack; \ rep_call_stack = &(lc); \ } while (0) #define rep_POP_CALL(lc) \ do { \ rep_env = (lc).saved_env; \ rep_structure = (lc).saved_structure; \ rep_call_stack = (lc).next; \ } while (0) /* guardians */ typedef struct rep_guardian_struct { repv car; struct rep_guardian_struct *next; repv accessible; repv inaccessible; } rep_guardian; /* cons' */ #define rep_CONSBLK_SIZE 1022 /* ~8k */ /* Structure of cons allocation blocks */ typedef struct rep_cons_block_struct { union { struct rep_cons_block_struct *p; /* ensure that the following cons cell is aligned to at least sizeof (rep_cons) (for the dcache) */ rep_cons dummy; } next; rep_cons cons[rep_CONSBLK_SIZE]; } rep_cons_block; /* prototypes */ #include "repint_subrs.h" /* If using GCC, make inline_Fcons be Fcons that only takes a procedure call when the heap needs to grow. */ #if defined __GNUC__ && defined __OPTIMIZE__ extern __inline__ repv inline_Fcons (repv x, repv y); extern __inline__ repv inline_Fcons (repv x, repv y) { rep_cons *c = rep_cons_freelist; if (c == 0) c = rep_allocate_cons (); rep_cons_freelist = rep_CONS (c->cdr); rep_used_cons++; rep_data_after_gc += sizeof(rep_cons); c->car = (x); c->cdr = (y); return rep_CONS_VAL (c); } #else # define inline_Fcons Fcons #endif #endif /* REPINT_H */ librep-0.90.2/src/repgdbm.c0000644000175200017520000001432011245011153014431 0ustar chrischris/* repgdbm.c -- rep wrapper to libgdbm $Id$ */ #define _GNU_SOURCE #ifdef HAVE_CONFIG_H # include #endif #include "rep.h" #include #include static int dbm_type; #define rep_DBM(v) ((rep_dbm *) rep_PTR(v)) #define rep_DBMP(v) (rep_CELL16_TYPEP(v, dbm_type) && rep_DBM(v)->dbm != 0) typedef struct rep_dbm_struct { repv car; struct rep_dbm_struct *next; GDBM_FILE dbm; repv path; repv access; repv mode; } rep_dbm; static rep_dbm *dbm_chain; DEFSYM(insert, "insert"); DEFSYM(replace, "replace"); DEFSYM(no_lock, "no-lock"); DEFUN("gdbm-open", Fgdbm_open, Sgdbm_open, (repv file, repv type, repv mode, repv flags), rep_Subr4) /* ::doc:rep.io.db.gdbm#gdbm-open:: gdbm-open PATH ACCESS-TYPE [MODE] [FLAGS] ::end:: */ { int uflags = 0, umode; rep_dbm *dbm; rep_GC_root gc_type, gc_mode; /* only flag currently is `no-lock' */ #ifdef GDBM_NOLOCK if (rep_CONSP (flags) && rep_CAR (flags) == Qno_lock) uflags |= GDBM_NOLOCK; #endif rep_PUSHGC(gc_type, type); rep_PUSHGC(gc_mode, mode); file = Flocal_file_name (file); rep_POPGC; rep_POPGC; if (!file) return file; rep_DECLARE1(file, rep_STRINGP); rep_DECLARE2(type, rep_SYMBOLP); uflags |= (type == Qwrite ? GDBM_NEWDB : type == Qappend ? GDBM_WRCREAT : GDBM_READER); umode = rep_INTP(mode) ? rep_INT(mode) : 0666; dbm = rep_ALLOC_CELL (sizeof (rep_dbm)); if (dbm == 0) return rep_mem_error(); rep_data_after_gc += sizeof (rep_dbm); dbm->car = dbm_type; dbm->path = file; dbm->access = type; dbm->mode = rep_MAKE_INT(umode); dbm->dbm = gdbm_open (rep_STR(file), 0, uflags, umode, 0); if (dbm->dbm != 0) { dbm->next = dbm_chain; dbm_chain = dbm; return rep_VAL(dbm); } else { rep_FREE_CELL (dbm); return rep_signal_file_error (file); } } DEFUN("gdbm-close", Fgdbm_close, Sgdbm_close, (repv dbm), rep_Subr1) /* ::doc:rep.io.db.gdbm#gdbm-close:: gdbm-close DBM ::end:: */ { rep_DECLARE1 (dbm, rep_DBMP); gdbm_close (rep_DBM(dbm)->dbm); rep_DBM(dbm)->dbm = 0; rep_DBM(dbm)->path = Qnil; rep_DBM(dbm)->access = Qnil; rep_DBM(dbm)->mode = Qnil; return Qt; } DEFUN("gdbm-fetch", Fgdbm_fetch, Sgdbm_fetch, (repv dbm, repv key), rep_Subr2) /* ::doc:rep.io.db.gdbm#gdbm-fetch:: gdbm-fetch DBM KEY ::end:: */ { datum dkey, dvalue; rep_DECLARE1 (dbm, rep_DBMP); rep_DECLARE2 (key, rep_STRINGP); dkey.dptr = rep_STR (key); dkey.dsize = rep_STRING_LEN (key); dvalue = gdbm_fetch (rep_DBM(dbm)->dbm, dkey); if (dvalue.dptr == 0) return Qnil; else { /* The string isn't always zero-terminated, so need to copy it.. */ repv out = rep_string_dupn (dvalue.dptr, dvalue.dsize); free (dvalue.dptr); return out; } } DEFUN("gdbm-store", Fgdbm_store, Sgdbm_store, (repv dbm, repv key, repv val, repv flags), rep_Subr4) /* ::doc:rep.io.db.gdbm#gdbm-store:: gdbm-store DBM KEY VALUE [FLAGS] ::end:: */ { int dflags; datum dkey, dvalue; rep_DECLARE1 (dbm, rep_DBMP); rep_DECLARE2 (key, rep_STRINGP); rep_DECLARE3 (val, rep_STRINGP); dkey.dptr = rep_STR (key); dkey.dsize = rep_STRING_LEN (key); dvalue.dptr = rep_STR (val); dvalue.dsize = rep_STRING_LEN (val); dflags = (flags == Qinsert ? GDBM_INSERT : GDBM_REPLACE); return (gdbm_store (rep_DBM(dbm)->dbm, dkey, dvalue, dflags) == 0 ? Qt : Qnil); } DEFUN("gdbm-delete", Fgdbm_delete, Sgdbm_delete, (repv dbm, repv key), rep_Subr2) /* ::doc:rep.io.db.gdbm#gdbm-delete:: gdbm-delete DBM KEY ::end:: */ { datum dkey; rep_DECLARE1 (dbm, rep_DBMP); rep_DECLARE2 (key, rep_STRINGP); dkey.dptr = rep_STR (key); dkey.dsize = rep_STRING_LEN (key); return gdbm_delete (rep_DBM(dbm)->dbm, dkey) == 0 ? Qt : Qnil; } DEFUN("gdbm-walk", Fgdbm_walk, Sgdbm_walk, (repv fun, repv dbm), rep_Subr2) /* ::doc:rep.io.db.gdbm#gdbm-walk:: gdbm-walk FUN DBM ::end:: */ { rep_GC_root gc_dbm, gc_fun; repv ret = Qnil; datum dkey; rep_DECLARE1 (dbm, rep_DBMP); rep_PUSHGC (gc_dbm, dbm); rep_PUSHGC (gc_fun, fun); dkey = gdbm_firstkey (rep_DBM(dbm)->dbm); while (dkey.dptr) { if (!rep_call_lisp1 (fun, rep_string_dupn (dkey.dptr, dkey.dsize))) { ret = rep_NULL; free (dkey.dptr); break; } dkey = gdbm_nextkey (rep_DBM(dbm)->dbm, dkey); } rep_POPGC; rep_POPGC; return ret; } DEFUN("gdbmp", Fgdbmp, Sgdbmp, (repv arg), rep_Subr1) /* ::doc:rep.io.db.gdbm#gdbmp:: gdbmp ARG Returns t if ARG is an gdbm object (created by `gdbm-open'). ::end:: */ { return rep_DBMP(arg) ? Qt : Qnil; } static void dbm_mark (repv val) { rep_MARKVAL (rep_DBM(val)->path); rep_MARKVAL (rep_DBM(val)->access); rep_MARKVAL (rep_DBM(val)->mode); } static void dbm_sweep (void) { rep_dbm *x = dbm_chain; dbm_chain = 0; while (x != 0) { rep_dbm *next = x->next; if (!rep_GC_CELL_MARKEDP (rep_VAL(x))) { if (x->dbm != 0) gdbm_close (x->dbm); rep_FREE_CELL (x); } else { rep_GC_CLR_CELL (rep_VAL(x)); x->next = dbm_chain; dbm_chain = x; } x = next; } } static void dbm_print (repv stream, repv dbm) { rep_stream_puts (stream, "#path)) rep_stream_puts (stream, rep_PTR(rep_DBM(dbm)->path), -1, rep_TRUE); else rep_stream_puts (stream, "nil", -1, rep_FALSE); rep_stream_putc (stream, '>'); } static int dbm_compare (repv v1, repv v2) { return (v1 == v2) ? 0 : 1; } repv rep_dl_init (void) { repv tem; dbm_type = rep_register_new_type ("gdbm", dbm_compare, dbm_print, dbm_print, dbm_sweep, dbm_mark, 0, 0, 0, 0, 0, 0, 0); rep_INTERN (insert); rep_INTERN (replace); rep_INTERN (no_lock); tem = rep_push_structure ("rep.io.db.gdbm"); /* ::alias:gdbm rep.io.db.gdbm:: */ rep_alias_structure ("gdbm"); rep_ADD_SUBR(Sgdbm_open); rep_ADD_SUBR(Sgdbm_close); rep_ADD_SUBR(Sgdbm_fetch); rep_ADD_SUBR(Sgdbm_store); rep_ADD_SUBR(Sgdbm_delete); rep_ADD_SUBR(Sgdbm_walk); rep_ADD_SUBR(Sgdbmp); return rep_pop_structure (tem); } void rep_dl_kill (void) { rep_dbm *db; for (db = dbm_chain; db != 0; db = db->next) { if (db->dbm != 0) Fgdbm_close (rep_VAL (db)); } } librep-0.90.2/src/repdoc.c0000644000175200017520000000451211245011153014267 0ustar chrischris/* repdoc.c -- Program to strip doc-strings from C source Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include #include #include #include #include #ifndef GDBM_NOLOCK # define GDBM_NOLOCK 0 #endif static void usage(void) { fputs("usage: repdoc doc-file [src-files...]\n", stderr); exit(1); } static void scanfile(FILE *src, GDBM_FILE sdbm) { char buf[512]; while(fgets(buf, 512, src)) { char *start = strstr(buf, "::doc:"); if(start) { datum key, value; char buf[16384]; /* so lazy.. */ char *out = buf; char *id = start + 6; start = strstr (id, "::"); if (start == 0) continue; *start = 0; while(fgets(out, sizeof (buf) - (out - buf), src)) { char *end = strstr (out, "::end::"); if (end != 0) break; out += strlen(out); } /* ignore trailing newline */ if (out > buf) out--; *out = 0; key.dptr = id; key.dsize = strlen(id); value.dptr = buf; value.dsize = strlen(buf); if (gdbm_store (sdbm, key, value, GDBM_REPLACE) < 0) perror ("gdbm_store"); } } } int main(int ac, char **av) { GDBM_FILE docdbm; ac--; av++; if(ac < 2) usage(); docdbm = gdbm_open(*av++, 0, GDBM_WRCREAT | GDBM_NOLOCK, 0666, 0); ac--; if(docdbm == 0) { fprintf(stderr, "can't open output files.\n"); exit(2); } if(!ac) scanfile(stdin, docdbm); else { while(ac) { FILE *file = fopen(*av, "r"); if(file) { scanfile(file, docdbm); fclose(file); } ac--; av++; } } return 0; } librep-0.90.2/src/rep_subrs.h0000644000175200017520000006213711245011153015033 0ustar chrischris/* rep_subrs.h -- mostly LISP subr declarations Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #ifndef REP_SUBRS_H #define REP_SUBRS_H #include #ifndef inline #define inline #endif /* from continuations.c */ extern int rep_thread_lock; extern rep_bool rep_pending_thread_yield; extern repv rep_call_with_barrier (repv (*callback)(repv), repv arg, rep_bool closed, void (*in)(void *), void (*out)(void *), void *data); extern repv Fcall_cc (repv thunk); extern repv Fcontinuation_callable_p (repv cont); extern repv Fcall_with_object (repv arg, repv thunk); extern repv Fcall_with_dynamic_root (repv thunk); extern repv Fcall_with_barrier (repv thunk, repv closed, repv in, repv out); extern repv Fmake_thread (repv thunk, repv name); extern repv Fthread_yield (void); extern repv Fthread_delete (repv thread); extern repv Fthread_suspend (repv thread, repv msecs); extern repv Fthread_wake (repv thread); extern repv Ftheadp (repv arg); extern repv Fthread_suspended_p (repv thread); extern repv Fthread_exited_p (repv thread); extern repv Fcurrent_thread (repv depth); extern repv Fall_threads (repv depth); extern repv Fthread_forbid (void); extern repv Fthread_permit (void); extern repv Fthread_name (repv th); extern unsigned long rep_max_sleep_for (void); /* from datums.c */ extern repv Fmake_datum (repv, repv); extern repv Fdefine_datum_printer (repv, repv); extern repv Fdatum_ref (repv, repv); extern repv Fdatum_set (repv, repv, repv); extern repv Fhas_type_p (repv, repv); /* from debug-buffer.c */ extern void *rep_db_alloc(char *name, int size); extern void rep_db_free(void *db); extern void rep_db_vprintf(void *_db, char *fmt, va_list args); extern void rep_db_printf(void *db, char *fmt, ...); extern void rep_db_print_backtrace(void *_db, char *fun); extern void *rep_db_return_address(void); extern void rep_db_spew(void *_db); extern void rep_db_spew_all(void); extern void rep_db_kill(void); /* from files.c */ extern repv Qdefault_directory; extern repv Qstart, Qend; extern repv Qread, Qwrite, Qappend; extern repv rep_fh_env; extern int rep_file_type; extern int rep_op_write_buffer_contents; extern int rep_op_read_file_contents; extern int rep_op_insert_file_contents; extern repv rep_signal_file_error(repv cdr); extern repv rep_unbound_file_error(repv file); extern repv rep_get_file_handler(repv file_name, int op); extern repv rep_call_file_handler(repv handler, int op, repv sym, int nargs, ...); extern repv rep_get_handler_from_file_or_name(repv *filep, int op); extern repv rep_expand_and_get_handler(repv *file_namep, int op); extern repv rep_localise_and_get_handler(repv *file_namep, int op); extern rep_bool rep_file_newer_than(repv name1, repv name2); extern repv Ffile_name_absolute_p(repv file); extern repv Fexpand_file_name(repv, repv); extern repv Flocal_file_name(repv); extern repv Fcanonical_file_name(repv); extern repv Ffile_name_nondirectory(repv); extern repv Ffile_name_directory(repv); extern repv Ffile_name_as_directory(repv); extern repv Fdirectory_file_name(repv); extern repv Ffilep(repv arg); extern repv Ffile_binding(repv file); extern repv Ffile_bound_stream(repv file); extern repv Ffile_handler_data(repv); extern repv Fset_file_handler_data(repv, repv); extern repv Fopen_file(repv, repv); extern repv Fmake_file_from_stream(repv, repv, repv); extern repv Fclose_file(repv); extern repv Fflush_file(repv file); extern repv Fseek_file(repv file, repv offset, repv where); extern repv Fdelete_file(repv); extern repv Frename_file(repv, repv); extern repv Fmake_directory(repv); extern repv Fdelete_directory(repv); extern repv Fcopy_file(repv, repv); extern repv Ffile_readable_p(repv file); extern repv Ffile_writable_p(repv file); extern repv Ffile_exists_p(repv file); extern repv Ffile_regular_p(repv file); extern repv Ffile_directory_p(repv file); extern repv Ffile_symlink_p(repv file); extern repv Ffile_owner_p(repv file); extern repv Ffile_nlinks(repv file); extern repv Ffile_size(repv file); extern repv Ffile_modes(repv file); extern repv Fset_file_modes(repv file, repv modes); extern repv Ffile_modes_as_string(repv file); extern repv Ffile_modtime(repv file); extern repv Fdirectory_files(repv dir); extern repv Fread_symlink(repv file); extern repv Fmake_symlink(repv file, repv contents); extern repv Fstdin_file(void); extern repv Fstdout_file(void); extern repv Fstderr_file(void); extern repv Fmake_temp_name(void); extern repv rep_file_fdopen (int fd, char *mode); /* from find.c */ extern rep_regexp *rep_compile_regexp(repv re); extern void rep_push_regexp_data(struct rep_saved_regexp_data *sd); extern void rep_pop_regexp_data(void); extern void rep_update_last_match(repv data, rep_regexp *prog); extern void rep_set_string_match(repv obj, repv start, repv end); extern void (*rep_regsub_fun)(int, rep_regsubs *, char *, char *, void *); extern int (*rep_regsublen_fun)(int, rep_regsubs *, char *, void *); extern repv Qregexp_error; extern repv Fstring_match(repv re, repv str, repv start, repv nocasep); extern repv Fstring_looking_at(repv re, repv string, repv start, repv nocasep); extern repv Fexpand_last_match(repv template_); extern repv Fmatch_start(repv exp); extern repv Fmatch_end(repv exp); extern repv Fquote_regexp(repv str); extern repv Fregexp_cache_control(repv limit); extern void rep_regerror(char *err); /* from fluids.c */ extern repv Fmake_fluid (repv); extern repv Ffluid_ref (repv); extern repv Ffluid_set (repv, repv); extern repv Fwith_fluids (repv, repv, repv); /* from lisp.c */ extern repv rep_load_autoload(repv); extern repv rep_funcall(repv fun, repv arglist, rep_bool eval_args); extern repv rep_apply (repv, repv); extern repv rep_call_lisp0(repv); extern repv rep_call_lisp1(repv, repv); extern repv rep_call_lisp2(repv, repv, repv); extern repv rep_call_lisp3(repv, repv, repv, repv); extern repv rep_call_lisp4(repv, repv, repv, repv, repv); extern repv rep_call_lispn (repv fun, int argc, repv *argv); extern repv rep_handle_var_int(repv, int *); extern repv rep_handle_var_long_int(repv, long *); extern void rep_handle_error(repv, repv); extern repv rep_signal_arg_error(repv, int); extern repv rep_signal_missing_arg(int argnum); extern repv rep_mem_error(void); extern repv Qdebug_entry, Qdebug_exit, Qdebug_error_entry; extern repv Qquote, Qlambda, Qmacro, Qautoload, Qfunction; extern repv Qstandard_input, Qstandard_output; extern repv Qamp_optional, Qamp_rest, Qamp_aux; extern volatile repv rep_throw_value; extern repv rep_int_cell, rep_term_cell; extern repv Qerror, Qerror_message, Qinvalid_function; extern repv Qvoid_value, Qbad_arg, Qinvalid_read_syntax; extern repv Qend_of_stream, Qinvalid_lambda_list, Qmissing_arg; extern repv Qinvalid_macro, Qinvalid_autoload, Qno_catcher; extern repv Qfile_error; extern repv Qinvalid_stream, Qsetting_constant, Qprocess_error; extern repv Qno_memory, Quser_interrupt, Qarith_error; extern repv Qterm_interrupt; extern repv Qstack_error; extern repv Qprint_escape, Qprint_length, Qprint_level, Qnewlines; extern repv rep_env, rep_fenv, rep_special_bindings; extern struct rep_Call *rep_call_stack; extern int rep_lisp_depth, rep_max_lisp_depth; extern int rep_test_int_counter; extern int rep_test_int_period; extern void (*rep_test_int_fun)(void); extern repv Ffuncall(repv); extern repv Feval(repv); extern repv Fprogn(repv, repv); extern repv Fbreak(void); extern repv Fstep(repv); extern repv Fsignal(repv error, repv data); extern repv Fbacktrace(repv strm); extern repv Vmax_lisp_depth(repv val); extern int rep_list_length(repv); extern rep_bool rep_assign_args (repv list, int required, int total, ...); /* from lispcmds.c */ extern repv Qor, Qand; extern repv Qload_path, Qafter_load_alist, Qlisp_lib_directory; extern repv Qdl_load_path, Qdl_load_reloc_now, Qprovide, Qfeatures; extern repv Qsite_lisp_directory, Qdocumentation_file, Qdocumentation_files; extern repv Fquote(repv, repv); extern repv Fcar(repv); extern repv Fcdr(repv); extern repv Fmake_list(repv, repv); extern repv Fnconc(repv args); extern repv Frplaca(repv, repv); extern repv Frplacd(repv, repv); extern repv Freverse(repv); extern repv Fnreverse(repv); extern repv Fassoc(repv, repv); extern repv Fassq(repv, repv); extern repv Frassoc(repv, repv); extern repv Frassq(repv, repv); extern repv Fnth(repv, repv); extern repv Fnthcdr(repv index, repv list); extern repv Flast(repv); extern repv Fmapcar(repv, repv); extern repv Fmapc(repv, repv); extern repv Ffilter(repv pred, repv list); extern repv Fmember(repv, repv); extern repv Fmemq(repv, repv); extern repv Fmemql(repv, repv); extern repv Fdelete(repv, repv); extern repv Fdelq(repv, repv); extern repv Fdelete_if(repv, repv); extern repv Fdelete_if_not(repv, repv); extern repv Fmake_vector(repv, repv); extern repv Farrayp(repv); extern repv Faset(repv, repv, repv); extern repv Faref(repv, repv); extern repv Fmake_string(repv, repv); extern repv Fsubstring(repv string, repv start, repv end); extern repv Flength(repv); extern repv Fcopy_sequence(repv); extern repv Felt(repv, repv); extern repv Fcond(repv, repv); extern repv Fapply(repv); extern repv Fload(repv file, repv noerr_p, repv nopath_p, repv nosuf_p, repv in_env); extern repv Fequal(repv, repv); extern repv Feq(repv, repv); extern repv Fstring_head_eq(repv, repv); extern repv Fnull(repv); extern repv Fatom(repv); extern repv Fconsp(repv); extern repv Flistp(repv); extern repv Fstringp(repv); extern repv Fvectorp(repv); extern repv Fbytecodep(repv); extern repv Ffunctionp(repv); extern repv Fmacrop(repv); extern repv Fspecial_form_p(repv); extern repv Fsubrp(repv arg); extern repv Fsequencep(repv arg); extern repv FSdocumentation(repv subr, repv useVar); extern repv FSname(repv subr, repv useVar); extern repv Fcall_hook(repv hook, repv arg_list, repv type); extern repv Fthrow(repv, repv); /* from lispmach.c */ extern repv Qbytecode_error; extern repv Fvalidate_byte_code(repv bc_major, repv bc_minor); extern repv Fmake_byte_code_subr(repv args); /* from macros.c */ extern repv Fmacroexpand(repv, repv); /* from main.c */ extern void rep_init(char *prog_name, int *argc, char ***argv, void (*sys_symbols)(void), void (*sys_usage)(void)); extern void rep_init_from_dump(char *prog_name, int *argc, char ***argv, void (*sys_symbols)(void), void (*sys_usage)(void), char *dump_file); extern repv rep_load_environment (repv file); extern void rep_kill(void); extern rep_bool rep_get_option (char *option, repv *argp); extern rep_bool rep_on_idle(long since_last_event); extern rep_bool rep_handle_input_exception(repv *result_p); extern int rep_top_level_exit (void); extern void *rep_common_db; extern int rep_recurse_depth; extern rep_bool (*rep_on_idle_fun)(int since_last); extern repv (*rep_event_loop_fun)(void); extern repv Qidle_hook; extern void (*rep_on_termination_fun)(void); extern repv Qexit, Qquit, Qtop_level, Qcommand_line_args; extern repv Qbatch_mode, Qinterpreted_mode, Qprogram_name; extern repv Qerror_mode, Qinterrupt_mode; extern repv Frecursive_edit(void); extern repv rep_top_level_recursive_edit (void); extern repv Frecursion_depth(void); extern repv Fget_command_line_option (repv, repv); /* from message.c */ enum rep_message { rep_messagen = 0, rep_message, rep_messagef, rep_save_message, rep_append_message, rep_reset_message, rep_restore_message, rep_redisplay_message }; extern void (*rep_message_fun)(enum rep_message fn, ...); /* from misc.c */ extern char *rep_str_dupn(const char *old, int len); extern void (*rep_beep_fun)(void); extern repv Qoperating_system, Qwindow_system, Qprocess_environment; extern repv Qbuild_id_string; extern repv Qupcase_table, Qdowncase_table, Qflatten_table; extern repv Fbeep(void); extern repv Fcomplete_string(repv existing, repv arg_list, repv fold); extern repv Fcurrent_time(void); extern repv Ffix_time(repv time); extern repv Fcurrent_time_string(repv time, repv format); extern repv Ftime_later_p(repv t1, repv t2); extern repv Fsleep_for(repv secs, repv msecs); extern repv Fsit_for(repv secs, repv msecs); extern repv Fuser_login_name(void); extern repv Fuser_full_name(repv arg); extern repv Fuser_home_directory(repv user); extern repv Fsystem_name(void); extern repv Fmessage(repv string, repv now); extern repv Frandom(repv arg); extern repv Ftranslate_string(repv string, repv table); extern repv Falpha_char_p(repv); extern repv Fupper_case_p(repv); extern repv Flower_case_p(repv); extern repv Fdigit_char_p(repv); extern repv Falphanumericp(repv); extern repv Fspace_char_p(repv); extern repv Fchar_upcase(repv); extern repv Fchar_downcase(repv); /* from numbers.c */ extern repv rep_make_long_uint (unsigned long in); extern repv rep_make_long_int (long in); extern unsigned long rep_get_long_uint (repv in); extern long rep_get_long_int (repv in); extern repv rep_make_longlong_int (rep_long_long in); extern rep_long_long rep_get_longlong_int (repv in); extern repv rep_make_float (double in, rep_bool force); extern double rep_get_float (repv in); extern int rep_compare_numbers (repv n1, repv n2); extern char *rep_print_number_to_string (repv obj, int radix, int prec); extern repv rep_number_foldl (repv args, repv (*op)(repv, repv)); extern repv rep_integer_foldl (repv args, repv (*op)(repv, repv)); extern repv rep_foldl (repv args, repv (*op)(repv, repv)); extern repv rep_number_add (repv x, repv y); extern repv rep_number_neg (repv x); extern repv rep_number_sub (repv x, repv y); extern repv rep_number_mul (repv x, repv y); extern repv rep_number_div (repv x, repv y); extern repv rep_number_lognot (repv x); extern repv rep_number_logior (repv x, repv y); extern repv rep_number_logxor (repv x, repv y); extern repv rep_number_logand (repv x, repv y); extern repv rep_number_max (repv x, repv y); extern repv rep_number_min (repv x, repv y); extern repv rep_integer_gcd (repv x, repv y); extern repv Feql(repv arg1, repv arg2); extern repv Fremainder(repv n1, repv n2); extern repv Fmod(repv n1, repv n2); extern repv Fquotient(repv n1, repv n2); extern repv Flognot(repv); extern repv Fnot(repv); extern repv Fplus1(repv); extern repv Fsub1(repv); extern repv Fash(repv, repv); extern repv Ffloor (repv); extern repv Fceiling (repv); extern repv Ftruncate (repv); extern repv Fround (repv); extern repv Fexp (repv); extern repv Flog (repv); extern repv Fsin (repv); extern repv Fcos (repv); extern repv Ftan (repv); extern repv Fasin (repv); extern repv Facos (repv); extern repv Fatan (repv, repv); extern repv Fsqrt (repv); extern repv Fexpt (repv, repv); extern repv Fzerop(repv); extern repv Fnumberp(repv); extern repv Fintegerp(repv); extern repv Frationalp(repv); extern repv Frealp(repv); extern repv Fexactp(repv); extern repv Finexactp(repv); extern repv Fexact_to_inexact(repv); extern repv Finexact_to_exact(repv); extern repv Fnumerator(repv); extern repv Fdenominator(repv); /* from streams.c */ extern repv Qformat_hooks_alist; extern int rep_stream_getc(repv); extern int rep_stream_ungetc(repv, int); extern int rep_stream_putc(repv, int); extern int rep_stream_puts(repv, void *, int, rep_bool); extern int rep_stream_read_esc(repv, int *); extern repv Fwrite(repv stream, repv data, repv len); extern repv Fread_char(repv stream); extern repv Fpeek_char(repv stream); extern repv Fread_chars(repv stream, repv count); extern repv Fread_line(repv stream); extern repv Fcopy_stream(repv source, repv dest); extern repv Fread(repv); extern repv Fprint(repv, repv); extern repv Fprin1(repv, repv); extern repv Fprinc(repv, repv); extern repv Fformat(repv); extern repv Fmake_string_input_stream(repv string, repv start); extern repv Fmake_string_output_stream(void); extern repv Fget_output_stream_string(repv strm); extern repv Finput_stream_p(repv arg); extern repv Foutput_stream_p(repv arg); /* from symbols.c */ extern repv rep_undefined_value; extern repv (*rep_deref_local_symbol_fun)(repv sym); extern repv (*rep_set_local_symbol_fun)(repv sym, repv val); extern void rep_intern_static(repv *, repv); extern repv rep_call_with_closure (repv closure, repv (*fun)(repv arg), repv arg); extern repv rep_bind_symbol(repv, repv, repv); extern int rep_unbind_symbols(repv); extern repv rep_add_binding_to_env (repv env, repv sym, repv value); extern repv rep_obarray; extern repv Qt; extern repv Qvariable_documentation, Qpermanent_local; extern repv rep_void_value; extern rep_bool rep_warn_shadowing; extern repv Fmake_symbol(repv); extern repv Fmake_obarray(repv); extern repv Ffind_symbol(repv, repv); extern repv Fintern_symbol(repv, repv); extern repv Fintern(repv, repv); extern repv Funintern(repv, repv); extern repv Fmake_closure (repv function, repv name); extern repv Fclosure_function (repv funarg); extern repv Fset_closure_function (repv funarg, repv fun); extern repv Fclosurep (repv arg); extern repv Fsymbol_value(repv, repv); extern repv Fdefvar(repv, repv); extern repv Fset(repv, repv); extern repv Fsetplist(repv, repv); extern repv Fsymbol_name(repv); extern repv Fdefault_value(repv, repv); extern repv Fdefault_boundp(repv); extern repv Fset_default(repv, repv); extern repv Fboundp(repv); extern repv Fsymbol_plist(repv); extern repv Fgensym(void); extern repv Fsymbolp(repv); extern repv Fsetq(repv, repv); extern repv Fmakunbound(repv); extern repv Fget(repv, repv); extern repv Fput(repv, repv, repv); extern repv Fapropos(repv, repv, repv); extern repv Fmake_variable_special (repv sym); extern repv Fspecial_variable_p(repv sym); extern repv Ftrace(repv sym); extern repv Funtrace(repv sym); extern repv Vobarray(repv val); extern repv Fmake_keyword (repv in); extern repv Fkeywordp (repv arg); /* from structures.c */ extern repv rep_structure; extern repv Fmake_binding_immutable (repv); extern repv Fbinding_immutable_p (repv, repv); extern repv Fexport_bindings (repv list); extern repv Ffeaturep(repv); extern repv Fprovide(repv); extern repv Frequire(repv); extern repv rep_push_structure_name (repv name); extern repv rep_push_structure (const char *name); extern repv rep_pop_structure (repv old); extern void rep_alias_structure (const char *name); extern repv rep_bootstrap_structure (const char *s); extern repv rep_add_subr(rep_xsubr *, rep_bool); extern void rep_structure_exports_all (repv s, rep_bool status); extern void rep_structure_set_binds (repv s, rep_bool status); /* from tuples.c */ extern repv rep_make_tuple (repv car, repv a, repv b); extern void rep_mark_tuple (repv t); /* from values.c */ extern repv Qafter_gc_hook; extern rep_cons *rep_dumped_cons_start, *rep_dumped_cons_end; extern rep_symbol *rep_dumped_symbols_start, *rep_dumped_symbols_end; extern repv rep_dumped_non_constants; extern int rep_guardian_type; extern repv rep_box_pointer (void *p); void *rep_unbox_pointer (repv v); extern void rep_register_type(unsigned int code, char *name, int (*compare)(repv, repv), void (*princ)(repv, repv), void (*print)(repv, repv), void (*sweep)(void), void (*mark)(repv), void (*mark_type)(void), int (*getc)(repv), int (*ungetc)(repv, int), int (*putc)(repv, int), int (*puts)(repv, void *, int, rep_bool), repv (*bind)(repv), void (*unbind)(repv)); extern unsigned int rep_register_new_type(char *name, int (*compare)(repv, repv), void (*princ)(repv, repv), void (*print)(repv, repv), void (*sweep)(void), void (*mark)(repv), void (*mark_type)(void), int (*getc)(repv), int (*ungetc)(repv, int), int (*putc)(repv, int), int (*puts)(repv, void *, int, rep_bool), repv (*bind)(repv), void (*unbind)(repv)); extern rep_type *rep_get_data_type(unsigned int code); extern int rep_value_cmp(repv, repv); extern void rep_princ_val(repv, repv); extern void rep_print_val(repv, repv); extern repv rep_null_string(void); extern repv rep_box_string (char *ptr, long len); extern repv rep_make_string(long); extern repv rep_string_dupn(const char *, long); extern repv rep_string_dup(const char *); extern repv rep_concat2(char *, char *); extern repv rep_concat3(char *, char *, char *); extern repv rep_concat4(char *s1, char *s2, char *s3, char *s4); extern rep_bool rep_set_string_len(repv, long); extern repv rep_list_1(repv); extern repv rep_list_2(repv, repv); extern repv rep_list_3(repv, repv, repv); extern repv rep_list_4(repv, repv, repv, repv); extern repv rep_list_5(repv, repv, repv, repv, repv); extern repv rep_make_vector(int); extern repv Fmake_primitive_guardian (void); extern repv Fprimitive_guardian_push (repv g, repv obj); extern repv Fprimitive_guardian_pop (repv g); extern void rep_mark_static(repv *); extern void rep_mark_value(repv); extern repv Fcons(repv, repv); extern rep_GC_root *rep_gc_root_stack; extern rep_GC_n_roots *rep_gc_n_roots_stack; extern repv Vgarbage_threshold(repv val); extern repv Vidle_garbage_threshold(repv val); extern repv Fgarbage_collect(repv noStats); extern int rep_data_after_gc, rep_gc_threshold, rep_idle_gc_threshold; extern rep_bool rep_in_gc; #ifdef rep_HAVE_UNIX /* from unix_dl.c */ extern rep_bool rep_find_c_symbol(void *, char **, void **); extern void *rep_find_dl_symbol (repv feature, char *symbol); /* from unix_files.c */ extern repv rep_lookup_errno(void); extern unsigned long rep_file_length(repv file); /* from unix_main.c */ extern unsigned long rep_time(void); extern rep_long_long rep_utime (void); extern unsigned long rep_getpid (void); extern void (*rep_register_input_fd_fun)(int fd, void (*callback)(int fd)); extern void (*rep_deregister_input_fd_fun)(int fd); extern void rep_add_event_loop_callback (rep_bool (*callback)(void)); extern void rep_sleep_for(long secs, long msecs); extern void rep_register_input_fd(int fd, void (*callback)(int fd)); extern void rep_deregister_input_fd(int fd); extern void rep_map_inputs (void (*fun)(int fd, void (*callback)(int))); extern void rep_mark_input_pending(int fd); extern void rep_unix_set_fd_nonblocking(int fd); extern void rep_unix_set_fd_blocking(int fd); extern void rep_unix_set_fd_cloexec(int fd); extern void rep_sig_restart(int sig, rep_bool flag); extern repv rep_event_loop(void); extern repv rep_sit_for(unsigned long timeout_msecs); extern repv rep_accept_input_for_callbacks (unsigned long timeout_msecs, int ncallbacks, void (**callbacks)(int)); extern repv rep_accept_input_for_fds (unsigned long timeout_msecs, int nfds, int *fds); extern repv rep_accept_input(unsigned long timeout_msecs, void (*callback)(int)); extern rep_bool rep_poll_input(int fd); #ifdef DEBUG_SYS_ALLOC extern void *rep_alloc(unsigned int length); extern void *rep_realloc(void *ptr, unsigned int length); extern void rep_free(void *ptr); extern void rep_print_allocations(void); #else # include # define rep_alloc(n) malloc(n) # define rep_realloc(p,n) realloc(p,n) # define rep_free(p) free(p) #endif extern void (*rep_redisplay_fun)(void); extern long (*rep_wait_for_input_fun)(void *inputs, unsigned long timeout_msecs); extern int rep_input_timeout_secs; extern repv Funix_print_allocations(void); /* from unix_processes.c */ extern repv Qpipe, Qpty; extern void (*rep_sigchld_fun) (void); extern rep_bool rep_proc_periodically(void); extern repv Fmake_process(repv stream, repv fun, repv dir, repv prog, repv args); extern repv Fstart_process(repv arg_list); extern repv Fcall_process(repv arg_list); extern repv Finterrupt_process(repv proc, repv grp); extern repv Fkill_process(repv proc, repv grp); extern repv Fstop_process(repv proc, repv grp); extern repv Fcontinue_process(repv proc, repv grp); extern repv Fprocess_exit_status(repv proc); extern repv Fprocess_exit_value(repv proc); extern repv Fprocess_id(repv proc); extern repv Fprocess_running_p(repv proc); extern repv Fprocess_stopped_p(repv proc); extern repv Fprocess_in_use_p(repv proc); extern repv Fprocessp(repv arg); extern repv Fprocess_prog(repv proc); extern repv Fset_process_prog(repv proc, repv prog); extern repv Fprocess_args(repv proc); extern repv Fset_process_args(repv proc, repv args); extern repv Fprocess_output_stream(repv proc); extern repv Fset_process_output_stream(repv proc, repv stream); extern repv Fprocess_error_stream(repv proc); extern repv Fset_process_error_stream(repv proc, repv stream); extern repv Fprocess_function(repv proc); extern repv Fset_process_function(repv proc, repv fn); extern repv Fprocess_dir(repv proc); extern repv Fset_process_dir(repv proc, repv dir); extern repv Fprocess_connection_type(repv proc); extern repv Fset_process_connection_type(repv proc, repv type); extern repv Factive_processes(void); extern repv Faccept_process_output(repv secs, repv msecs); void rep_register_process_input_handler (void (*handler)(int)); #endif /* rep_HAVE_UNIX */ /* in plugins */ extern repv rep_dl_init (void); extern void rep_dl_kill (void); #endif /* REP_SUBRS_H */ librep-0.90.2/src/rep_regexp.h0000644000175200017520000001341111245011153015156 0ustar chrischris/* * Definitions etc. for regexp(3) routines. * * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], * not the System V one. */ #ifndef REP_REGEXP_H #define REP_REGEXP_H #define rep_NSUBEXP 10 typedef enum rep_regtype { rep_reg_string = 0, rep_reg_obj } rep_regtype; typedef union rep_regsubs { struct { char *startp[rep_NSUBEXP]; char *endp[rep_NSUBEXP]; } string; struct { repv startp[rep_NSUBEXP]; repv endp[rep_NSUBEXP]; } obj; } rep_regsubs; typedef struct rep_regexp { rep_regtype lasttype; rep_regsubs matches; char regstart; /* Internal use only. */ char reganch; /* Internal use only. */ char *regmust; /* Internal use only. */ int regmlen; /* Internal use only. */ int regsize; /* actual size of regexp structure */ char program[1]; /* Unwarranted chumminess with compiler. */ } rep_regexp; /* Data structure used to save and restore regexp data internally */ struct rep_saved_regexp_data { struct rep_saved_regexp_data *next; rep_regtype type; repv data; rep_regsubs matches; }; /* eflags for regexec2() */ #define rep_REG_NOTBOL 1 /* start of input isn't start of line */ #define rep_REG_NOCASE 2 /* fold upper and lower case */ #define rep_REG_1LINE 4 /* for regexec_tx: only search to the end of the line for the start of the match. */ #define rep_regexec(p,s) rep_regexec2(p,s,0) extern rep_regexp *rep_regcomp(char *); extern int rep_regexec2(rep_regexp *, char *, int); extern int rep_regmatch_string(rep_regexp *, char *, int); extern int rep_regexp_max_depth; /* Only include the internal stuff if it's explicitly requested, since it comtaminates the namespace.. */ #ifdef rep_NEED_REGEXP_INTERNALS /* * Structure for regexp "program". This is essentially a linear encoding of * a nondeterministic finite-state machine (aka syntax charts or "railroad * normal form" in parsing technology). Each node is an opcode plus a "next" * pointer, possibly plus an operand. "Next" pointers of all nodes except * BRANCH implement concatenation; a "next" pointer with a BRANCH on both * ends of it is connecting two alternatives. (Here we have one of the * subtle syntax dependencies: an individual BRANCH (as opposed to a * collection of them) is never concatenated with anything because of * operator precedence.) The operand of some types of node is a literal * string; for others, it is a node leading into a sub-FSM. In particular, * the operand of a BRANCH node is the first node of the branch. (NB this is * *not* a tree structure: the tail of the branch connects to the thing * following the set of BRANCHes.) The opcodes are: */ /* definition number opnd? meaning */ #define END 0 /* no End of program. */ #define BOL 1 /* no Match "" at beginning of line. */ #define EOL 2 /* no Match "" at end of line. */ #define ANY 3 /* no Match any one character. */ #define ANYOF 4 /* str Match any character in this string. */ #define ANYBUT 5 /* str Match any character not in this * string. */ #define BRANCH 6 /* node Match this alternative, or the * next... */ #define BACK 7 /* no Match "", "next" ptr points backward. */ #define EXACTLY 8 /* str Match this string. */ #define NOTHING 9 /* no Match empty string. */ #define STAR 10 /* node Match this (simple) thing 0 or more * times. */ #define PLUS 11 /* node Match this (simple) thing 1 or more * times. */ #define WORD 12 /* no Match alphanumeric or _ char */ #define NWORD 13 /* no Match non-(alphanumeric or _) char */ #define WSPC 14 /* no Match whitespace char */ #define NWSPC 15 /* no Match non-whitespace char */ #define DIGI 16 /* no Match digit char */ #define NDIGI 17 /* no Match non-digit char */ #define WEDGE 18 /* no Match "" at word boundary */ #define NWEDGE 19 /* no Match "" not at word boundary */ #define OPEN 20 /* no Mark this point in input as start of * #n. */ /* OPEN+1 is number 1, etc. */ #define CLOSE 30 /* no Analogous to OPEN. */ #define NGSTAR 40 /* node Match this (simple) thing 0 or more times (non-greedily) */ #define NGPLUS 41 /* node Match this (simple) thing 1 or more times (non-greedily) */ /* * Opcode notes: * * BRANCH The set of branches constituting a single choice are hooked together * with their "next" pointers, since precedence prevents anything being * concatenated to any individual branch. The "next" pointer of the last * BRANCH in a choice points to the thing following the whole choice. This * is also where the final "next" pointer of each individual branch points; * each branch starts with the operand node of a BRANCH node. * * BACK Normal "next" pointers all implicitly point forward; BACK exists to * make loop structures possible. * * STAR,PLUS '?', and complex '*' and '+', are implemented as circular * BRANCH structures using BACK. Simple cases (one character per match) are * implemented with STAR and PLUS for speed and to minimize recursive * plunges. * * OPEN,CLOSE ...are numbered at compile time. */ /* * A node is one char of opcode followed by two chars of "next" pointer. * "Next" pointers are stored as two 8-bit pieces, high order first. The * value is a positive offset from the opcode of the node containing it. An * operand, if any, simply follows the node. (Note that much of the code * generation knows about this implicit relationship.) * * Using two bytes for the "next" pointer is vast overkill for most things, but * allows patterns to get big without disasters. */ #define OP(p) (*(p)) #define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) #define OPERAND(p) ((p) + 3) /* * The first byte of the regexp internal "program" is actually this magic * number; the start node begins in the second byte. */ #define MAGIC 0234 #endif /* rep_NEED_REGEXP_INTERNALS */ #endif /* REP_REGEXP_H */ librep-0.90.2/src/rep_lisp.h0000644000175200017520000007216411245011153014645 0ustar chrischris/* rep_lisp.h -- Data structures/objects for Lisp Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* library-private definitions are in repint.h */ #ifndef REP_LISP_H #define REP_LISP_H #include /* Stringify X. Expands macros in X. */ #define rep_QUOTE(x) rep_QUOTE__(x) #define rep_QUOTE__(x) #x /* Concat two tokens. Expands macros in X and Y. */ #define rep_CONCAT(x, y) rep_CONCAT__(x, y) #define rep_CONCAT__(x, y) x##y /* Lisp values. */ /* A `repv' is a lisp value, perhaps a pointer to an object, but not a real pointer; it's two lowest bits define its type. */ typedef unsigned rep_PTR_SIZED_INT repv; /* The number of bits in the lisp value type. */ #define rep_VALUE_BITS rep_PTR_SIZED_INT_BITS /* Get the integer constant X in the lisp value type */ #define rep_VALUE_CONST(x) rep_CONCAT(x, rep_PTR_SIZED_INT_SUFFIX) /* Structure of Lisp objects and the pointers to them. */ /* Bit definitions for repv pointers. The lowest bit is always zero except during GC. If bit one is set the object is a 30-bit signed integer, with the data bits stored in the pointer as bits 2->31. Otherwise (i.e. bit 1 of the pointer is clear), the value is a pointer to a "cell"; all objects other than integers are represented by various types of cells. Every cell has a repv as its first element (called the car), the lowest bits of this define the actual type of the cell. If bit zero of the car is unset, the cell is a cons, a pair of two values the car and the cdr (the GC mark bit of the cons is bit zero of the cdr). If bit zero of the car is set, then further type information is stored in bits 1->5 of the car, with bit 5 used to denote statically allocated objects and bit 7 the mark bit. So there are 2^4 possible types of cells. This isn't enough, so bit 6 of the car is used to denote a ``cell16'' type -- a cell in which bits 8->15 give the actual type. These cell16 types are allocated dynamically. Note that some assumptions are made about data object alignment. All Lisp cells _must_ be aligned to four-byte boundaries. If using GNU CC, we'll use the alignment attribute. Otherwise the rep_ALIGN macro needs setting.. */ #define rep_VALUE_CONS_MARK_BIT 1 #define rep_VALUE_IS_INT 2 #define rep_VALUE_INT_SHIFT 2 #define rep_CELL_ALIGNMENT rep_PTR_SIZED_INT_SIZEOF #if rep_CELL_ALIGNMENT <= rep_MALLOC_ALIGNMENT /* Allocate SIZE bytes of memory, aligned to NORMAL_ALIGNMENT */ # define rep_ALLOC_CELL(n) rep_alloc(n) /* Free something allocated by rep_ALLOC_CELL */ # define rep_FREE_CELL(x) rep_free(x) #else # error "Need an aligned memory allocator" #endif /* A ``null pointer'', i.e. an invalid object. This has the important property of being a proper null pointer (i.e. (void *)0) when converted to a pointer, i.e. rep_PTR(rep_NULL) == NULL. */ #define rep_NULL (0) /* Align the variable or struct member D to the necessary cell alignment. This is used like: ``rep_ALIGN_CELL(rep_cell foo) = ...'' */ #ifdef __GNUC__ # define rep_ALIGN_CELL(d) d __attribute__ ((aligned (rep_CELL_ALIGNMENT))) #elif defined (__digital__) && defined (__unix__) && defined (__DECC) # if rep_CELL_ALIGNMENT >= rep_PTR_SIZED_INT_SIZEOF /* "the C compiler aligns an int (32 bits) on a 4-byte boundary and a long (64 bits) on an 8-byte boundary" (Tru64 Programmer's Guide) */ # define rep_ALIGN_CELL(d) d # else # error "You need to fix alignment for Tru64" # endif #else /* # warning Lets hope your compiler aligns to 4 byte boundaries.. */ # define rep_ALIGN_CELL(d) d #endif /* Is repv V a cell type? */ #define rep_CELLP(v) (((v) & rep_VALUE_IS_INT) == 0) /* Is repv V a fixnum? */ #define rep_INTP(v) (!rep_CELLP(v)) /* Convert a repv into a signed integer. */ #define rep_INT(v) (((rep_PTR_SIZED_INT)(v)) \ >> rep_VALUE_INT_SHIFT) /* Convert a signed integer into a repv. */ #define rep_MAKE_INT(x) (((x) << rep_VALUE_INT_SHIFT) \ | rep_VALUE_IS_INT) /* Bounds of the integer type */ #define rep_LISP_INT_BITS (rep_VALUE_BITS - rep_VALUE_INT_SHIFT) #define rep_LISP_MAX_INT ((rep_VALUE_CONST(1) \ << (rep_LISP_INT_BITS - 1)) - 1) #define rep_LISP_MIN_INT (-(rep_VALUE_CONST(1) \ << (rep_LISP_INT_BITS - 1))) /* backwards compatibility */ #define rep_MAKE_LONG_INT(x) rep_make_long_int(x) #define rep_LONG_INT(v) rep_get_long_int(v) #define rep_LONG_INTP(v) \ (rep_INTEGERP(v) \ || (rep_CONSP(v) && rep_INTP(rep_CAR(v)) && rep_INTP(rep_CDR(v)))) /* Structure of a cell */ typedef struct { /* Low bits of this value define type of the cell. See below. All other bits (8->31) are available */ repv car; /* Data follows, in real objects. */ } rep_cell; /* If bit zero is set in the car of a cell, bits 1->4 of the car are type data, bit 5 denotes a cell16 type, bit 6 is set if the object is allocated statically, bit 7 is the GC mark bit. This means a maximum of 2^3, i.e. 16, cell8 types. cell16 types have eight extra type bits, bits 8->15, this gives 256 dynamically allocated type codes: [256 k + 0x21 | k <- [0..255]]. */ #define rep_CELL_IS_8 0x01 #define rep_CELL_IS_16 0x20 #define rep_CELL_STATIC_BIT 0x40 #define rep_CELL_MARK_BIT 0x80 #define rep_CELL8_TYPE_MASK 0x3f #define rep_CELL8_TYPE_BITS 8 #define rep_CELL16_TYPE_MASK 0xff21 /* is8 and is16 bits set */ #define rep_CELL16_TYPE_SHIFT 8 #define rep_CELL16_TYPE_BITS 16 /* Build a `rep_cell *' pointer out of a repv of a normal type */ #define rep_PTR(v) ((rep_cell *)(v)) /* Build a repv out of a pointer to a Lisp_Normal object */ #define rep_VAL(x) ((repv)(x)) /* Is V of cell8 type? */ #define rep_CELL8P(v) (rep_PTR(v)->car & rep_CELL_IS_8) /* Is V a cons? */ #define rep_CELL_CONS_P(v) (!rep_CELL8P(v)) /* Is V statically allocated? */ #define rep_CELL_STATIC_P(v) (rep_PTR(v)->car & rep_CELL_STATIC_BIT) /* Is V not an integer or cons? */ #define rep_CELL8_TYPE(v) (rep_PTR(v)->car & rep_CELL8_TYPE_MASK) /* Get the actual cell8 type of V to T */ #define rep_SET_CELL8_TYPE(v, t) \ (rep_PTR(v)->car = (rep_PTR(v)->car & rep_CELL8_TYPE_MASK) | (t)) /* Is V of cell16 type? */ #define rep_CELL16P(v) (rep_PTR(v)->car & rep_CELL_IS_16) /* Get the actual cell16 type of V */ #define rep_CELL16_TYPE(v) (rep_PTR(v)->car & rep_CELL16_TYPE_MASK) /* Set the actual cell16 type of V to T */ #define rep_SET_CELL16_TYPE(v, t) \ (rep_PTR(v)->car = (rep_PTR(v)->car & rep_CELL16_TYPE_MASK) | (t)) /* Structure of a cons cell, the only non-cell8 ptr type */ typedef struct { repv car; repv cdr; /* low bit is GC mark */ } rep_cons; #define rep_CONSP(v) (rep_CELLP(v) && rep_CELL_CONS_P(v)) /* Build a repv out of a pointer to a rep_cons object */ #define rep_CONS_VAL(x) rep_VAL(x) /* Get a pointer to a cons cell from a repv. */ #define rep_CONS(v) ((rep_cons *) rep_PTR(v)) /* Get the car or cdr from a cons repv. */ #define rep_CAR(v) (rep_CONS(v)->car) #define rep_CDR(v) (rep_CONS(v)->cdr) #define rep_CDRLOC(v) (&(rep_CONS(v)->cdr)) /* Get the cdr when GC is in progress. */ #define rep_GCDR(v) (rep_CDR(v) & ~rep_VALUE_CONS_MARK_BIT) /* True if cons cell V is mutable (i.e. not read-only). */ #define rep_CONS_WRITABLE_P(v) \ (! (rep_CONS(v) >= rep_dumped_cons_start \ && rep_CONS(v) < rep_dumped_cons_end)) /* Type data */ /* Information about each type */ typedef struct rep_type_struct { struct rep_type_struct *next; char *name; unsigned int code; /* Compares two values, rc is similar to strcmp() */ int (*compare)(repv val1, repv val2); /* Prints a textual representation of the object, not necessarily in a read'able format */ void (*princ)(repv stream, repv obj); /* Prints a textual representation of the object, if possible in a read'able format */ void (*print)(repv stream, repv obj); /* When non-null, a function that should be called during the sweep phase of garbage collection. */ void (*sweep)(void); /* When non-null, a function to mark OBJ and all objects it references. */ void (*mark)(repv obj); /* When called, should mark any objects that must persist across the GC, no matter what. */ void (*mark_type)(void); /* When non-null, functions called for the stream OBJ. */ int (*getc)(repv obj); int (*ungetc)(repv obj, int c); int (*putc)(repv obj, int c); int (*puts)(repv obj, void *data, int length, rep_bool lisp_obj_p); /* When non-null, a function to ``bind'' to OBJ temporarily, returning some handle for later unbinding. */ repv (*bind)(repv obj); /* When non-null, a function to ``unbind'' OBJ, the result of the earlier bind call. */ void (*unbind)(repv obj); } rep_type; /* Each type of Lisp object has a type code associated with it. Note how non-cons cells are given odd values, so that the rep_CELL_IS_8 bit doesn't have to be masked out. */ #define rep_Cons 0x00 /* made up */ #define rep_Symbol 0x01 #define rep_Int 0x02 /* made up */ #define rep_Vector 0x03 #define rep_String 0x05 #define rep_Compiled 0x07 #define rep_Void 0x09 #define rep_Reserved 0x0b #define rep_Number 0x0d #define rep_SF 0x0f #define rep_Subr0 0x11 #define rep_Subr1 0x13 #define rep_Subr2 0x15 #define rep_Subr3 0x17 #define rep_Subr4 0x19 #define rep_Subr5 0x1b #define rep_SubrN 0x1d #define rep_Funarg 0x1f /* Assuming that V is a cell, return the type code */ #define rep_CELL_TYPE(v) (rep_CONSP(v) ? rep_Cons \ : !rep_CELL16P(v) ? rep_CELL8_TYPE(v) \ : rep_CELL16_TYPE(v)) /* Return a type code given a repv */ #define rep_TYPE(v) (rep_INTP(v) ? rep_Int : rep_CELL_TYPE(v)) /* true if V is of type T (T must be a cell8 type) */ #define rep_CELL8_TYPEP(v, t) \ (rep_CELLP(v) && rep_CELL8_TYPE(v) == (t)) #define rep_CELL16_TYPEP(v, t) \ (rep_CELLP(v) && rep_CELL16_TYPE(v) == (t)) /* true if V is of type T. */ #define rep_TYPEP(v, t) (rep_TYPE(v) == t) /* tuples, cells containing two values */ typedef struct { repv car; repv a, b; } rep_tuple; #define rep_TUPLE(v) ((rep_tuple *) rep_PTR (v)) /* Numbers (private defs in numbers.c) */ /* Is V a non-fixnum number? */ #define rep_NUMBERP(v) rep_CELL8_TYPEP(v, rep_Number) /* Is V numeric? */ #define rep_NUMERICP(v) (rep_INTP(v) || rep_NUMBERP(v)) /* bits 8-9 of car define number type (except when on freelist) */ typedef rep_cell rep_number; /* these are in order of promotion */ #define rep_NUMBER_INT 0 /* faked */ #define rep_NUMBER_BIGNUM 0x100 #define rep_NUMBER_RATIONAL 0x200 #define rep_NUMBER_FLOAT 0x400 #define rep_NUMBER_TYPE(v) (((rep_number *)rep_PTR(v))->car & 0x700) #define rep_NUMBER_BIGNUM_P(v) (rep_NUMBER_TYPE(v) & rep_NUMBER_BIGNUM) #define rep_NUMBER_RATIONAL_P(v) (rep_NUMBER_TYPE(v) & rep_NUMBER_RATIONAL) #define rep_NUMBER_FLOAT_P(v) (rep_NUMBER_TYPE(v) & rep_NUMBER_FLOAT) #define rep_NUMERIC_TYPE(v) \ (rep_INTP(v) ? rep_NUMBER_INT : rep_NUMBER_TYPE(v)) #define rep_INTEGERP(v) \ (rep_INTP(v) || (rep_NUMBERP(v) && rep_NUMBER_BIGNUM_P(v))) /* Strings */ typedef struct rep_string_struct { /* Bits 0->7 are standard cell8 defines. Bits 8->31 store the length of the string. This means that strings can't contain more than 2^24-1 bytes (thats about 16.7MB) */ repv car; /* Pointer to the (zero-terminated) characters */ char *data; } rep_string; #define rep_STRING_LEN_SHIFT 8 #define rep_MAX_STRING \ ((rep_VALUE_CONST(1) << (rep_VALUE_BITS - rep_STRING_LEN_SHIFT)) - 1) #define rep_STRINGP(v) rep_CELL8_TYPEP(v, rep_String) #define rep_STRING(v) ((rep_string *) rep_PTR(v)) #define rep_STRING_LEN(v) (rep_STRING(v)->car >> rep_STRING_LEN_SHIFT) #define rep_MAKE_STRING_CAR(len) (((len) << rep_STRING_LEN_SHIFT) | rep_String) /* True if this string may be written to; generally static strings are made from C string-constants and usually in read-only storage. */ #define rep_STRING_WRITABLE_P(s) (!rep_CELL_STATIC_P(s)) /* Define a variable V, containing a static string S. This must be cast to a repv via the rep_VAL() macro when using. */ #define DEFSTRING(v, s) \ rep_ALIGN_CELL(static const rep_string v) = { \ ((sizeof(s) - 1) << rep_STRING_LEN_SHIFT) \ | rep_CELL_STATIC_BIT | rep_String, \ (char *)s \ } #define rep_STR(v) (rep_STRING(v)->data) /* Use this to get a newline into a DEFSTRING */ #define rep_DS_NL "\n" /* Symbols */ /* symbol object, actual allocated as a tuple */ typedef struct { repv car; /* bits 8->11 are flags */ repv next; /* next symbol in rep_obarray bucket */ repv name; } rep_symbol; #define rep_SF_KEYWORD (1 << (rep_CELL8_TYPE_BITS + 0)) /* Means that the symbol's value may be in some form of local storage, if so then that occurrence takes precedence. */ #define rep_SF_LOCAL (1 << (rep_CELL8_TYPE_BITS + 1)) /* This means that setting the value of the symbol always sets the local value, even if one doesn't already exist. */ #define rep_SF_SET_LOCAL (1 << (rep_CELL8_TYPE_BITS + 2)) /* When a function is evaluated whose symbol has this bit set, the next evaluated form will invoke the Lisp debugger. */ #define rep_SF_DEBUG (1 << (rep_CELL8_TYPE_BITS + 3)) /* Dynamically bound */ #define rep_SF_SPECIAL (1 << (rep_CELL8_TYPE_BITS + 4)) /* A special, but was first set from an environment in which specials can't normally be accessed; if the symbol is later defvar'd its original value will be overwritten. */ #define rep_SF_WEAK (1 << (rep_CELL8_TYPE_BITS + 5)) /* A variable that was weak, but has been modified via defvar from an unrestricted special environment */ #define rep_SF_WEAK_MOD (1 << (rep_CELL8_TYPE_BITS + 6)) /* Set when the variable has been defvar'd */ #define rep_SF_DEFVAR (1 << (rep_CELL8_TYPE_BITS + 7)) #define rep_SF_LITERAL (1 << (rep_CELL8_TYPE_BITS + 8)) #define rep_SYM(v) ((rep_symbol *)rep_PTR(v)) #define rep_SYMBOLP(v) rep_CELL8_TYPEP(v, rep_Symbol) #define rep_NILP(v) ((v) == Qnil) #define rep_LISTP(v) (rep_NILP(v) || rep_CONSP(v)) #define rep_KEYWORDP(v) (rep_SYMBOLP(v) \ && (rep_SYM(v)->car & rep_SF_KEYWORD) != 0) #define rep_SYMBOL_LITERAL_P(v) ((rep_SYM(v)->car & rep_SF_LITERAL) != 0) /* Vectors */ typedef struct rep_vector_struct { repv car; /* size is bits 8->31 */ struct rep_vector_struct *next; repv array[1]; } rep_vector; /* Bytes to allocate for S objects */ #define rep_VECT_SIZE(s) ((sizeof(repv) * ((s)-1)) + sizeof(rep_vector)) #define rep_VECT(v) ((rep_vector *)rep_PTR(v)) #define rep_VECTI(v,i) (rep_VECT(v)->array[(i)]) #define rep_VECT_LEN(v) (rep_VECT(v)->car >> 8) #define rep_SET_VECT_LEN(v,l) (rep_VECT(v)->car = ((l) << 8 | rep_Vector)) #define rep_VECTORP(v) rep_CELL8_TYPEP(v, rep_Vector) #define rep_VECTOR_WRITABLE_P(v) (!rep_CELL_STATIC_P(v)) /* Compiled Lisp functions; this is a vector. Some of these definitions are probably hard coded into lispmach.c */ #define rep_COMPILEDP(v) rep_CELL8_TYPEP(v, rep_Compiled) #define rep_COMPILED(v) ((rep_vector *)rep_PTR(v)) /* First elt is byte-code string */ #define rep_COMPILED_CODE(v) rep_VECTI(v, 0) /* Second is constant vector */ #define rep_COMPILED_CONSTANTS(v) rep_VECTI(v, 1) /* Third is an (opaque) integer: memory requirements */ #define rep_COMPILED_STACK(v) rep_VECTI(v, 2) #define rep_COMPILED_MIN_SLOTS 3 /* Optional fifth element is documentation. */ #define rep_COMPILED_DOC(v) ((rep_VECT_LEN(v) >= 4) \ ? rep_VECTI(v, 3) : Qnil) /* Optional sixth element is interactive specification. */ #define rep_COMPILED_INTERACTIVE(v) ((rep_VECT_LEN(v) >= 5) \ ? rep_VECTI(v, 4) : Qnil) /* Files */ /* A file object. */ typedef struct rep_file_struct { repv car; /* single flag at bit 16 */ struct rep_file_struct *next; /* Name as user sees it */ repv name; /* Function to call to handle file operations, or t for file in local fs */ repv handler; /* Data for handler's use; for local files, this is the name of the file opened in the local fs. */ repv handler_data; /* For local files, a buffered file handle; for others some sort of stream. */ union { FILE *fh; repv stream; } file; /* For input streams */ int line_number; } rep_file; /* When this bit is set in flags, the file handle is never fclose()'d, i.e. this file points to something like stdin. */ #define rep_LFF_DONT_CLOSE (1 << (rep_CELL16_TYPE_BITS + 0)) #define rep_LFF_BOGUS_LINE_NUMBER (1 << (rep_CELL16_TYPE_BITS + 1)) #define rep_LFF_SILENT_ERRORS (1 << (rep_CELL16_TYPE_BITS + 2)) #define rep_FILE(v) ((rep_file *)rep_PTR(v)) #define rep_FILEP(v) rep_CELL16_TYPEP(v, rep_file_type) #define rep_LOCAL_FILE_P(v) (rep_FILE(v)->handler == Qt) /* Built-in subroutines */ /* Calling conventions are straightforward, returned value is result of function. But returning rep_NULL signifies some kind of abnormal exit (i.e. an error or throw, or ..?), should be treated as rep_INTERRUPTP defined below is */ /* C subroutine, can take from zero to five arguments. */ typedef struct { repv car; union { repv (*fun0)(void); repv (*fun1)(repv); repv (*fun2)(repv, repv); repv (*fun3)(repv, repv, repv); repv (*fun4)(repv, repv, repv, repv); repv (*fun5)(repv, repv, repv, repv, repv); repv (*funv)(int, repv *); } fun; repv name; repv int_spec; } rep_subr; typedef struct { repv car; repv (*fun)(); repv name; repv int_spec; /* put this in plist? */ } rep_xsubr; /* If set in rep_SubrN types, it'll be passed a vector of args, instead of a list */ #define rep_SUBR_VEC (1 << (rep_CELL8_TYPE_BITS + 0)) #define rep_SUBR_VEC_P(v) (rep_SUBR(v)->car & rep_SUBR_VEC) #define rep_SubrV (rep_SubrN | rep_SUBR_VEC) #define rep_XSUBR(v) ((rep_xsubr *) rep_PTR(v)) #define rep_SUBR(v) ((rep_subr *) rep_PTR(v)) #define rep_SUBR0FUN(v) (rep_SUBR(v)->fun.fun0) #define rep_SUBR1FUN(v) (rep_SUBR(v)->fun.fun1) #define rep_SUBR2FUN(v) (rep_SUBR(v)->fun.fun2) #define rep_SUBR3FUN(v) (rep_SUBR(v)->fun.fun3) #define rep_SUBR4FUN(v) (rep_SUBR(v)->fun.fun4) #define rep_SUBR5FUN(v) (rep_SUBR(v)->fun.fun5) #define rep_SUBRNFUN(v) (rep_SUBR(v)->fun.fun1) #define rep_SUBRVFUN(v) (rep_SUBR(v)->fun.funv) #define rep_SFFUN(v) (rep_SUBR(v)->fun.fun2) /* Closures */ typedef struct rep_funarg_struct { repv car; repv fun; repv name; repv env; repv structure; } rep_funarg; #define rep_FUNARG(v) ((rep_funarg *)rep_PTR(v)) #define rep_FUNARGP(v) (rep_CELL8_TYPEP(v, rep_Funarg)) #define rep_FUNARG_WRITABLE_P(v) (!rep_CELL_STATIC_P(v)) /* Guardians */ #define rep_GUARDIAN(v) ((rep_guardian *) rep_PTR(v)) #define rep_GUARDIANP(v) rep_CELL16_TYPEP(v, rep_guardian_type) /* Other definitions */ /* Macros for other types */ #define rep_VOIDP(v) rep_CELL8_TYPEP(v, rep_Void) /* Building lists */ #define rep_LIST_1(v1) Fcons(v1, Qnil) #define rep_LIST_2(v1,v2) Fcons(v1, rep_LIST_1(v2)) #define rep_LIST_3(v1,v2,v3) Fcons(v1, rep_LIST_2(v2, v3)) #define rep_LIST_4(v1,v2,v3,v4) Fcons(v1, rep_LIST_3(v2, v3, v4)) #define rep_LIST_5(v1,v2,v3,v4,v5) Fcons(v1, rep_LIST_4(v2, v3, v4, v5)) #define rep_CAAR(obj) rep_CAR (rep_CAR (obj)) #define rep_CDAR(obj) rep_CDR (rep_CAR (obj)) #define rep_CADR(obj) rep_CAR (rep_CDR (obj)) #define rep_CDDR(obj) rep_CDR (rep_CDR (obj)) #define rep_CAAAR(obj) rep_CAR (rep_CAR (rep_CAR (obj))) #define rep_CDAAR(obj) rep_CDR (rep_CAR (rep_CAR (obj))) #define rep_CADAR(obj) rep_CAR (rep_CDR (rep_CAR (obj))) #define rep_CDDAR(obj) rep_CDR (rep_CDR (rep_CAR (obj))) #define rep_CAADR(obj) rep_CAR (rep_CAR (rep_CDR (obj))) #define rep_CDADR(obj) rep_CDR (rep_CAR (rep_CDR (obj))) #define rep_CADDR(obj) rep_CAR (rep_CDR (rep_CDR (obj))) #define rep_CDDDR(obj) rep_CDR (rep_CDR (rep_CDR (obj))) #define rep_CAAAAR(obj) rep_CAR (rep_CAR (rep_CAR (rep_CAR (obj)))) #define rep_CDAAAR(obj) rep_CDR (rep_CAR (rep_CAR (rep_CAR (obj)))) #define rep_CADAAR(obj) rep_CAR (rep_CDR (rep_CAR (rep_CAR (obj)))) #define rep_CDDAAR(obj) rep_CDR (rep_CDR (rep_CAR (rep_CAR (obj)))) #define rep_CAADAR(obj) rep_CAR (rep_CAR (rep_CDR (rep_CAR (obj)))) #define rep_CDADAR(obj) rep_CDR (rep_CAR (rep_CDR (rep_CAR (obj)))) #define rep_CADDAR(obj) rep_CAR (rep_CDR (rep_CDR (rep_CAR (obj)))) #define rep_CDDDAR(obj) rep_CDR (rep_CDR (rep_CDR (rep_CAR (obj)))) #define rep_CAAADR(obj) rep_CAR (rep_CAR (rep_CAR (rep_CDR (obj)))) #define rep_CDAADR(obj) rep_CDR (rep_CAR (rep_CAR (rep_CDR (obj)))) #define rep_CADADR(obj) rep_CAR (rep_CDR (rep_CAR (rep_CDR (obj)))) #define rep_CDDADR(obj) rep_CDR (rep_CDR (rep_CAR (rep_CDR (obj)))) #define rep_CAADDR(obj) rep_CAR (rep_CAR (rep_CDR (rep_CDR (obj)))) #define rep_CDADDR(obj) rep_CDR (rep_CAR (rep_CDR (rep_CDR (obj)))) #define rep_CADDDR(obj) rep_CAR (rep_CDR (rep_CDR (rep_CDR (obj)))) #define rep_CDDDDR(obj) rep_CDR (rep_CDR (rep_CDR (rep_CDR (obj)))) /* Garbage collection definitions */ /* gc macros for cell8/16 values */ #define rep_GC_CELL_MARKEDP(v) (rep_PTR(v)->car & rep_CELL_MARK_BIT) #define rep_GC_SET_CELL(v) (rep_PTR(v)->car |= rep_CELL_MARK_BIT) #define rep_GC_CLR_CELL(v) (rep_PTR(v)->car &= ~rep_CELL_MARK_BIT) /* gc macros for cons values */ #define rep_GC_CONS_MARKEDP(v) (rep_CDR(v) & rep_VALUE_CONS_MARK_BIT) #define rep_GC_SET_CONS(v) (rep_CDR(v) |= rep_VALUE_CONS_MARK_BIT) #define rep_GC_CLR_CONS(v) (rep_CDR(v) &= ~rep_VALUE_CONS_MARK_BIT) /* True when cell V has been marked. */ #define rep_GC_MARKEDP(v) \ (rep_CELL_CONS_P(v) ? rep_GC_CONS_MARKEDP(v) : rep_GC_CELL_MARKEDP(v)) /* Set the mark bit of cell V. */ #define rep_GC_SET(v) \ do { \ if(rep_CELLP(v)) \ rep_GC_SET_CELL(v); \ else \ rep_GC_SET_CONS(v); \ } while(0) /* Clear the mark bit of cell V. */ #define rep_GC_CLR(v) \ do { \ if(rep_CELLP(v)) \ rep_GC_CLR_CELL(v); \ else \ rep_GC_CLR_CONS(v); \ } while(0) /* Recursively mark object V. */ #define rep_MARKVAL(v) \ do { \ if(v != 0 && !rep_INTP(v) && !rep_GC_MARKEDP(v)) \ rep_mark_value(v); \ } while(0) /* A stack of dynamic GC roots, i.e. objects to start marking from. */ typedef struct rep_gc_root { repv *ptr; struct rep_gc_root *next; } rep_GC_root; typedef struct rep_gc_n_roots { repv *first; int count; struct rep_gc_n_roots *next; } rep_GC_n_roots; /* Push a root to VAL using ROOT as storage (ROOT is rep_GC_root type) */ #define rep_PUSHGC(root, val) \ do { \ (root).ptr = &(val); \ (root).next = rep_gc_root_stack; \ rep_gc_root_stack = &(root); \ } while(0) /* Push a root to N values starting at PTR using ROOT as storage (ROOT is rep_GC_n_roots type) */ #define rep_PUSHGCN(root, ptr, n) \ do { \ (root).first = (ptr); \ (root).count = (n); \ (root).next = rep_gc_n_roots_stack; \ rep_gc_n_roots_stack = &(root); \ } while(0) #if !defined (rep_PARANOID_GC) # define rep_POPGC (rep_gc_root_stack = rep_gc_root_stack->next) # define rep_POPGCN (rep_gc_n_roots_stack = rep_gc_n_roots_stack->next) #else /* Check that gc roots are popped when they should have been; assumes downwards growing stack */ # if defined (__GNUC__) && defined (sparc) # define rep_get_sp(var) asm ("mov %%sp, %0" : "=r" (var)) # else # error "don't know how to get stack ptr on this arch, undef rep_PARANOID_GC" # endif #define rep_CHECK_GC(root) \ char *sp; rep_get_sp(sp); \ if (sp > (char *) root) \ abort (); # define rep_POPGC \ do { \ rep_CHECK_GC(rep_gc_root_stack) \ rep_gc_root_stack = rep_gc_root_stack->next; \ } while (0) # define rep_POPGCN \ do { \ rep_CHECK_GC(rep_gc_n_roots_stack) \ rep_gc_n_roots_stack = rep_gc_n_roots_stack->next; \ } while (0) #endif /* Macros for declaring functions */ /* Define a function named NAME (a string), whose function body will be called FSYM, whose rep_subr will be called SSYM, with argument list ARGS, of type code TYPE. */ #define DEFUN(name,fsym,ssym,args,type) \ DEFSTRING(rep_CONCAT(ssym, __name), name); \ extern repv fsym args; \ rep_ALIGN_CELL(rep_xsubr ssym) = { type, (repv (*)()) fsym, \ rep_VAL(&rep_CONCAT(ssym, __name)), \ rep_NULL }; \ repv fsym args /* Same as above but with an extra arg -- an interactive-spec string. */ #define DEFUN_INT(name,fsym,ssym,args,type,interactive) \ DEFSTRING(rep_CONCAT(ssym, __name), name); \ DEFSTRING(rep_CONCAT(ssym, __int), interactive); \ extern repv fsym args; \ rep_ALIGN_CELL(rep_xsubr ssym) = { type, (repv (*)()) fsym, \ rep_VAL(&rep_CONCAT(ssym, __name)), \ rep_VAL(&rep_CONCAT(ssym, __int)) };\ repv fsym args /* Add a subroutine */ #define rep_ADD_SUBR(subr) rep_add_subr(&subr, rep_TRUE) /* Add a non-exported subroutine */ #define rep_ADD_INTERNAL_SUBR(subr) rep_add_subr(&subr, rep_FALSE) /* Add an interactive subroutine */ #define rep_ADD_SUBR_INT(subr) rep_add_subr(&subr, rep_TRUE) /* Declare a symbol stored in variable QX. */ #define DEFSYM(x, name) \ repv Q ## x; DEFSTRING(str_ ## x, name) /* Intern a symbol stored in QX, whose name (a lisp string) is stored in str_X (i.e. declared with DEFSYM) */ #define rep_INTERN(x) rep_intern_static(& Q ## x, rep_VAL(& str_ ## x)) /* Same as above, but also marks the variable as dynamically scoped */ #define rep_INTERN_SPECIAL(x) \ do { \ rep_intern_static (& Q ## x, rep_VAL(& str_ ## x)); \ Fmake_variable_special (Q ## x); \ rep_SYM(Q ## x)->car |= rep_SF_DEFVAR; \ } while (0) /* Add an error string called err_X for symbol stored in QX */ #define rep_ERROR(x) \ Fput(Q ## x, Qerror_message, rep_VAL(& err_ ## x)) /* Macros for ensuring an object is of a certain type i.e. to ensure first arg `foo' is a string, rep_DECLARE1(foo, rep_STRINGP); */ #define rep_DECLARE(n,x,e) \ do { \ if(! (e)) \ { \ rep_signal_arg_error(x, n); \ return rep_NULL; \ } \ } while(0) #define rep_DECLARE1(x,t) rep_DECLARE(1,x,t(x)) #define rep_DECLARE2(x,t) rep_DECLARE(2,x,t(x)) #define rep_DECLARE3(x,t) rep_DECLARE(3,x,t(x)) #define rep_DECLARE4(x,t) rep_DECLARE(4,x,t(x)) #define rep_DECLARE5(x,t) rep_DECLARE(5,x,t(x)) #define rep_DECLARE1_OPT(x,t) rep_DECLARE(1, x, (x) == Qnil || t(x)) #define rep_DECLARE2_OPT(x,t) rep_DECLARE(2, x, (x) == Qnil || t(x)) #define rep_DECLARE3_OPT(x,t) rep_DECLARE(3, x, (x) == Qnil || t(x)) #define rep_DECLARE4_OPT(x,t) rep_DECLARE(4, x, (x) == Qnil || t(x)) #define rep_DECLARE5_OPT(x,t) rep_DECLARE(5, x, (x) == Qnil || t(x)) /* Macros for interrupt handling */ #define rep_MAY_YIELD \ do { \ if (rep_pending_thread_yield && rep_thread_lock == 0) \ Fthread_yield (); \ } while (0) #define rep_FORBID rep_thread_lock++ #define rep_PERMIT rep_thread_lock-- #define rep_PREEMPTABLE_P (rep_thread_lock <= 0) /* rep_TEST_INT is called before testing rep_INTERRUPTP, if necessary the target operating system will define it to be something useful. There's also a variant rep_TEST_INT_SLOW that should be used by code that only checks a few times or less a second */ #ifndef rep_TEST_INT # define rep_TEST_INT \ do { \ if(++rep_test_int_counter > rep_test_int_period) { \ (*rep_test_int_fun)(); \ rep_test_int_counter = 0; \ rep_pending_thread_yield = rep_TRUE; \ } \ } while(0) # define rep_TEST_INT_SLOW \ do { \ (*rep_test_int_fun)(); \ rep_test_int_counter = 0; \ if (!rep_INTERRUPTP) \ Fthread_yield (); \ } while(0) #else /* !rep_TEST_INT */ # ifndef rep_TEST_INT_SLOW # define rep_TEST_INT_SLOW rep_TEST_INT # endif #endif /* True when an interrupt has occurred; this means that the function should exit as soon as possible, returning rep_NULL. */ #define rep_INTERRUPTP (rep_throw_value != rep_NULL) /* End-of-list / false value The canonical method of getting '() is to access the `Qnil' variable. But we know that that currently points to `rep_eol_datum'. So avoid lots of global variable referencing by hardcoding that value for library-internal code. */ extern repv Qnil; #ifdef rep_INTERNAL extern rep_tuple rep_eol_datum; # ifdef rep_DEFINE_QNIL repv Qnil = rep_VAL (&rep_eol_datum); # endif /* OS X has problems with this */ # ifndef __APPLE__ # define Qnil rep_VAL(&rep_eol_datum) # endif #endif /* Storing timestamps */ #define rep_MAKE_TIME(time) \ Fcons(rep_MAKE_INT(time / 86400), rep_MAKE_INT(time % 86400)) #define rep_GET_TIME(time) \ (rep_INT(rep_CAR(time)) * 86400 + rep_INT(rep_CDR(time))) #define rep_TIMEP(v) rep_CONSP(v) #endif /* REP_LISP_H */ librep-0.90.2/src/rep_gh.h0000644000175200017520000002200311245011153014257 0ustar chrischris/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. * * The exception is that, if you link the GUILE library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of * linking the GUILE library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the * Free Software Foundation under the name GUILE. If you copy * code from other Free Software Foundation releases into a copy of * GUILE, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ #ifndef REP_GH_H #define REP_GH_H #ifdef __cplusplus extern "C" { #endif #include /* gcc has extern inline functions that are basically as fast as macros */ #ifdef __GNUC__ # define INL inline # define EXTINL extern inline #else # define INL #define EXTINL #endif /* __GNUC__ */ typedef repv SCM; #define SCM_EOL Qnil #define SCM_BOOL_F Qnil #define SCM_BOOL_T Qt #define SCM_UNDEFINED rep_undefined_value #define SCM_UNSPECIFIED rep_undefined_value typedef SCM (*scm_t_catch_body) (void *data); typedef SCM (*scm_t_catch_handler) (void *data, SCM tag, SCM throw_args); void gh_enter(int argc, char *argv[], void (*c_main_prog)(int, char **)); #define gh_init () scm_init_guile () void gh_repl(int argc, char *argv[]); SCM gh_catch(SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data); SCM gh_standard_handler(void *data, SCM tag, SCM throw_args); SCM gh_eval_str(const char *scheme_code); SCM gh_eval_str_with_catch(const char *scheme_code, scm_t_catch_handler handler); SCM gh_eval_str_with_standard_handler(const char *scheme_code); SCM gh_eval_str_with_stack_saving_handler(const char *scheme_code); SCM gh_eval_file(const char *fname); #define gh_load(fname) gh_eval_file(fname) SCM gh_eval_file_with_catch(const char *scheme_code, scm_t_catch_handler handler); SCM gh_eval_file_with_standard_handler(const char *scheme_code); #define gh_defer_ints() do{}while(0) #define gh_allow_ints() do{}while(0) SCM gh_new_procedure(const char *proc_name, SCM (*fn)(), int n_required_args, int n_optional_args, int varp); SCM gh_new_procedure0_0(const char *proc_name, SCM (*fn)(void)); SCM gh_new_procedure0_1(const char *proc_name, SCM (*fn)(SCM)); SCM gh_new_procedure0_2(const char *proc_name, SCM (*fn)(SCM, SCM)); SCM gh_new_procedure1_0(const char *proc_name, SCM (*fn)(SCM)); SCM gh_new_procedure1_1(const char *proc_name, SCM (*fn)(SCM, SCM)); SCM gh_new_procedure1_2(const char *proc_name, SCM (*fn)(SCM, SCM, SCM)); SCM gh_new_procedure2_0(const char *proc_name, SCM (*fn)(SCM, SCM)); SCM gh_new_procedure2_1(const char *proc_name, SCM (*fn)(SCM, SCM, SCM)); SCM gh_new_procedure2_2(const char *proc_name, SCM (*fn)(SCM, SCM, SCM, SCM)); SCM gh_new_procedure3_0(const char *proc_name, SCM (*fn)(SCM, SCM, SCM)); SCM gh_new_procedure4_0(const char *proc_name, SCM (*fn)(SCM, SCM, SCM, SCM)); SCM gh_new_procedure5_0(const char *proc_name, SCM (*fn)(SCM, SCM, SCM, SCM, SCM)); /* C to Scheme conversion */ SCM gh_bool2scm(int x); SCM gh_int2scm(int x); SCM gh_ulong2scm(unsigned long x); SCM gh_long2scm(long x); SCM gh_double2scm(double x); SCM gh_char2scm(char c); SCM gh_str2scm(const char *s, size_t len); SCM gh_str02scm(const char *s); void gh_set_substr(char *src, SCM dst, long start, size_t len); SCM gh_symbol2scm(const char *symbol_str); SCM gh_ints2scm(const int *d, long n); SCM gh_doubles2scm(const double *d, long n); /* Scheme to C conversion */ int gh_scm2bool(SCM obj); int gh_scm2int(SCM obj); unsigned long gh_scm2ulong(SCM obj); long gh_scm2long(SCM obj); char gh_scm2char(SCM obj); double gh_scm2double(SCM obj); char *gh_scm2newstr(SCM str, size_t *lenp); void gh_get_substr(SCM src, char *dst, long start, size_t len); char *gh_symbol2newstr(SCM sym, size_t *lenp); char *gh_scm2chars(SCM vector, char *result); short *gh_scm2shorts(SCM vector, short *result); long *gh_scm2longs(SCM vector, long *result); float *gh_scm2floats(SCM vector, float *result); double *gh_scm2doubles(SCM vector, double *result); /* type predicates: tell you if an SCM object has a given type */ int gh_boolean_p(SCM val); int gh_symbol_p(SCM val); int gh_char_p(SCM val); int gh_vector_p(SCM val); int gh_pair_p(SCM val); int gh_number_p(SCM val); int gh_string_p(SCM val); int gh_procedure_p(SCM val); int gh_list_p(SCM val); int gh_inexact_p(SCM val); int gh_exact_p(SCM val); /* more predicates */ int gh_eq_p(SCM x, SCM y); int gh_eqv_p(SCM x, SCM y); int gh_equal_p(SCM x, SCM y); int gh_string_equal_p(SCM s1, SCM s2); int gh_null_p(SCM l); /* standard Scheme procedures available from C */ SCM gh_not(SCM val); SCM gh_define(const char *name, SCM val); /* string manipulation routines */ SCM gh_make_string(SCM k, SCM chr); SCM gh_string_length(SCM str); SCM gh_string_ref(SCM str, SCM k); SCM gh_string_set_x(SCM str, SCM k, SCM chr); SCM gh_substring(SCM str, SCM start, SCM end); SCM gh_string_append(SCM args); /* vector manipulation routines */ /* note that gh_vector() does not behave quite like the Scheme (vector obj1 obj2 ...), because the interpreter engine does not pass the data element by element, but rather as a list. thus, gh_vector() ends up being identical to gh_list_to_vector() */ SCM gh_vector(SCM ls); SCM gh_make_vector(SCM length, SCM val); SCM gh_vector_set_x(SCM vec, SCM pos, SCM val); SCM gh_vector_ref(SCM vec, SCM pos); unsigned long gh_vector_length (SCM v); unsigned long gh_uniform_vector_length (SCM v); SCM gh_uniform_vector_ref (SCM v, SCM ilist); #define gh_list_to_vector(ls) gh_vector(ls) SCM gh_vector_to_list(SCM v); SCM gh_lookup (const char *sname); SCM gh_module_lookup (SCM module, const char *sname); SCM gh_cons(SCM x, SCM y); SCM gh_list(SCM elt, ...); unsigned long gh_length(SCM l); SCM gh_append(SCM args); SCM gh_append2(SCM l1, SCM l2); SCM gh_append3(SCM l1, SCM l2, SCM l3); SCM gh_append4(SCM l1, SCM l2, SCM l3, SCM l4); SCM gh_reverse(SCM ls); SCM gh_list_tail(SCM ls, SCM k); SCM gh_list_ref(SCM ls, SCM k); SCM gh_memq(SCM x, SCM ls); SCM gh_memv(SCM x, SCM ls); SCM gh_member(SCM x, SCM ls); SCM gh_assq(SCM x, SCM alist); SCM gh_assv(SCM x, SCM alist); SCM gh_assoc(SCM x, SCM alist); SCM gh_car(SCM x); SCM gh_cdr(SCM x); SCM gh_caar(SCM x); SCM gh_cadr(SCM x); SCM gh_cdar(SCM x); SCM gh_cddr(SCM x); SCM gh_caaar(SCM x); SCM gh_caadr(SCM x); SCM gh_cadar(SCM x); SCM gh_caddr(SCM x); SCM gh_cdaar(SCM x); SCM gh_cdadr(SCM x); SCM gh_cddar(SCM x); SCM gh_cdddr(SCM x); SCM gh_set_car_x(SCM pair, SCM value); SCM gh_set_cdr_x(SCM pair, SCM value); /* Calling Scheme functions from C. */ SCM gh_apply (SCM proc, SCM ls); SCM gh_call0 (SCM proc); SCM gh_call1 (SCM proc, SCM arg); SCM gh_call2 (SCM proc, SCM arg1, SCM arg2); SCM gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3); /* reading and writing Scheme objects. */ void gh_display (SCM x); void gh_write (SCM x); void gh_newline (void); /* void gh_gc_mark(SCM) : mark an SCM as in use. */ /* void gh_defer_ints() : don't interrupt code section. */ /* void gh_allow_ints() : see gh_defer_ints(). */ /* void gh_new_cell(SCM, int tag) : initialize SCM to be of type 'tag' */ /* int gh_type_p(SCM, tag) : test if SCM is of type 'tag' */ /* SCM gh_intern(char*) : get symbol corresponding to c-string.*/ /* void gh_set_ext_data(SCM, void*) : set extension data on SCM */ /* void *gh_get_ext_data(SCM) : return extension data from SCM. */ /* void gh_assert(int cond, char *msg, SCM obj); */ #ifdef __cplusplus } #endif #endif /* REP_GH_H */ /* Local Variables: c-file-style: "gnu" End: */ librep-0.90.2/src/rep_config.h.in0000644000175200017520000000207711245011153015544 0ustar chrischris/* rep_config.h.in -- configure defs needed by library callers */ #ifndef REP_CONFIG_H #define REP_CONFIG_H /* Version number */ #undef rep_VERSION /* libtool interface revision number */ #undef rep_INTERFACE /* Define if you have some flavour of Unix */ #undef rep_HAVE_UNIX /* An implicitly signed integer type, that a pointer can be cast to and from without dropping bits */ #undef rep_PTR_SIZED_INT /* This is either L or LL -- the suffix to append to integer constants of the above type */ #undef rep_PTR_SIZED_INT_SUFFIX /* A string, the printf integer conversion of the above integer type, i.e. "" for int, "l" for long, "ll" for long long */ #undef rep_PTR_SIZED_INT_CONV /* The number of bytes in the above type. */ #undef rep_PTR_SIZED_INT_SIZEOF #define rep_PTR_SIZED_INT_BITS (rep_PTR_SIZED_INT_SIZEOF * CHAR_BIT) /* The minimum alignment of memory allocated by malloc(). The default of four should be ok for most systems? */ #undef rep_MALLOC_ALIGNMENT /* Defined if `long long int' is available */ #undef rep_HAVE_LONG_LONG #endif /* REP_CONFIG_H */ librep-0.90.2/src/rep.h0000644000175200017520000000230711245011153013606 0ustar chrischris/* rep.h -- Public include file, brings in all the rest Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #ifndef REP_H #define REP_H #include #include typedef int rep_bool; #define rep_TRUE 1 #define rep_FALSE 0 #ifndef NULL #define NULL 0 #endif #include #ifdef rep_HAVE_LONG_LONG # define rep_long_long long long #else # define rep_long_long long #endif #include "rep_lisp.h" #include "rep_regexp.h" #include "rep_subrs.h" #endif /* REP_H */ librep-0.90.2/src/rep.c0000644000175200017520000000120011245011153013570 0ustar chrischris/* rep.c -- read-eval-print front end $Id$ */ #define _GNU_SOURCE #ifdef HAVE_CONFIG_H # include #endif #include "rep.h" #include "build.h" #include #ifdef HAVE_LOCALE_H # include #endif int main(int argc, char **argv) { DEFSTRING (rep, "rep/user"); int exit_status; char *prog_name = *argv++; argc--; #ifdef HAVE_SETLOCALE setlocale (LC_ALL, ""); #endif rep_init (prog_name, &argc, &argv, 0, 0); rep_call_with_barrier (rep_load_environment, rep_VAL (&rep), rep_TRUE, 0, 0, 0); exit_status = rep_top_level_exit (); rep_kill(); return exit_status; } librep-0.90.2/src/rep-xgettext.jl0000644000175200017520000000337011245011153015637 0ustar chrischris#! /usr/bin/rep !# ;; rep-xgettext.jl -- extract i18n strings from lisp scripts ;; $Id: rep-xgettext.jl,v 1.8 2000/08/03 16:17:09 john Exp $ ;; This file is part of librep. ;; librep is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; librep is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with librep; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (require 'rep.i18n.xgettext) (defvar *write-c-file* nil) ;; entry point (when (get-command-line-option "--help") (write standard-output "\ usage: rep-xgettext [OPTIONS...] FILES... where OPTIONS are any of: --include DEFINER --c --pot\n") (throw 'quit 0)) (when (or (get-command-line-option "-c") (get-command-line-option "--c")) (setq *write-c-file* t)) (when (or (get-command-line-option "-p") (get-command-line-option "--pot")) (setq *write-c-file* nil)) (let ((included '()) tem) (while (setq tem (get-command-line-option "--include" t)) (setq included (cons (intern tem) included))) (when included (set-included-definers included))) (while command-line-args (let ((file (car command-line-args))) (setq command-line-args (cdr command-line-args)) (scan-file file))) (if *write-c-file* (output-c-file) (output-pot-file)) ;; Local variables: ;; major-mode: lisp-mode ;; End: librep-0.90.2/src/rep-remote.c0000644000175200017520000002542311245011153015076 0ustar chrischris/* rep-remote.c -- remote filesystem back-end Copyright (C) 1999 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* todo: * support non 8-bit clean connections? * make `mv' work across filesystems? */ #define _GNU_SOURCE #ifdef HAVE_CONFIG_H # include #endif #include #include #include #include #include #include #include #include #include #include #include #include #if HAVE_DIRENT_H # include # define NAMLEN(dirent) strlen((dirent)->d_name) #else # define dirent direct # define NAMLEN(dirent) (dirent)->d_namlen # if HAVE_SYS_NDIR_H # include # endif # if HAVE_SYS_DIR_H # include # endif # if HAVE_NDIR_H # include # endif #endif #ifndef PATH_MAX # define PATH_MAX 256 #endif #ifndef S_ISLNK #define S_ISLNK(mode) (((mode) & S_IFMT) == S_IFLNK) #endif #ifndef S_ISSOCK #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK) #endif #define PROTOCOL_VERSION 1 /* trivia */ static void x_perror (char *fmt, ...) { va_list args; va_start(args, fmt); vfprintf (stderr, fmt, args); va_end(args); fprintf (stderr, ": %s\n", strerror (errno)); exit (10); } static void send_char (char c) { if (write (1, &c, 1) != 1) x_perror ("send_char"); } static int read_char (void) { char c; if (read (0, &c, 1) != 1) return EOF; return c; } static void send_long (long value) { char lbuf[10]; sprintf (lbuf, "%08lx", value); if (write (1, lbuf, 8) != 8) x_perror ("send_long"); } static long read_long () { char lbuf[10]; if (read (0, lbuf, 8) != 8) x_perror ("read_long"); lbuf[8] = 0; return strtol (lbuf, 0, 16); } static void send_string (char *string) { long length = strlen (string); send_long (length); if (write (1, string, length) != length) x_perror ("send_string"); } static char * read_string () { long length = read_long (); char *buf = malloc (length + 1); if (read (0, buf, length) != length) x_perror ("read_string"); buf[length] = 0; return buf; } static void send_success (void) { send_char ('\001'); } static void send_errno (int error) { send_char ('\177'); send_string (strerror (error)); } static char * quote_string (char *out, char *in) { char c; *out++ = '"'; while ((c = *in++) != 0) { switch (c) { case 0: *out++ = '\\'; *out++ = '0'; *out++ = '0'; *out++ = '0'; break; case '"': *out++ = '\\'; *out++ = '"'; break; case '\\': *out++ = '\\'; *out++ = '\\'; break; default: *out++ = c; } } *out++ = '"'; *out = 0; return out; } static char * uid_name (uid_t uid) { struct passwd *pw = getpwuid (uid); return (pw != 0) ? pw->pw_name : 0; } static char * gid_name (gid_t gid) { struct group *gr = getgrgid (gid); return (gr != 0) ? gr->gr_name : 0; } static char * output_mode_string (char *out, unsigned long perms) { int i; char c = '-'; memset (out, '-', 10); if(S_ISDIR(perms)) c = 'd'; else if(S_ISLNK(perms)) c = 'l'; else if(S_ISBLK(perms)) c = 'b'; else if(S_ISCHR(perms)) c = 'c'; else if(S_ISFIFO(perms)) c = 'p'; else if(S_ISSOCK(perms)) c = 's'; out[0] = c; for(i = 0; i < 3; i++) { unsigned long xperms = perms >> ((2 - i) * 3); if(xperms & 4) out[1+i*3] = 'r'; if(xperms & 2) out[2+i*3] = 'w'; c = (xperms & 1) ? 'x' : 0; if(perms & (04000 >> i)) { static char extra_bits[3] = { 'S', 'S', 'T' }; /* Rampant abuse of ASCII knowledge :-) */ c = extra_bits[i] | (c & 0x20); } if(c != 0) out[3+i*3] = c; } out[10] = 0; return out + 10; } /* commands */ static void do_get (int argc, char **argv) { struct stat st; assert (argc == 1); if (stat (argv[0], &st) == 0 && S_ISREG (st.st_mode)) { FILE *fh = fopen (argv[0], "r"); if (fh != 0) { unsigned long size = st.st_size; send_success (); send_long (size); while (size > 0) { char buf[BUFSIZ]; int this = (size > BUFSIZ ? BUFSIZ : size); this = fread (buf, 1, this, fh); if (this == 0) x_perror ("get-read"); if (write (1, buf, this) != this) x_perror ("get-write"); size -= this; } fclose (fh); } else send_errno (errno); } else send_errno (EISDIR); /* ?? */ } static void do_put (int argc, char **argv) { FILE *fh; assert (argc == 1); fh = fopen (argv[0], "w"); if (fh != 0) { long size = read_long (); long todo = size; while (todo > 0) { char buf[BUFSIZ]; int this = (todo > BUFSIZ ? BUFSIZ : todo); this = read (0, buf, this); if (this < 0) x_perror ("put-read"); if (fwrite (buf, 1, this, fh) != this) x_perror ("put-write"); todo -= this; } fclose (fh); send_success (); } else send_errno (errno); } static void do_rm (int argc, char **argv) { assert (argc == 1); if (unlink (argv[0]) == 0) send_success (); else send_errno (errno); } static void do_rmdir (int argc, char **argv) { assert (argc == 1); if (rmdir (argv[0]) == 0) send_success (); else send_errno (errno); } static void do_mv (int argc, char **argv) { assert (argc == 2); if (rename (argv[0], argv[1]) == 0) send_success (); else send_errno (errno); } static void do_mkdir (int argc, char **argv) { assert (argc == 1); if (mkdir (argv[0], S_IRWXU | S_IRWXG | S_IRWXO) == 0) send_success (); else send_errno (errno); } static void do_cp (int argc, char **argv) { int srcf; assert (argc == 2); srcf = open(argv[0], O_RDONLY); if(srcf != -1) { int dstf = open(argv[1], O_WRONLY | O_CREAT | O_TRUNC, 0666); if(dstf != -1) { struct stat statb; int rd; if(fstat(srcf, &statb) == 0) chmod(argv[1], statb.st_mode); do { char buf[BUFSIZ]; int wr; rd = read(srcf, buf, BUFSIZ); if(rd < 0) x_perror ("copy-read"); wr = write(dstf, buf, rd); if(wr != rd) x_perror ("copy-write"); } while(rd != 0); close(dstf); send_success (); } else send_errno (errno); close(srcf); } else send_errno (errno); } static void do_chmod (int argc, char **argv) { long mode; assert (argc == 2); mode = strtol (argv[1], 0, 16); if (chmod (argv[0], mode) == 0) send_success (); else send_errno (errno); } static void do_readlink (int argc, char **argv) { char buf[PATH_MAX]; int length; assert (argc == 1); length = readlink (argv[0], buf, sizeof (buf)); if (length != -1) { send_success (); buf[length] = 0; send_string (buf); } else send_errno (errno); } static void do_symlink (int argc, char **argv) { assert (argc == 2); if (symlink (argv[0], argv[1]) == 0) send_success (); else send_errno (errno); } static void do_readdir (int argc, char **argv) { DIR *dir; assert (argc == 1); dir = opendir(argv[0]); if(dir != 0) { struct dirent *de; char dirname[PATH_MAX]; strcpy (dirname, argv[0]); if (dirname[strlen(dirname)-1] != '/') strcat (dirname, "/"); while((de = readdir(dir))) { /* for each entry write out the following record: [ NAME SIZE MODTIME TYPE MODES MODE-STRING NLINKS USER GROUP ] suitable for Lisp reading. */ char nambuf[PATH_MAX]; struct stat st; char buf[3*PATH_MAX], *ptr = buf; strcpy (nambuf, dirname); strcat (nambuf, de->d_name); if (lstat (nambuf, &st) == 0) { *ptr++ = '['; ptr = quote_string (ptr, de->d_name); ptr += sprintf (ptr, " %ld (%ld . %ld) %s %ld \"", (long)st.st_size, st.st_mtime / 86400, st.st_mtime % 86400, S_ISREG (st.st_mode) ? "file" : S_ISDIR (st.st_mode) ? "directory" : S_ISLNK (st.st_mode) ? "symlink" : S_ISFIFO (st.st_mode) ? "pipe" : S_ISSOCK (st.st_mode) ? "socket" : S_ISCHR (st.st_mode) ? "device" : S_ISBLK (st.st_mode) ? "device" : "nil", (long)st.st_mode & 07777); ptr = output_mode_string (ptr, st.st_mode); ptr += sprintf (ptr, "\" %d \"%s\" \"%s\"]\n", (int)st.st_nlink, uid_name (st.st_uid), gid_name (st.st_gid)); send_char ('\002'); send_string (buf); } else x_perror ("readdir-stat"); } closedir(dir); send_success (); } else send_errno (errno); } /* entry point */ static void print_signature (void) { char buf[256]; sprintf (buf, "\002rep-remote; protocol %d\002\001", PROTOCOL_VERSION); if (write (1, buf, strlen (buf)) != strlen (buf)) x_perror ("print_signature"); } int main (int argc, char **argv) { fflush (0); /* Paranoia against braindead installation; would anyone really be so foolish?! */ if (getuid () != geteuid () || getgid () != getegid ()) { fputs ("Don't install rep-remote setuid; it's not designed for it.\n", stderr); return 10; } print_signature (); while (1) { char *args[64]; int command, nargs, i; command = read_char (); nargs = read_char (); if (command == EOF || nargs == EOF) return 0; assert (nargs < 64); for (i = 0; i < nargs; i++) args[i] = read_string (); args[i] = 0; switch (command) { case 'G': /* get FILENAME */ do_get (nargs, args); break; case 'P': /* put FILENAME */ do_put (nargs, args); break; case 'R': /* rm FILE */ do_rm (nargs, args); break; case 'r': /* rmdir FILE */ do_rmdir (nargs, args); break; case 'M': /* mv SOURCE DEST */ do_mv (nargs, args); break; case 'm': /* mkdir FILE */ do_mkdir (nargs, args); break; case 'C': /* cp SOURCE DEST */ do_cp (nargs, args); break; case 'c': /* chmod FILE MODE */ do_chmod (nargs, args); break; case 'l': /* readlink FILE */ do_readlink (nargs, args); break; case 'L': /* symlink NAME1 NAME2 */ do_symlink (nargs, args); break; case 'D': /* readdir FILE */ do_readdir (nargs, args); break; case 'Q': /* quit */ return 0; case '\n': case '\r': /* ignored */ break; } for (i = 0; i < nargs; i++) free (args[i]); } } librep-0.90.2/src/rep-md5.c0000644000175200017520000000524011245011153014263 0ustar chrischris/* rep-md5.c -- wrap some md5 functions Copyright (C) 2001 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include #include "repint.h" #include "md5.h" static repv digest_to_repv (char digest[16]) { static const char hex_digits[16] = "0123456789abcdef"; char hex_digest[32]; int i; /* Currently rep has no interface to create bignums directly, so format to a hex-encoded string, then reparse it. XXX This loses if rep was compiled without GMP support.. */ for (i = 0; i < 16; i++) { hex_digest[i*2] = hex_digits[digest[i] & 15]; hex_digest[i*2+1] = hex_digits[digest[i] >> 4]; } return rep_parse_number (hex_digest, 32, 16, 1, 0); } DEFUN ("md5-string", Fmd5_string, Smd5_string, (repv data), rep_Subr1) /* ::doc:rep.util.md5#md5-string:: md5-string STRING Return the integer representing the MD5 message digest of the bytes stored in STRING. This integer will have no more than 128 significant bits. ::end:: */ { char digest[16]; rep_DECLARE1 (data, rep_STRINGP); md5_buffer (rep_STR (data), rep_STRING_LEN (data), digest); return digest_to_repv (digest); } DEFUN ("md5-local-file", Fmd5_local_file, Smd5_local_file, (repv file), rep_Subr1) /* ::doc:rep.util.md5#md5-local-file:: md5-local-file LOCAL-FILE-NAME Return the integer representing the MD5 message digest of the bytes stored in the file called LOCAL-FILE-NAME (which must name a file in the local filing system). The returned integer will have no more than 128 significant bits. ::end:: */ { FILE *fh; char digest[16]; rep_DECLARE1 (file, rep_STRINGP); fh = fopen (rep_STR (file), "r"); if (fh == 0) return rep_signal_file_error (file); md5_stream (fh, digest); fclose (fh); return digest_to_repv (digest); } repv rep_dl_init (void) { repv tem = rep_push_structure ("rep.util.md5"); rep_ADD_SUBR(Smd5_string); rep_ADD_SUBR(Smd5_local_file); return rep_pop_structure (tem); } librep-0.90.2/src/rep-config.sh0000755000175200017520000000144111245011153015235 0ustar chrischris#!/bin/sh # load libtool configuration ltconf=/tmp/libtool.conf.$$ ../libtool --config >$ltconf . $ltconf rm -f $ltconf prefix="$1" libdir="$2" version="$3" LIBS="$4" repexecdir="$5" sitelispdir="$6" libpath="-L${libdir}" cat <&2 exit 1 fi while test \$# -gt 0; do case \$1 in --version) echo "${version}" ;; --cflags) echo "-I${prefix}/include -I${repexecdir}" ;; --libs) echo "${libpath} -lrep ${LIBS}" ;; --execdir) echo "${repexecdir}" ;; --lispdir) echo "${sitelispdir}" ;; *) echo "\${usage}" 1>&2 exit 1 ;; esac shift done EOF librep-0.90.2/src/regsub.c0000644000175200017520000000757111245011153014312 0ustar chrischris/* * regsub @(#)regsub.c 1.3 of 2 April 86 * * Copyright (c) 1986 by University of Toronto. Written by Henry Spencer. Not * derived from licensed software. * * Permission is granted to anyone to use this software for any purpose on any * computer system, and to redistribute it freely, subject to the following * restrictions: * * 1. The author is not responsible for the consequences of use of this * software, no matter how awful, even if they arise from defects in it. * * 2. The origin of this software must not be misrepresented, either by explicit * claim or by omission. * * 3. Altered versions must be plainly marked as such, and must not be * misrepresented as being the original software. */ #define _GNU_SOURCE #define rep_NEED_REGEXP_INTERNALS #include "repint.h" #include #include /* * CHANGED, 14-Jan-93, by J.Harper, * added #ifdef __STDC__ prototype sections so I can use registerized * arguments * * also, I added the regsublen() function for safety & general usefulness * (regsub() has no checks for overstepping its dest string) */ #ifndef CHARBITS #define UCHARAT(p) ((int)*(unsigned char *)(p)) #else #define UCHARAT(p) ((int)*(p)&CHARBITS) #endif /* * - regsub - perform substitutions after a regexp match * * data is null if the last match was a string, or the TX if the last * match was on a buffer. */ void rep_default_regsub(lasttype, matches, source, dest, data) int lasttype; rep_regsubs *matches; char *source; char *dest; void *data; { register char *src; register char *dst; register char c; register int no; register int len; if (matches == NULL || source == NULL || dest == NULL) { rep_regerror("NULL parm to regsub"); return; } if ((lasttype == rep_reg_string && !rep_STRINGP(rep_VAL(data))) || (lasttype == rep_reg_obj)) { rep_regerror("Bad type of data to regsub"); return; } src = source; dst = dest; while ((c = *src++) != '\0') { if (c == '&') no = 0; else if (c == '\\' && '0' <= *src && *src <= '9') no = *src++ - '0'; else no = -1; if (no < 0) { /* Ordinary character. */ if (c == '\\' && (*src == '\\' || *src == '&')) c = *src++; *dst++ = c; } else { if(lasttype == rep_reg_string) { if (matches->string.startp[no] != NULL && matches->string.endp[no] != NULL) { len = matches->string.endp[no] - matches->string.startp[no]; (void) strncpy(dst, matches->string.startp[no], len); dst += len; if (len != 0 && *(dst - 1) == '\0') { /* strncpy hit NUL. */ rep_regerror("damaged match string"); return; } } } } } *dst++ = '\0'; } /* * - regsublen - dummy regsub() returning length of contructed string, * including terminating '\0' */ int rep_default_regsublen(lasttype, matches, source, data) int lasttype; rep_regsubs *matches; char *source; void *data; { register char *src; register char c; register int no; register int dstlen = 1; if (matches == NULL || source == NULL) { rep_regerror("NULL parm to regsublen"); return(0); } if ((lasttype == rep_reg_string && !rep_STRINGP(rep_VAL(data))) || (lasttype == rep_reg_obj)) { rep_regerror("Bad type of data to regsublen"); return (0); } src = source; while ((c = *src++) != '\0') { if (c == '&') no = 0; else if (c == '\\' && '0' <= *src && *src <= '9') no = *src++ - '0'; else no = -1; if (no < 0) { /* Ordinary character. */ if (c == '\\' && (*src == '\\' || *src == '&')) c = *src++; dstlen++; } else { if(lasttype == rep_reg_string) { if (matches->string.startp[no] != NULL && matches->string.endp[no] != NULL) { dstlen += matches->string.endp[no] - matches->string.startp[no]; } } } } return(dstlen); } librep-0.90.2/src/regexp.c0000644000175200017520000007654711245011153014326 0ustar chrischris/* * regcomp and regexec -- regsub and regerror are elsewhere @(#)regexp.c 1.3 * of 18 April 87 * * Copyright (c) 1986 by University of Toronto. Written by Henry Spencer. Not * derived from licensed software. * * Permission is granted to anyone to use this software for any purpose on any * computer system, and to redistribute it freely, subject to the following * restrictions: * * 1. The author is not responsible for the consequences of use of this * software, no matter how awful, even if they arise from defects in it. * * 2. The origin of this software must not be misrepresented, either by explicit * claim or by omission. * * 3. Altered versions must be plainly marked as such, and must not be * misrepresented as being the original software. * * Beware that some of this code is subtly aware of the way operator precedence * is structured in regular expressions. Serious changes in * regular-expression syntax might require a total rethink. */ /* Lots of changes for Jade. See the file README.regexp for more details */ #define _GNU_SOURCE #define rep_NEED_REGEXP_INTERNALS #include "repint.h" #include #include #include #include #undef DEBUG /* * Utility definitions. */ #ifndef CHARBITS #define UCHARAT(p) ((int)*(unsigned char *)(p)) #else #define UCHARAT(p) ((int)*(p)&CHARBITS) #endif #define FAIL(m) { rep_regerror(m); return(NULL); } #define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?') #define META "^$.[()|?+*\\" /* * Flags to be passed up and down. */ #define HASWIDTH 01 /* Known never to match null string. */ #define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ #define SPSTART 04 /* Starts with * or +. */ #define WORST 0 /* Worst case. */ /* * Global work variables for regcomp(). */ static char *regparse; /* Input-scan pointer. */ static int regnpar; /* () count. */ static char regdummy; static char *regcode; /* Code-emit pointer; ®dummy = don't. */ static long regsize; /* Code size. */ /* * Forward declarations for regcomp()'s friends. */ static char *reg(int, int *); static char *regbranch(int *); static char *regpiece(int *); static char *regatom(int *); static char *regnode(char); static char *regnext(char *); static void regc(char); static void reginsert(char, char *); static void regtail(char *, char *); static void regoptail(char *, char *); extern void rep_regerror(char *); #ifdef DEBUG void regdump(rep_regexp *); int regenable_debug = 0; #endif #ifndef HAVE_STRCSPN int strcspn(char *, char *); #endif /* * - regcomp - compile a regular expression into internal code * * We can't allocate space until we know how big the compiled form will be, but * we can't compile it (and thus know how big it is) until we've got a place * to put the code. So we cheat: we compile it twice, once with code * generation turned off and size counting turned on, and once "for real". * This also means that we don't allocate space until we are sure that the * thing really will compile successfully, and we never have to move the code * and thus invalidate pointers into it. (Note that it has to be in one * piece because free() must be able to free it all.) * * Beware that the optimization-preparation code in here knows about some of the * structure of the compiled regexp. */ rep_regexp * rep_regcomp(char *exp) { register rep_regexp *r; register char *scan; register char *longest; register int len; int flags; if (exp == NULL) FAIL("NULL argument"); /* First pass: determine size, legality. */ regparse = exp; regnpar = 1; regsize = 0L; regcode = ®dummy; regc(MAGIC); if (reg(0, &flags) == NULL) return (NULL); /* Small enough for pointer-storage convention? */ if (regsize >= 32767L) /* Probably could be 65535L. */ FAIL("regexp too big"); /* Allocate space. */ r = (rep_regexp *) malloc(sizeof(rep_regexp) + (unsigned) regsize); if (r == NULL) FAIL("out of space"); /* Second pass: emit code. */ regparse = exp; regnpar = 1; regcode = r->program; regc(MAGIC); if (reg(0, &flags) == NULL) return (NULL); /* Dig out information for optimizations. */ r->regstart = '\0'; /* Worst-case defaults. */ r->reganch = 0; r->regmust = NULL; r->regmlen = 0; r->regsize = sizeof(rep_regexp) + (unsigned)regsize; scan = r->program + 1; /* First BRANCH. */ if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ scan = OPERAND(scan); /* Starting-point info. */ if (OP(scan) == EXACTLY) r->regstart = UCHARAT(OPERAND(scan)); else if (OP(scan) == BOL) r->reganch++; /* * If there's something expensive in the r.e., find the longest * literal string that must appear and make it the regmust. Resolve * ties in favor of later strings, since the regstart check works * with the beginning of the r.e. and avoiding duplication * strengthens checking. Not a strong reason, but sufficient in the * absence of others. */ if (flags & SPSTART) { longest = NULL; len = 0; for (; scan != NULL; scan = regnext(scan)) if (OP(scan) == EXACTLY && strlen(OPERAND(scan)) >= len) { longest = OPERAND(scan); len = strlen(OPERAND(scan)); } r->regmust = longest; r->regmlen = len; } } #ifdef DEBUG if (regenable_debug) { printf ("compiled `%s' to:\n", exp); regdump (r); } #endif return (r); } /* * - reg - regular expression, i.e. main body or parenthesized thing * * Caller must absorb opening parenthesis. * * Combining parenthesis handling with the base level of regular expression is a * trifle forced, but the need to tie the tails of the branches to what * follows makes it hard to avoid. */ static char * reg(int paren, int *flagp) { register char *ret; register char *br; register char *ender; register int parno = 0; int flags; *flagp = HASWIDTH; /* Tentatively. */ /* Make an OPEN node, if parenthesized. */ if (paren) { if (regnpar >= rep_NSUBEXP) FAIL("too many ()"); parno = regnpar; regnpar++; ret = regnode(OPEN + parno); } else ret = NULL; /* Pick up the branches, linking them together. */ br = regbranch(&flags); if (br == NULL) return (NULL); if (ret != NULL) regtail(ret, br); /* OPEN -> first. */ else ret = br; if (!(flags & HASWIDTH)) *flagp &= ~HASWIDTH; *flagp |= flags & SPSTART; while (*regparse == '|') { regparse++; br = regbranch(&flags); if (br == NULL) return (NULL); regtail(ret, br); /* BRANCH -> BRANCH. */ if (!(flags & HASWIDTH)) *flagp &= ~HASWIDTH; *flagp |= flags & SPSTART; } /* Make a closing node, and hook it on the end. */ ender = regnode((paren) ? CLOSE + parno : END); regtail(ret, ender); /* Hook the tails of the branches to the closing node. */ for (br = ret; br != NULL; br = regnext(br)) regoptail(br, ender); /* Check for proper termination. */ if (paren && *regparse++ != ')') { FAIL("unmatched ()"); } else if (!paren && *regparse != '\0') { if (*regparse == ')') { FAIL("unmatched ()"); } else FAIL("junk on end");/* "Can't happen". */ /* NOTREACHED */ } return (ret); } /* * - regbranch - one alternative of an | operator * * Implements the concatenation operator. */ static char * regbranch(int *flagp) { register char *ret; register char *chain; register char *latest; int flags; *flagp = WORST; /* Tentatively. */ ret = regnode(BRANCH); chain = NULL; while (*regparse != '\0' && *regparse != '|' && *regparse != ')') { latest = regpiece(&flags); if (latest == NULL) return (NULL); *flagp |= flags & HASWIDTH; if (chain == NULL) /* First piece. */ *flagp |= flags & SPSTART; else regtail(chain, latest); chain = latest; } if (chain == NULL) /* Loop ran zero times. */ (void) regnode(NOTHING); return (ret); } /* * - regpiece - something followed by possible [*+?] * * Note that the branching code sequences used for ? and the general cases of * * and + are somewhat optimized: they use the same NOTHING node as both the * endmarker for their branch list and the body of the last branch. It might * seem that this node could be dispensed with entirely, but the endmarker * role is not redundant. */ static char * regpiece(int *flagp) { register char *ret; register char op; register char *next; int flags; int greedy; ret = regatom(&flags); if (ret == NULL) return (NULL); op = *regparse; if (!ISMULT(op)) { *flagp = flags; return (ret); } if (!(flags & HASWIDTH) && op != '?') FAIL("*+ operand could be empty"); *flagp = (op != '+') ? (WORST | SPSTART) : (WORST | HASWIDTH); greedy = (regparse[1] != '?'); if (op == '*' && (flags & SIMPLE)) reginsert(greedy ? STAR : NGSTAR, ret); else if (op == '*') { if (greedy) { /* Emit x* as (x&|), where & means "self". */ reginsert(BRANCH, ret); /* Either x */ regoptail(ret, regnode(BACK)); /* and loop */ regoptail(ret, ret); /* back */ regtail(ret, regnode(BRANCH)); /* or */ regtail(ret, regnode(NOTHING)); /* null. */ } else { /* Emit x*? as (|x&), where & means "self". */ reginsert(BRANCH, ret); /* Either */ reginsert(NOTHING, ret); /* null. */ reginsert(BRANCH, ret); /* or x */ regtail(ret+9, regnode(BACK)); /* and loop */ regtail(ret+9, ret); /* back */ regtail(ret, ret+6); regtail(ret+3, regcode); } } else if (op == '+' && (flags & SIMPLE)) reginsert(greedy ? PLUS : NGPLUS, ret); else if (op == '+') { if (greedy) { /* Emit x+ as x(&|), where & means "self". */ next = regnode(BRANCH); /* Either */ regtail(ret, next); regtail(regnode(BACK), ret); /* loop back */ regtail(next, regnode(BRANCH)); /* or */ regtail(ret, regnode(NOTHING)); /* null. */ } else { char *null, *b2; /* Emit x+? as x(|&), where & means "self". */ next = regnode(BRANCH); /* Either */ regtail(ret, next); null = regnode(NOTHING); /* null */ b2 = regnode(BRANCH); regtail(regnode(BACK), ret); /* or loop back */ regtail(next, b2); regtail(null, regcode); } } else if (op == '?') { if (greedy) { /* Emit x? as (x|) */ reginsert(BRANCH, ret); /* Either x */ regtail(ret, regnode(BRANCH)); /* or */ next = regnode(NOTHING); /* null. */ regtail(ret, next); regoptail(ret, next); } else { /* Emit x?? as (|x) */ reginsert(BRANCH, ret); reginsert(NOTHING, ret); /* Either null */ reginsert(BRANCH, ret); /* or x. */ regoptail(ret, regcode); regtail(ret, ret + 6); regtail(ret, regcode); } } if (greedy) regparse++; else regparse += 2; if (ISMULT(*regparse)) FAIL("nested *?+"); return (ret); } /* * - regatom - the lowest level * * Optimization: gobbles an entire sequence of ordinary characters so that it * can turn them into a single node, which is smaller to store and faster to * run. Backslashed characters are exceptions, each becoming a separate * node; the code is simpler that way and it's not worth fixing. */ static char * regatom(int *flagp) { register char *ret; int flags; *flagp = WORST; /* Tentatively. */ switch (*regparse++) { case '^': ret = regnode(BOL); break; case '$': ret = regnode(EOL); break; case '.': ret = regnode(ANY); *flagp |= HASWIDTH | SIMPLE; break; case '[':{ register int class; register int classend; if (*regparse == '^') { /* Complement of range. */ ret = regnode(ANYBUT); regparse++; } else ret = regnode(ANYOF); if (*regparse == ']' || *regparse == '-') regc(*regparse++); while (*regparse != '\0' && *regparse != ']') { if (*regparse == '-') { regparse++; if (*regparse == ']' || *regparse == '\0') regc('-'); else { class = UCHARAT(regparse - 2) + 1; classend = UCHARAT(regparse); if (class > classend + 1) FAIL("invalid [] range"); for (; class <= classend; class++) regc(class); regparse++; } } else regc(*regparse++); } regc('\0'); if (*regparse != ']') FAIL("unmatched []"); regparse++; *flagp |= HASWIDTH | SIMPLE; } break; case '(': ret = reg(1, &flags); if (ret == NULL) return (NULL); *flagp |= flags & (HASWIDTH | SPSTART); break; case '\0': case '|': case ')': FAIL("internal urp"); /* Supposed to be caught earlier. */ break; case '?': case '+': case '*': FAIL("?+* follows nothing"); break; case '\\': switch (*regparse++) { case '\0': FAIL("trailing \\"); break; case 'w': ret = regnode (WORD); *flagp |= HASWIDTH | SIMPLE; break; case 'W': ret = regnode (NWORD); *flagp |= HASWIDTH | SIMPLE; break; case 's': ret = regnode (WSPC); *flagp |= HASWIDTH | SIMPLE; break; case 'S': ret = regnode (NWSPC); *flagp |= HASWIDTH | SIMPLE; break; case 'd': ret = regnode (DIGI); *flagp |= HASWIDTH | SIMPLE; break; case 'D': ret = regnode (NDIGI); *flagp |= HASWIDTH | SIMPLE; break; case 'b': ret = regnode (WEDGE); break; case 'B': ret = regnode (NWEDGE); break; default: ret = regnode(EXACTLY); regc(regparse[-1]); regc('\0'); *flagp |= HASWIDTH | SIMPLE; } break; default:{ register int len; register char ender; regparse--; len = strcspn(regparse, META); if (len <= 0) FAIL("internal disaster"); ender = *(regparse + len); if (len > 1 && ISMULT(ender)) len--; /* Back off clear of ?+* operand. */ *flagp |= HASWIDTH; if (len == 1) *flagp |= SIMPLE; ret = regnode(EXACTLY); while (len > 0) { regc(*regparse++); len--; } regc('\0'); } break; } return (ret); } /* * - regnode - emit a node */ static char * /* Location. */ regnode(char op) { register char *ret; register char *ptr; ret = regcode; if (ret == ®dummy) { regsize += 3; return (ret); } ptr = ret; *ptr++ = op; *ptr++ = '\0'; /* Null "next" pointer. */ *ptr++ = '\0'; regcode = ptr; return (ret); } /* * - regc - emit (if appropriate) a byte of code */ static void regc(char b) { if (regcode != ®dummy) *regcode++ = b; else regsize++; } /* * - reginsert - insert an operator in front of already-emitted operand * * Means relocating the operand. */ static void reginsert(char op, char *opnd) { register char *src; register char *dst; register char *place; if (regcode == ®dummy) { regsize += 3; return; } src = regcode; regcode += 3; dst = regcode; while (src > opnd) *--dst = *--src; place = opnd; /* Op node, where operand used to be. */ *place++ = op; *place++ = '\0'; *place++ = '\0'; } /* * - regtail - set the next-pointer at the end of a node chain */ static void regtail(char *p, char *val) { register char *scan; register char *temp; register int offset; if (regcode == ®dummy) return; /* Find last node. */ scan = p; for (;;) { temp = regnext(scan); if (temp == NULL) break; scan = temp; } if (OP(scan) == BACK) offset = scan - val; else offset = val - scan; *(scan + 1) = (offset >> 8) & 0377; *(scan + 2) = offset & 0377; } /* * - regoptail - regtail on operand of first argument; nop if operandless */ static void regoptail(char *p, char *val) { /* "Operandless" and "op != BRANCH" are synonymous in practice. */ if (p == NULL || regcode == ®dummy || OP(p) != BRANCH) return; regtail(OPERAND(p), val); } /* * regexec and friends */ /* * Global work variables for regexec(). */ static char *reginput; /* String-input pointer. */ static char *regbol; /* Beginning of input, for ^ check. */ static char **regstartp; /* Pointer to startp array. */ static char **regendp; /* Ditto for endp. */ static char regnocase; /* Ignore case when string-matching. */ static int regnest; /* depth of recursion */ int rep_regexp_max_depth = 2048; /* * Forwards. */ static int regtry(rep_regexp *, char *); static int regmatch(char *); static int regrepeat(char *); #ifdef DEBUG int regnarrate = 0; char *regprop(char *); #endif /* DEBUG */ /* * - regexec - match a regexp against a string * * jsh -- changed regexec to regexec2 with an extra argument for flag bits, * flags are REG_NOTBOL and REG_NOCASE. */ int rep_regexec2(rep_regexp *prog, char *string, int eflags) { register char *s; /* For REG_NOCASE and strpbrk() */ static char mat[3] = "xX"; /* Be paranoid... */ if (prog == NULL || string == NULL) { rep_regerror("NULL parameter"); return (0); } /* Check validity of program. */ if (UCHARAT(prog->program) != MAGIC) { rep_regerror("corrupted program"); return (0); } /* jsh -- Check for REG_NOCASE, means ignore case in string matches. */ regnocase = ((eflags & rep_REG_NOCASE) != 0); /* If there is a "must appear" string, look for it. */ if (prog->regmust != NULL) { s = string; if(regnocase) { mat[0] = tolower(UCHARAT(prog->regmust)); mat[1] = toupper(UCHARAT(prog->regmust)); while ((s = strpbrk(s, mat)) != NULL) { if(strncasecmp(s, prog->regmust, prog->regmlen) == 0) break; /* Found it. */ s++; } } else { while ((s = strchr(s, prog->regmust[0])) != NULL) { if(strncmp(s, prog->regmust, prog->regmlen) == 0) break; /* Found it. */ s++; } } if (s == NULL) /* Not present. */ return (0); } /* Mark beginning of line for ^ . */ /* jsh -- if REG_NOTBOL is set then set regbol to something absurd to guarantee ^ doesn't match */ regbol = (eflags & rep_REG_NOTBOL) ? "" : string; /* Simplest case: anchored match need be tried only once. */ if (prog->reganch) return (regtry(prog, string)); /* Messy cases: unanchored match. */ s = string; if (prog->regstart != '\0') { /* We know what char it must start with. */ if(regnocase) { mat[0] = tolower(prog->regstart); mat[1] = toupper(prog->regstart); while((s = strpbrk(s, mat)) != NULL) { if(regtry(prog, s)) return (1); s++; } } else { while((s = strchr(s, prog->regstart)) != NULL) { if(regtry(prog, s)) return (1); s++; } } } else /* We don't -- general case. */ do { if (regtry(prog, s)) return (1); } while (*s++ != '\0'); /* Failure. */ return (0); } /* * - regmatch_string - match a regexp against the string STRING. * No searching */ int rep_regmatch_string(rep_regexp *prog, char *string, int eflags) { /* Check for REG_NOCASE, means ignore case in string matches. */ regnocase = ((eflags & rep_REG_NOCASE) != 0); /* Mark beginning of line for ^ . */ /* jsh -- if REG_NOTBOL is set then set regbol to something absurd to guarantee ^ doesn't match */ regbol = (eflags & rep_REG_NOTBOL) ? "" : string; return regtry(prog, string); } /* * - regtry - try match at specific point */ static int /* 0 failure, 1 success */ regtry(rep_regexp *prog, char *string) { register int i; register char **sp; register char **ep; reginput = string; regstartp = prog->matches.string.startp; regendp = prog->matches.string.endp; regnest = 0; sp = prog->matches.string.startp; ep = prog->matches.string.endp; for (i = rep_NSUBEXP; i > 0; i--) { *sp++ = NULL; *ep++ = NULL; } if (regmatch(prog->program + 1)) { regstartp[0] = string; regendp[0] = reginput; prog->lasttype = rep_reg_string; return (1); } else return (0); } /* get around the insane number of return statements in regmatch () */ static inline int nested_regmatch (char *prog) { int ret; regnest++; ret = regmatch (prog); regnest--; return ret; } /* * - regmatch - main matching routine * * Conceptually the strategy is simple: check to see whether the current node * matches, call self recursively to see whether the rest matches, and then * act accordingly. In practice we make some effort to avoid recursion, in * particular by going through "ordinary" nodes (that don't need to know * whether the rest of the match failed) by a loop instead of by recursion. */ static int /* 0 failure, 1 success */ regmatch(char *prog) { register char *scan; /* Current node. */ char *next; /* Next node. */ if (regnest >= rep_regexp_max_depth) { /* recursion overload, bail out */ rep_regerror ("stack overflow"); return 0; } scan = prog; #ifdef DEBUG if (scan != NULL && regnarrate) fprintf(stderr, "%s(\n", regprop(scan)); #endif while (scan != NULL) { #ifdef DEBUG if (regnarrate) fprintf(stderr, "%s...\n", regprop(scan)); #endif next = regnext(scan); switch (OP(scan)) { case BOL: if (reginput != regbol) return (0); break; case EOL: if (*reginput != '\0') return (0); break; case ANY: if (*reginput == '\0') return (0); reginput++; break; case EXACTLY:{ register int len; register char *opnd; opnd = OPERAND(scan); if(regnocase) { /* Inline the first character, for speed. */ if(toupper(UCHARAT(opnd)) != toupper(UCHARAT(reginput))) return (0); len = strlen(opnd); if(len > 1 && strncasecmp(opnd, reginput, len) != 0) return (0); } else { /* Inline the first character, for speed. */ if(*opnd != *reginput) return (0); len = strlen(opnd); if(len > 1 && strncmp(opnd, reginput, len) != 0) return (0); } reginput += len; } break; case ANYOF: if (*reginput == '\0' || strchr(OPERAND(scan), *reginput) == NULL) return (0); reginput++; break; case ANYBUT: if (*reginput == '\0' || strchr(OPERAND(scan), *reginput) != NULL) return (0); reginput++; break; case NOTHING: break; case BACK: break; case OPEN + 1: case OPEN + 2: case OPEN + 3: case OPEN + 4: case OPEN + 5: case OPEN + 6: case OPEN + 7: case OPEN + 8: case OPEN + 9:{ register int no; register char *save; no = OP(scan) - OPEN; save = reginput; if (nested_regmatch(next)) { /* * Don't set startp if some later invocation of the same * parentheses already has. */ if (regstartp[no] == NULL) regstartp[no] = save; return (1); } else return (0); } break; case CLOSE + 1: case CLOSE + 2: case CLOSE + 3: case CLOSE + 4: case CLOSE + 5: case CLOSE + 6: case CLOSE + 7: case CLOSE + 8: case CLOSE + 9:{ register int no; register char *save; no = OP(scan) - CLOSE; save = reginput; if (nested_regmatch(next)) { /* * Don't set endp if some later invocation of the same * parentheses already has. */ if (regendp[no] == NULL) regendp[no] = save; return (1); } else return (0); } break; case BRANCH:{ register char *save; if (OP(next) != BRANCH) /* No choice. */ next = OPERAND(scan); /* Avoid recursion. */ else { do { save = reginput; if (nested_regmatch(OPERAND(scan))) return (1); reginput = save; scan = regnext(scan); } while (scan != NULL && OP(scan) == BRANCH); return (0); /* NOTREACHED */ } } break; case STAR: case PLUS:{ register char nextch; register int no; register char *save; register int min; /* * Lookahead to avoid useless match attempts when we know * what character comes next. */ nextch = '\0'; if (OP(next) == EXACTLY) nextch = UCHARAT(OPERAND(next)); if(regnocase) nextch = toupper(nextch); min = (OP(scan) == STAR) ? 0 : 1; save = reginput; no = regrepeat(OPERAND(scan)); while (no >= min) { /* If it could work, try it. */ if (nextch == '\0' || (regnocase ? toupper(UCHARAT(reginput)) : *reginput) == nextch) if (nested_regmatch(next)) return (1); /* Couldn't or didn't -- back up. */ no--; reginput = save + no; } return (0); } break; case NGSTAR: case NGPLUS:{ register char nextch; register int no; register char *save; register int max; /* * Lookahead to avoid useless match attempts when we know * what character comes next. */ nextch = '\0'; if (OP(next) == EXACTLY) nextch = UCHARAT(OPERAND(next)); if(regnocase) nextch = toupper(nextch); no = (OP(scan) == NGSTAR) ? 0 : 1; save = reginput; max = regrepeat(OPERAND(scan)); while (no <= max) { reginput = save + no; /* If it could work, try it. */ if (nextch == '\0' || (regnocase ? toupper(UCHARAT(reginput)) : *reginput) == nextch) if (nested_regmatch(next)) return (1); /* Couldn't or didn't -- move up. */ no++; } return (0); } break; case WORD: if (*reginput != '_' && !isalnum (UCHARAT(reginput))) return 0; reginput++; break; case NWORD: if (*reginput == '_' || isalnum (UCHARAT(reginput))) return 0; reginput++; break; case WSPC: if (!isspace (UCHARAT(reginput))) return 0; reginput++; break; case NWSPC: if (isspace (UCHARAT(reginput))) return 0; reginput++; break; case DIGI: if (!isdigit (UCHARAT(reginput))) return 0; reginput++; break; case NDIGI: if (isdigit (UCHARAT(reginput))) return 0; reginput++; break; case WEDGE: if (reginput == regbol || *reginput == '\0' || ((reginput[-1] == '_' || isalnum (UCHARAT(reginput - 1))) && (*reginput != '_' && !isalnum (UCHARAT(reginput)))) || ((reginput[-1] != '_' && !isalnum (UCHARAT(reginput - 1))) && (*reginput == '_' || isalnum (UCHARAT(reginput))))) break; return 0; case NWEDGE: if (!(reginput == regbol || *reginput == '\0' || ((reginput[-1] == '_' || isalnum (UCHARAT(reginput - 1))) && (*reginput != '_' && !isalnum (UCHARAT(reginput)))) || ((reginput[-1] != '_' && !isalnum (UCHARAT(reginput - 1))) && (*reginput == '_' || isalnum (UCHARAT(reginput)))))) break; return 0; case END: return (1); /* Success! */ break; default: rep_regerror("memory corruption"); return (0); break; } scan = next; } /* * We get here only if there's trouble -- normally "case END" is the * terminating point. */ rep_regerror("corrupted pointers"); return (0); } /* * - regrepeat - repeatedly match something simple, report how many */ static int regrepeat(char *p) { int count; register char *scan; register char *opnd; scan = reginput; opnd = OPERAND(p); switch (OP(p)) { case ANY: scan += strlen(scan); break; case EXACTLY: if(regnocase) { while(toupper(UCHARAT(opnd)) == toupper(UCHARAT(scan))) { scan++; } } else { while(*opnd == *scan) { scan++; } } break; case ANYOF: while (*scan != '\0' && strchr(opnd, *scan) != NULL) { scan++; } break; case ANYBUT: while (*scan != '\0' && strchr(opnd, *scan) == NULL) { scan++; } break; case WORD: while (*scan != '\0' && (*scan == '_' || isalnum (UCHARAT(scan)))) { scan++; } break; case NWORD: while (*scan != '\0' && (*scan != '_' && !isalnum (UCHARAT(scan)))) { scan++; } break; case WSPC: while (*scan != '\0' && isspace (UCHARAT(scan))) { scan++; } break; case NWSPC: while (*scan != '\0' && !isspace (UCHARAT(scan))) { scan++; } break; case DIGI: while (*scan != '\0' && isdigit (UCHARAT(scan))) { scan++; } break; case NDIGI: while (*scan != '\0' && !isdigit (UCHARAT(scan))) { scan++; } break; default: /* Oh dear. Called inappropriately. */ rep_regerror("internal foulup"); return 0; /* Best compromise. */ break; } count = scan - reginput; reginput = scan; return count; } /* * - regnext - dig the "next" pointer out of a node */ static char * regnext(char *p) { register int offset; if (p == ®dummy) return (NULL); offset = NEXT(p); if (offset == 0) return (NULL); if (OP(p) == BACK) return (p - offset); else return (p + offset); } #ifdef DEBUG char *regprop(); /* * - regdump - dump a regexp onto stdout in vaguely comprehensible form */ void regdump(rep_regexp *r) { register char *s; register char op = EXACTLY; /* Arbitrary non-END op. */ register char *next; s = r->program + 1; while (op != END) { /* While that wasn't END last time... */ op = OP(s); printf("\t%4d%s", s - r->program, regprop(s)); /* Where, what. */ next = regnext(s); if (next == NULL) /* Next ptr. */ printf("(0)"); else printf("(%d)", (s - r->program) + (next - s)); s += 3; if (op == ANYOF || op == ANYBUT || op == EXACTLY) { /* Literal string, where present. */ while (*s != '\0') { putchar(*s); s++; } s++; } putchar('\n'); } /* Header fields of interest. */ if (r->regstart != '\0') printf("start `%c' ", r->regstart); if (r->reganch) printf("anchored "); if (r->regmust != NULL) printf("must have \"%s\"", r->regmust); printf("\n"); } /* * - regprop - printable representation of opcode */ char * regprop(char *op) { register char *p; static char buf[50]; (void) strcpy(buf, ":"); switch (OP(op)) { case BOL: p = "BOL"; break; case EOL: p = "EOL"; break; case ANY: p = "ANY"; break; case ANYOF: p = "ANYOF"; break; case ANYBUT: p = "ANYBUT"; break; case BRANCH: p = "BRANCH"; break; case EXACTLY: p = "EXACTLY"; break; case NOTHING: p = "NOTHING"; break; case BACK: p = "BACK"; break; case END: p = "END"; break; case OPEN + 1: case OPEN + 2: case OPEN + 3: case OPEN + 4: case OPEN + 5: case OPEN + 6: case OPEN + 7: case OPEN + 8: case OPEN + 9: sprintf(buf + strlen(buf), "OPEN%d", OP(op) - OPEN); p = NULL; break; case CLOSE + 1: case CLOSE + 2: case CLOSE + 3: case CLOSE + 4: case CLOSE + 5: case CLOSE + 6: case CLOSE + 7: case CLOSE + 8: case CLOSE + 9: sprintf(buf + strlen(buf), "CLOSE%d", OP(op) - CLOSE); p = NULL; break; case STAR: p = "STAR"; break; case PLUS: p = "PLUS"; break; case WORD: p = "WORD"; break; case NWORD: p = "NWORD"; break; case WSPC: p = "WSPC"; break; case NWSPC: p = "NWSPC"; break; case DIGI: p = "DIGI"; break; case NDIGI: p = "NDIGI"; break; case WEDGE: p = "WEDGE"; break; case NWEDGE: p = "NWEDGE"; break; case NGSTAR: p = "NGSTAR"; break; case NGPLUS: p = "NGPLUS"; break; default: rep_regerror("corrupted opcode"); p = 0; break; } if (p != NULL) (void) strcat(buf, p); return (buf); } #endif /* * The following is provided for those people who do not have strcspn() in * their C libraries. They should get off their butts and do something about * it; at least one public-domain implementation of those (highly useful) * string routines has been published on Usenet. */ #ifndef HAVE_STRCSPN /* * strcspn - find length of initial segment of s1 consisting entirely of * characters not from s2 */ int strcspn(char *s1, char *s2) { register char *scan1; register char *scan2; register int count; count = 0; for (scan1 = s1; *scan1 != '\0'; scan1++) { for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ if (*scan1 == *scan2++) return (count); count++; } return (count); } #endif librep-0.90.2/src/regexp.30000644000175200017520000001505111245011153014225 0ustar chrischris.TH REGEXP 3 local .DA 2 April 1986 .SH NAME regcomp, regexec, regsub, regerror \- regular expression handler .SH SYNOPSIS .ft B .nf #include regexp *regcomp(exp) char *exp; int regexec(prog, string) regexp *prog; char *string; regsub(prog, source, dest) regexp *prog; char *source; char *dest; regerror(msg) char *msg; .SH DESCRIPTION These functions implement .IR egrep (1)-style regular expressions and supporting facilities. .PP .I Regcomp compiles a regular expression into a structure of type .IR regexp , and returns a pointer to it. The space has been allocated using .IR malloc (3) and may be released by .IR free . .PP .I Regexec matches a NUL-terminated \fIstring\fR against the compiled regular expression in \fIprog\fR. It returns 1 for success and 0 for failure, and adjusts the contents of \fIprog\fR's \fIstartp\fR and \fIendp\fR (see below) accordingly. .PP The members of a .I regexp structure include at least the following (not necessarily in order): .PP .RS char *startp[NSUBEXP]; .br char *endp[NSUBEXP]; .RE .PP where .I NSUBEXP is defined (as 10) in the header file. Once a successful \fIregexec\fR has been done using the \fIregexp\fR, each \fIstartp\fR-\fIendp\fR pair describes one substring within the \fIstring\fR, with the \fIstartp\fR pointing to the first character of the substring and the \fIendp\fR pointing to the first character following the substring. The 0th substring is the substring of \fIstring\fR that matched the whole regular expression. The others are those substrings that matched parenthesized expressions within the regular expression, with parenthesized expressions numbered in left-to-right order of their opening parentheses. .PP .I Regsub copies \fIsource\fR to \fIdest\fR, making substitutions according to the most recent \fIregexec\fR performed using \fIprog\fR. Each instance of `&' in \fIsource\fR is replaced by the substring indicated by \fIstartp\fR[\fI0\fR] and \fIendp\fR[\fI0\fR]. Each instance of `\e\fIn\fR', where \fIn\fR is a digit, is replaced by the substring indicated by \fIstartp\fR[\fIn\fR] and \fIendp\fR[\fIn\fR]. To get a literal `&' or `\e\fIn\fR' into \fIdest\fR, prefix it with `\e'; to get a literal `\e' preceding `&' or `\e\fIn\fR', prefix it with another `\e'. .PP .I Regerror is called whenever an error is detected in \fIregcomp\fR, \fIregexec\fR, or \fIregsub\fR. The default \fIregerror\fR writes the string \fImsg\fR, with a suitable indicator of origin, on the standard error output and invokes \fIexit\fR(2). .I Regerror can be replaced by the user if other actions are desirable. .SH "REGULAR EXPRESSION SYNTAX" A regular expression is zero or more \fIbranches\fR, separated by `|'. It matches anything that matches one of the branches. .PP A branch is zero or more \fIpieces\fR, concatenated. It matches a match for the first, followed by a match for the second, etc. .PP A piece is an \fIatom\fR possibly followed by `*', `+', or `?'. An atom followed by `*' matches a sequence of 0 or more matches of the atom. An atom followed by `+' matches a sequence of 1 or more matches of the atom. An atom followed by `?' matches a match of the atom, or the null string. .PP An atom is a regular expression in parentheses (matching a match for the regular expression), a \fIrange\fR (see below), `.' (matching any single character), `^' (matching the null string at the beginning of the input string), `$' (matching the null string at the end of the input string), a `\e' followed by a single character (matching that character), or a single character with no other significance (matching that character). .PP A \fIrange\fR is a sequence of characters enclosed in `[]'. It normally matches any single character from the sequence. If the sequence begins with `^', it matches any single character \fInot\fR from the rest of the sequence. If two characters in the sequence are separated by `\-', this is shorthand for the full list of ASCII characters between them (e.g. `[0-9]' matches any decimal digit). To include a literal `]' in the sequence, make it the first character (following a possible `^'). To include a literal `\-', make it the first or last character. .SH AMBIGUITY If a regular expression could match two different parts of the input string, it will match the one which begins earliest. If both begin in the same place but match different lengths, or match the same length in different ways, life gets messier, as follows. .PP In general, the possibilities in a list of branches are considered in left-to-right order, the possibilities for `*', `+', and `?' are considered longest-first, nested constructs are considered from the outermost in, and concatenated constructs are considered leftmost-first. The match that will be chosen is the one that uses the earliest possibility in the first choice that has to be made. If there is more than one choice, the next will be made in the same manner (earliest possibility) subject to the decision on the first choice. And so forth. .PP For example, `(ab|a)b*c' could match `abc' in one of two ways. The first choice is between `ab' and `a'; since `ab' is earlier, and does lead to a successful overall match, it is chosen. Since the `b' is already spoken for, the `b*' must match its last possibility\(emthe empty string\(emsince it must respect the earlier choice. .PP In the particular case where no `|'s are present and there is only one `*', `+', or `?', the net effect is that the longest possible match will be chosen. So `ab*', presented with `xabbbby', will match `abbbb'. Note that if `ab*' is tried against `xabyabbbz', it will match `ab' just after `x', due to the begins-earliest rule. (In effect, the decision on where to start the match is the first choice to be made, hence subsequent choices must respect it even if this leads them to less-preferred alternatives.) .SH SEE ALSO egrep(1), expr(1) .SH DIAGNOSTICS \fIRegcomp\fR returns NULL for a failure (\fIregerror\fR permitting), where failures are syntax errors, exceeding implementation limits, or applying `+' or `*' to a possibly-null operand. .SH HISTORY Both code and manual page were written at U of T. They are intended to be compatible with the Bell V8 \fIregexp\fR(3), but are not derived from Bell code. .SH BUGS Empty branches and empty regular expressions are not portable to V8. .PP The restriction against applying `*' or `+' to a possibly-null operand is an artifact of the simplistic implementation. .PP Does not support \fIegrep\fR's newline-separated branches; neither does the V8 \fIregexp\fR(3), though. .PP Due to emphasis on compactness and simplicity, it's not strikingly fast. It does give special attention to handling simple cases quickly. librep-0.90.2/src/record-profile.c0000644000175200017520000001127711245011153015735 0ustar chrischris/* record-profile.c -- very basic Lisp profiler Copyright (C) 2000 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* Commentary: Hook into the interrupt-checking code to record the current backtrace statistics. Uses SIGPROF to tell the lisp system when it should interrupt (can't run the profiler off the signal itself, since data would need to be allocated from the signal handler) */ #define _GNU_SOURCE /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include #ifdef HAVE_UNISTD_H # include #endif #ifdef HAVE_SYS_TIME_H # include #endif static repv profile_table; static rep_bool profiling; static void (*chained_test_interrupt)(void); static int profile_interval = 10; /* microseconds */ /* SIGPROF handling */ #ifdef HAVE_SETITIMER static RETSIGTYPE sigprof_handler (int unused) { /* force an interrupt */ rep_test_int_counter = rep_test_int_period; } #endif static void set_timer (void) { #ifdef HAVE_SETITIMER struct itimerval it, tem; it.it_interval.tv_usec = 0; it.it_interval.tv_sec = 0; it.it_value.tv_usec = profile_interval % 1000000; it.it_value.tv_sec = profile_interval / 1000000; setitimer (ITIMER_PROF, &it, &tem); signal (SIGPROF, sigprof_handler); #endif } static void clear_timer (void) { #ifdef HAVE_SETITIMER signal (SIGPROF, SIG_IGN); #endif } /* profile recording */ static void test_interrupt (void) { if (profiling) { repv *seen = alloca (rep_max_lisp_depth * sizeof (repv)); struct rep_Call *c; int seen_i = 0; for (c = rep_call_stack; c != 0 && c->fun != Qnil; c = c->next) { repv name; switch (rep_TYPE (c->fun)) { case rep_Subr0: case rep_Subr1: case rep_Subr2: case rep_Subr3: case rep_Subr4: case rep_Subr5: case rep_SubrN: name = rep_XSUBR (c->fun)->name; break; case rep_Funarg: name = rep_FUNARG (c->fun)->name; break; default: continue; } if (rep_STRINGP (name)) { repv tem; int j; name = Fintern (name, Qnil); for (j = 0; j < seen_i; j++) { if (seen[j] == name) goto skip; } tem = F_structure_ref (profile_table, name); if (rep_VOIDP (tem)) tem = Fcons (rep_MAKE_INT (0), rep_MAKE_INT (0)); if (c == rep_call_stack) rep_CAR (tem) = rep_MAKE_INT (rep_INT (rep_CAR (tem)) + 1); rep_CDR (tem) = rep_MAKE_INT (rep_INT (rep_CDR (tem)) + 1); Fstructure_define (profile_table, name, tem); seen[seen_i++] = name; } skip: {} } set_timer (); } (*chained_test_interrupt) (); } /* interface */ DEFUN ("start-profiler", Fstart_profiler, Sstart_profiler, (void), rep_Subr0) { profile_table = Fmake_structure (Qnil, Qnil, Qnil, Qnil); profiling = rep_TRUE; set_timer (); return Qt; } DEFUN ("stop-profiler", Fstop_profiler, Sstop_profiler, (void), rep_Subr0) { profiling = rep_FALSE; clear_timer (); return Qt; } DEFUN ("fetch-profile", Ffetch_profile, Sfetch_profile, (void), rep_Subr0) { return profile_table ? profile_table : Qnil; } DEFUN ("profile-interval", Fprofile_interval, Sprofile_interval, (repv arg), rep_Subr1) { repv ret = rep_MAKE_INT (profile_interval); if (rep_INTP (arg) && rep_INT (arg) > 0) profile_interval = rep_INT (arg); return ret; } /* init */ repv rep_dl_init (void) { repv tem = rep_push_structure ("rep.lang.record-profile"); rep_ADD_SUBR (Sstart_profiler); rep_ADD_SUBR (Sstop_profiler); rep_ADD_SUBR (Sfetch_profile); rep_ADD_SUBR (Sprofile_interval); rep_mark_static (&profile_table); #ifdef HAVE_SETITIMER signal (SIGPROF, SIG_IGN); #endif chained_test_interrupt = rep_test_int_fun; rep_test_int_fun = test_interrupt; return rep_pop_structure (tem); } librep-0.90.2/src/realpath.c0000644000175200017520000001245311245011153014616 0ustar chrischris/* Return the canonical absolute name of a given file. Copyright (C) 1996 Free Software Foundation, Inc. This file is part of the GNU C Library. The GNU C Library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with the GNU C Library; see the file COPYING.LIB. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* I've hacked this file to compile with Jade --jsh */ #include #ifndef HAVE_REALPATH /* AIX requires this to be the first thing in the file. */ #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include #include #ifdef NEED_MEMORY_H # include #endif #ifdef HAVE_UNISTD_H # include #endif #include #include #include #ifndef S_ISLNK #define S_ISLNK(mode) (((mode) & S_IFMT) == S_IFLNK) #endif #ifndef S_ISSOCK #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK) #endif /* Return the canonical absolute name of file NAME. A canonical name does not contain any `.', `..' components nor any repeated path separators ('/') or symlinks. All path components must exist. If RESOLVED is null, the result is malloc'd; otherwise, if the canonical name is PATH_MAX chars or more, returns null with `errno' set to ENAMETOOLONG; if the name fits in fewer than PATH_MAX chars, returns the name in RESOLVED. If the name cannot be resolved and RESOLVED is non-NULL, it contains the path of the first component that cannot be resolved. If the path can be resolved, RESOLVED holds the same value as the value returned. */ /* I'll never test errno, so ignore all attempts to set it, in the interests of portability.. */ #define __set_errno(err) char * realpath (const char *name, char *resolved) { char *rpath, *dest, *extra_buf = NULL; const char *start, *end, *rpath_limit; long int path_max; int num_links = 0; #ifdef PATH_MAX path_max = PATH_MAX; #else path_max = pathconf (name, _PC_PATH_MAX); if (path_max <= 0) path_max = 1024; #endif rpath = resolved ? alloca (path_max) : malloc (path_max); rpath_limit = rpath + path_max; if (name[0] != '/') { #ifdef HAVE_GETCWD if (!getcwd (rpath, path_max)) #else if (!getwd (rpath)) #endif goto error; dest = strchr (rpath, '\0'); } else { rpath[0] = '/'; dest = rpath + 1; } for (start = end = name; *start; start = end) { struct stat st; int n; /* skip sequence of multiple path-separators: */ while (*start == '/') ++start; /* find end of path component: */ for (end = start; *end && *end != '/'; ++end); if (end - start == 0) break; else if (strncmp (start, ".", end - start) == 0) /* nothing */; else if (strncmp (start, "..", end - start) == 0) { /* back up to previous component, ignore if at root already: */ if (dest > rpath + 1) while ((--dest)[-1] != '/'); } else { size_t new_size; if (dest[-1] != '/') *dest++ = '/'; if (dest + (end - start) >= rpath_limit) { if (resolved) { __set_errno (ENAMETOOLONG); goto error; } new_size = rpath_limit - rpath; if (end - start + 1 > path_max) new_size += end - start + 1; else new_size += path_max; rpath = realloc (rpath, new_size); rpath_limit = rpath + new_size; if (!rpath) return NULL; } memcpy (dest, start, end - start); dest += end - start; *dest = '\0'; if (lstat (rpath, &st) < 0) goto error; if (S_ISLNK (st.st_mode)) { char *buf = alloca (path_max); if (++num_links > MAXSYMLINKS) { __set_errno (ELOOP); goto error; } n = readlink (rpath, buf, path_max); if (n < 0) goto error; buf[n] = '\0'; if (!extra_buf) extra_buf = alloca (path_max); if ((long int) (n + strlen (end)) >= path_max) { __set_errno (ENAMETOOLONG); goto error; } /* careful here, end may be a pointer into extra_buf... */ strcat (buf, end); strcpy (extra_buf, buf); name = end = extra_buf; if (buf[0] == '/') dest = rpath + 1; /* it's an absolute symlink */ else /* back up to previous component, ignore if at root already: */ if (dest > rpath + 1) while ((--dest)[-1] != '/'); } else num_links = 0; } } if (dest > rpath + 1 && dest[-1] == '/') --dest; *dest = '\0'; return resolved ? strcpy (resolved, rpath) : rpath; error: if (resolved) strcpy (resolved, rpath); else free (rpath); return NULL; } #endif /* !HAVE_REALPATH */ librep-0.90.2/src/readline.c0000644000175200017520000001373611245011153014606 0ustar chrischris/* readline.c -- wrap some readline functions when available Copyright (C) 1999 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include #include #ifdef HAVE_SYS_TIME_H # include #endif #ifdef HAVE_UNISTD_H # include #endif #ifdef HAVE_LIBREADLINE # include # include #endif DEFSYM(rl_completion_generator, "rl-completion-generator"); DEFSYM(boundp, "boundp"); static repv completion_fun; static repv completions; #ifdef HAVE_LIBREADLINE static char *history_file = NULL; static char * completion_generator (char *word, int state) { if (state == 0) { repv fun = completion_fun; if (fun == Qnil) /* backwards compatibility, ugh */ fun = Fsymbol_value (Qrl_completion_generator, Qt); if (Ffunctionp (fun) != Qnil) { completions = (rep_call_with_barrier (Ffuncall, rep_list_2 (fun, rep_string_dup (word)), rep_TRUE, 0, 0, 0)); } else { repv re = Fquote_regexp (rep_string_dup (word)); repv boundp = Fsymbol_value (Qboundp, Qt); completions = Fapropos (rep_concat2("^", rep_STR(re)), boundp, Qnil); } if (completions == rep_NULL) completions = Qnil; } if (completions != Qnil && rep_CONSP(completions) && (rep_SYMBOLP(rep_CAR(completions)) || rep_STRINGP(rep_CAR(completions)))) { repv string = rep_CAR(completions); if (rep_SYMBOLP(string)) string = rep_SYM(string)->name; completions = rep_CDR(completions); return strdup (rep_STR(string)); } else return 0; } /* gratuitously stolen from guile, guile-readline/readline.c */ static int match_paren(int x, int k); static int find_matching_paren(int k); static void init_bouncing_parens(); static void init_bouncing_parens() { if(strncmp(rl_get_keymap_name(rl_get_keymap()), "vi", 2)) { rl_bind_key(')', match_paren); rl_bind_key(']', match_paren); rl_bind_key('}', match_paren); } } static int find_matching_paren(int k) { register int i; register char c = 0; int end_parens_found = 0; /* Choose the corresponding opening bracket. */ if (k == ')') c = '('; else if (k == ']') c = '['; else if (k == '}') c = '{'; for (i=rl_point-2; i>=0; i--) { /* Is the current character part of a character literal? */ if (i - 2 >= 0 && rl_line_buffer[i - 1] == '\\' && rl_line_buffer[i - 2] == '#') ; else if (rl_line_buffer[i] == k) end_parens_found++; else if (rl_line_buffer[i] == '"') { /* Skip over a string literal. */ for (i--; i >= 0; i--) if (rl_line_buffer[i] == '"' && ! (i - 1 >= 0 && rl_line_buffer[i - 1] == '\\')) break; } else if (rl_line_buffer[i] == c) { if (end_parens_found==0) return i; else --end_parens_found; } } return -1; } static int match_paren(int x, int k) { int tmp; fd_set readset; struct timeval timeout; rl_insert(x, k); /* Did we just insert a quoted paren? If so, then don't bounce. */ if (rl_point - 1 >= 1 && rl_line_buffer[rl_point - 2] == '\\') return 0; /* tmp = 200000 */ timeout.tv_sec = 0 /* tmp / 1000000 */ ; timeout.tv_usec = 200000 /* tmp % 1000000 */ ; FD_ZERO(&readset); FD_SET(fileno(rl_instream), &readset); if(rl_point > 1) { tmp = rl_point; rl_point = find_matching_paren(k); if(rl_point > -1) { rl_redisplay(); select(1, &readset, NULL, NULL, &timeout); } rl_point = tmp; } return 0; } #endif DEFUN("readline", Freadline, Sreadline, (repv prompt_, repv completer), rep_Subr2) { char *prompt = rep_STRINGP(prompt_) ? ((char *) rep_STR(prompt_)) : "> "; #ifdef HAVE_LIBREADLINE char *input; repv ret = Qnil, saved; rep_GC_root gc_saved; saved = completion_fun; completion_fun = completer; rep_PUSHGC (gc_saved, saved); input = readline (prompt); rep_POPGC; completion_fun = saved; if (input) { int len = strlen (input); if (len > 0) add_history (input); ret = rep_make_string (len + 2); memcpy (rep_STR(ret), input, len); rep_STR(ret)[len] = '\n'; rep_STR(ret)[len+1] = 0; free (input); } completions = Qnil; return ret; #else if (isatty (0)) { fputs (prompt, stderr); fflush (stderr); } return Fread_line (Fstdin_file ()); #endif } /* DL hooks */ repv rep_dl_init(void) { repv tem; rep_INTERN(rl_completion_generator); rep_INTERN(boundp); completions = Qnil; completion_fun = Qnil; rep_mark_static (&completions); rep_mark_static (&completion_fun); #ifdef HAVE_LIBREADLINE rl_completion_entry_function = (void *) completion_generator; rl_basic_quote_characters = "\""; if (isatty (0) && getenv("HOME")) { history_file=(char*) malloc((uint) strlen(getenv("HOME")) + (uint) strlen("/.rep_history") +2); if (history_file) { sprintf(history_file, "%s/.rep_history",getenv("HOME")); read_history(history_file); } } init_bouncing_parens(); #endif tem = rep_push_structure ("rep.io.readline"); /* ::alias:readline rep.io.readline:: */ rep_alias_structure ("readline"); rep_ADD_SUBR(Sreadline); return rep_pop_structure (tem); } #ifdef HAVE_LIBREADLINE void rep_dl_kill (void) { if (history_file) { write_history(history_file); free(history_file); } } #endif librep-0.90.2/src/origin.c0000644000175200017520000001045011245011153014300 0ustar chrischris/* origin.c -- tracking location from which lists were read Copyright (C) 2001 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" typedef struct origin_item origin_item; struct origin_item { origin_item *next; repv form; repv file; long line; }; #define BLOCK_SIZE (4084 / sizeof (struct origin_item)) typedef struct origin_block origin_block; struct origin_block { origin_block *next; struct origin_item items[BLOCK_SIZE]; }; static origin_item *free_list; static origin_block *block_list; static repv guardian; rep_bool rep_record_origins; #define HASH_SIZE 1024 #define HASH(x) (((x) >> 3) % HASH_SIZE) static origin_item *buckets[HASH_SIZE]; static void new_item_block (void) { origin_block *b; int i; b = rep_alloc (sizeof (origin_block)); for (i = 0; i < (BLOCK_SIZE - 1); i++) b->items[i].next = &(b->items[i+1]); b->items[i].next = free_list; free_list = &(b->items[0]); b->next = block_list; block_list = b; } void rep_record_origin (repv form, repv stream, long start_line) { origin_item *item; if (!rep_record_origins || !rep_CONSP (form) || !rep_FILEP (stream) || (rep_FILE (stream)->car & rep_LFF_BOGUS_LINE_NUMBER) != 0) { /* nothing to record here */ return; } if (free_list == 0) new_item_block (); item = free_list; free_list = item->next; item->form = form; item->file = rep_FILE (stream)->name; item->line = (start_line > 0 ? start_line : rep_FILE (stream)->line_number); item->next = buckets[HASH (form)]; buckets[HASH (form)] = item; Fprimitive_guardian_push (guardian, form); } DEFUN ("call-with-lexical-origins", Fcall_with_lexical_origins, Scall_with_lexical_origins, (repv thunk), rep_Subr1) { rep_bool old_record_origins = rep_record_origins; repv result; rep_record_origins = rep_TRUE; result = rep_call_lisp0 (thunk); rep_record_origins = old_record_origins; return result; } DEFUN ("lexical-origin", Flexical_origin, Slexical_origin, (repv form), rep_Subr1) { origin_item *item; if (rep_FUNARGP (form)) form = rep_FUNARG (form)->fun; if (!rep_CONSP (form)) return Qnil; for (item = buckets[HASH (form)]; item != 0; item = item->next) { if (item->form == form) return Fcons (item->file, rep_make_long_int (item->line)); } /* no direct hit, scan into the list */ while (rep_CONSP (form)) { repv out = Flexical_origin (rep_CAR (form)); if (out != Qnil) return out; form = rep_CDR (form); } return Qnil; } void rep_mark_origins (void) { int i; rep_MARKVAL (guardian); for (i = 0; i < HASH_SIZE; i++) { origin_item *item; for (item = buckets[i]; item != 0; item = item->next) rep_MARKVAL (item->file); } } DEFUN ("origin-after-gc", Forigin_after_gc, Sorigin_after_gc, (void), rep_Subr0) { repv form; while ((form = Fprimitive_guardian_pop (guardian)) != Qnil) { origin_item **ptr = buckets + HASH (form); while (*ptr != 0) { if ((*ptr)->form == form) { origin_item *item = *ptr; *ptr = item->next; item->next = free_list; free_list = item; } else ptr = &(*ptr)->next; } } return Qnil; } void rep_origin_init (void) { repv tem; guardian = Fmake_primitive_guardian (); tem = Fsymbol_value (Qafter_gc_hook, Qt); if (rep_VOIDP (tem)) tem = Qnil; Fset (Qafter_gc_hook, Fcons (rep_VAL(&Sorigin_after_gc), tem)); tem = rep_push_structure ("rep.lang.debug"); rep_ADD_SUBR(Scall_with_lexical_origins); rep_ADD_SUBR(Slexical_origin); rep_pop_structure (tem); } librep-0.90.2/src/numbers.c0000644000175200017520000020350411245011153014470 0ustar chrischris/* numbers.c -- Implement the tower of numeric types Copyright (C) 1993, 1994, 2000 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include #include #include #include #include #include #include #include #ifdef HAVE_LOCALE_H # include #endif #ifdef HAVE_GMP #include #endif #ifdef NEED_MEMORY_H # include #endif DEFSTRING(div_zero, "Divide by zero"); DEFSTRING(domain_error, "Domain error"); #if !defined (LONG_LONG_MIN) # if defined (LONGLONG_MIN) /* AIX and IRIX use LONGLONG_ */ # define LONG_LONG_MIN LONGLONG_MIN # define LONG_LONG_MAX LONGLONG_MAX # elif defined (LLONG_MIN) /* Solaris uses LLONG_ */ # define LONG_LONG_MIN LLONG_MIN # define LONG_LONG_MAX LLONG_MAX # endif #endif /* XXX hmm.. */ #if !defined (LONG_LONG_MAX) # define LONG_LONG_MAX LONG_MAX #endif #if !defined (LONG_LONG_MIN) # define LONG_LONG_MIN LONG_MIN #endif #if !defined (HAVE_STRTOLL) && defined (HAVE_STRTOQ) # define strtoll strtoq # define HAVE_STRTOLL 1 #endif /* Private type definitions */ typedef struct { repv car; #ifdef HAVE_GMP mpz_t z; #else rep_long_long z; #endif } rep_number_z; #ifndef HAVE_GMP # if SIZEOF_LONG_LONG > SIZEOF_LONG # define BIGNUM_MIN LONG_LONG_MIN # define BIGNUM_MAX LONG_LONG_MAX # else # define BIGNUM_MIN LONG_MIN # define BIGNUM_MAX LONG_MAX # endif #endif #ifdef __FreeBSD__ # define LONG_LONG_MIN LONG_MIN # define LONG_LONG_MAX LONG_MAX #endif typedef struct { repv car; #ifdef HAVE_GMP mpq_t q; #endif } rep_number_q; typedef struct { repv car; double f; } rep_number_f; typedef struct rep_number_block_struct { union { struct rep_number_block_struct *p; /* ensure that the following is aligned correctly */ #ifdef HAVE_GMP mpz_t dummy_z; mpq_t dummy_q; #else rep_long_long dummy_z; #endif double dummy_f; } next; rep_number data[1]; } rep_number_block; #define rep_SIZEOF_NUMBER_BLOCK(n,t) \ (sizeof (rep_number_block) - sizeof (rep_number) + (t) * (n)) #define rep_NUMBER(v,t) (((rep_number_ ## t *) rep_PTR(v))->t) #define rep_NUMBER_INEXACT_P(v) (rep_NUMBERP(v) && rep_NUMBER_FLOAT_P(v)) #define ZEROP(x) \ (rep_INTP (x) ? (x) == rep_MAKE_INT (0) : Fzerop (x) != Qnil) /* number object handling */ static rep_number_block *number_block_chain[3]; static rep_number *number_freelist[3]; static int number_allocations[3], number_sizeofs[3]; static int allocated_numbers, used_numbers; static inline int type_to_index (int type) { return (type == rep_NUMBER_BIGNUM ? 0 : type == rep_NUMBER_RATIONAL ? 1 : 2); } static void * make_number (int type) { rep_number *cn; int idx = type_to_index (type); cn = number_freelist[idx]; if(cn == NULL) { int i; rep_number_block *cb; rep_number *ptr, *next; cb = rep_alloc (rep_SIZEOF_NUMBER_BLOCK (number_allocations[idx], number_sizeofs[idx])); allocated_numbers += number_allocations[idx]; cb->next.p = number_block_chain[idx]; number_block_chain[idx] = cb; ptr = cb->data; for(i = 0; i < (number_allocations[idx] - 1); i++, ptr = next) { next = (rep_number *) (((char *) ptr) + number_sizeofs[idx]); ptr->car = (repv) next; } ptr->car = 0; number_freelist[idx] = (rep_number *) cb->data; cn = number_freelist[idx]; } number_freelist[idx] = (rep_number *) cn->car; cn->car = rep_Number | type; used_numbers++; rep_data_after_gc += sizeof (rep_number); return cn; } static void number_sweep(void) { int idx; used_numbers = 0; for (idx = 0; idx < 3; idx++) { rep_number_block *cb = number_block_chain[idx]; number_block_chain[idx] = 0; number_freelist[idx] = 0; while (cb != 0) { rep_number_block *nxt = cb->next.p; rep_number *newfree = 0, *newfreetail = 0, *this; int i, newused = 0; for (i = 0, this = cb->data; i < number_allocations[idx]; i++, this = (rep_number *) (((char *) this) + number_sizeofs[idx])) { /* if on the freelist then the CELL_IS_8 bit will be unset (since the pointer is long aligned) */ if (rep_CELL_CONS_P(rep_VAL(this)) || !rep_GC_CELL_MARKEDP ((repv) this)) { if (!newfreetail) newfreetail = this; if (!rep_CELL_CONS_P(rep_VAL(this))) { switch (idx) { case 0: #ifdef HAVE_GMP mpz_clear (((rep_number_z *)this)->z); #else ((rep_number_z *)this)->z = 0; #endif break; case 1: #ifdef HAVE_GMP mpq_clear (((rep_number_q *)this)->q); #endif break; } } this->car = rep_VAL (newfree); newfree = this; } else { rep_GC_CLR_CELL ((repv) this); newused++; } } if(newused == 0) { /* Whole block unused, lets get rid of it. */ rep_free(cb); allocated_numbers -= number_allocations[idx]; } else { if(newfreetail != NULL) { /* Link this mini-freelist onto the main one. */ newfreetail->car = rep_VAL (number_freelist[idx]); number_freelist[idx] = newfree; used_numbers += newused; } /* Have to rebuild the block chain as well. */ cb->next.p = number_block_chain[idx]; number_block_chain[idx] = cb; } cb = nxt; } } } /* Promotion */ static repv dup__ (repv in) { switch (rep_NUMBER_TYPE (in)) { rep_number_z *z; rep_number_f *f; case rep_NUMBER_BIGNUM: z = make_number (rep_NUMBER_BIGNUM); #ifdef HAVE_GMP mpz_init_set (z->z, rep_NUMBER(in,z)); #else z->z = rep_NUMBER(in,z); #endif return rep_VAL (z); #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: { rep_number_q *q = make_number (rep_NUMBER_RATIONAL); mpq_init (q->q); mpq_set (q->q, rep_NUMBER(in,q)); return rep_VAL (q); } #endif case rep_NUMBER_FLOAT: f = make_number (rep_NUMBER_FLOAT); f->f = rep_NUMBER(in,f); return rep_VAL (f); } abort (); } static inline repv dup (repv in) { if (rep_INTP (in)) return in; else return dup__ (in); } static repv promote_to (repv in, int type) { int in_type = rep_NUMERIC_TYPE (in); if (in_type >= type) return in; switch (in_type) { rep_number_z *z; rep_number_f *f; case rep_NUMBER_INT: switch (type) { case rep_NUMBER_BIGNUM: z = make_number (rep_NUMBER_BIGNUM); #ifdef HAVE_GMP mpz_init_set_si (z->z, rep_INT(in)); #else z->z = rep_INT (in); #endif return rep_VAL (z); case rep_NUMBER_RATIONAL: #ifdef HAVE_GMP { rep_number_q *q = make_number (rep_NUMBER_RATIONAL); mpq_init (q->q); mpq_set_si (q->q, rep_INT(in), 1); return rep_VAL (q); } #endif case rep_NUMBER_FLOAT: f = make_number (rep_NUMBER_FLOAT); f->f = (double) rep_INT(in); return rep_VAL (f); break; default: abort(); } case rep_NUMBER_BIGNUM: switch (type) { case rep_NUMBER_RATIONAL: #ifdef HAVE_GMP { rep_number_q *q = make_number (rep_NUMBER_RATIONAL); mpq_init (q->q); mpq_set_z (q->q, rep_NUMBER(in,z)); return rep_VAL (q); } #endif case rep_NUMBER_FLOAT: f = make_number (rep_NUMBER_FLOAT); #ifdef HAVE_GMP f->f = mpz_get_d (rep_NUMBER(in,z)); #else f->f = rep_NUMBER(in,z); #endif return rep_VAL (f); default: abort(); } #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: assert (type == rep_NUMBER_FLOAT); f = make_number (rep_NUMBER_FLOAT); f->f = mpq_get_d (rep_NUMBER(in,q)); return rep_VAL (f); #endif default: abort (); } } /* IN must be a non-fixnum number */ static repv maybe_demote (repv in) { assert (rep_NUMBERP(in)); switch (rep_NUMBER_TYPE(in)) { #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: if (mpz_cmp_ui (mpq_denref (rep_NUMBER (in,q)), 1) == 0) { rep_number_z *z = make_number (rep_NUMBER_BIGNUM); mpz_init_set (z->z, mpq_numref (rep_NUMBER (in,q))); in = rep_VAL (z); goto do_bignum; } break; #endif case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP do_bignum: if (mpz_cmp_si (rep_NUMBER (in,z), rep_LISP_MAX_INT) <= 0 && mpz_cmp_si (rep_NUMBER (in,z), rep_LISP_MIN_INT) >= 0) { in = rep_MAKE_INT (mpz_get_si (rep_NUMBER (in,z))); } #else if (rep_NUMBER (in,z) <= rep_LISP_MAX_INT && rep_NUMBER (in,z) >= rep_LISP_MIN_INT) { in = rep_MAKE_INT (rep_NUMBER (in,z)); } #endif } return in; } static repv coerce (repv in, int type) { int in_type = rep_NUMERIC_TYPE (in); if (in_type <= type) return in; switch (in_type) { case rep_NUMBER_BIGNUM: switch (type) { case rep_NUMBER_INT: #ifdef HAVE_GMP return rep_MAKE_INT (mpz_get_si (rep_NUMBER (in,z))); #else return rep_MAKE_INT (rep_NUMBER (in,z)); #endif default: abort (); } break; /* XXX implement me.. */ case rep_NUMBER_RATIONAL: case rep_NUMBER_FLOAT: default: abort (); } /* not reached. */ return rep_NULL; } static inline void promote (repv *n1p, repv *n2p) { repv n1 = *n1p; repv n2 = *n2p; int n1_type = rep_NUMERIC_TYPE (n1); int n2_type = rep_NUMERIC_TYPE (n2); if (n1_type > n2_type) *n2p = promote_to (n2, n1_type); else if (n1_type < n2_type) *n1p = promote_to (n1, n2_type); } static repv promote_dup__ (repv *n1p, repv *n2p) { repv n1 = *n1p; repv n2 = *n2p; int n1_type = rep_NUMERIC_TYPE (n1); int n2_type = rep_NUMERIC_TYPE (n2); repv out = rep_NULL; if (n1_type > n2_type) { out = promote_to (n2, n1_type); *n2p = out; } else if (n1_type < n2_type) { out = promote_to (n1, n2_type); *n1p = out; } else out = dup (*n1p); return out; } static inline repv promote_dup (repv *n1p, repv *n2p) { repv n1 = *n1p; repv n2 = *n2p; if (rep_INTP (n1) && rep_INTP (n2)) return n1; else return promote_dup__ (n1p, n2p); } repv rep_make_long_uint (unsigned long in) { if (in < rep_LISP_MAX_INT) return rep_MAKE_INT (in); else { rep_number_z *z = make_number (rep_NUMBER_BIGNUM); #ifdef HAVE_GMP mpz_init_set_ui (z->z, in); #else z->z = in; #endif return rep_VAL (z); } } repv rep_make_long_int (long in) { if (in >= rep_LISP_MIN_INT && in <= rep_LISP_MAX_INT) return rep_MAKE_INT (in); else { rep_number_z *z = make_number (rep_NUMBER_BIGNUM); #ifdef HAVE_GMP mpz_init_set_si (z->z, in); #else z->z = in; #endif return rep_VAL (z); } } unsigned long rep_get_long_uint (repv in) { if (rep_INTP (in)) return rep_INT (in); else if (rep_NUMBERP (in)) { switch (rep_NUMBER_TYPE(in)) { case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP return mpz_get_ui (rep_NUMBER(in,z)); #else return rep_NUMBER (in,z); #endif #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: return (unsigned long) mpq_get_d (rep_NUMBER(in,q)); #endif case rep_NUMBER_FLOAT: return (unsigned long) rep_NUMBER(in,f); } } else if (rep_CONSP (in) && rep_INTP (rep_CAR (in)) && rep_INTP (rep_CDR (in))) { return rep_INT (rep_CAR (in)) | (rep_INT (rep_CDR (in)) << 24); } return 0; } long rep_get_long_int (repv in) { if (rep_INTP (in)) return rep_INT (in); else if (rep_NUMBERP (in)) { switch (rep_NUMBER_TYPE(in)) { case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP return mpz_get_si (rep_NUMBER(in,z)); #else return rep_NUMBER (in,z); #endif #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: return (long) mpq_get_d (rep_NUMBER(in,q)); #endif case rep_NUMBER_FLOAT: return (long) rep_NUMBER(in,f); } } else if (rep_CONSP (in) && rep_INTP (rep_CAR (in)) && rep_INTP (rep_CDR (in))) { return rep_INT (rep_CAR (in)) | (rep_INT (rep_CDR (in)) << 24); } return 0; } #if SIZEOF_LONG_LONG > SIZEOF_LONG repv rep_make_longlong_int (rep_long_long in) { if (in <= rep_LISP_MAX_INT && in >= rep_LISP_MIN_INT) return rep_MAKE_INT (in); else { #ifdef HAVE_GMP int sign = (in < 0) ? -1 : 1; unsigned rep_long_long uin = (sign < 0) ? -in : in; unsigned long bottom = (unsigned long) uin; unsigned long top = (unsigned long) (uin >> (CHAR_BIT * sizeof (long))); rep_number_z *z = make_number (rep_NUMBER_BIGNUM); mpz_init_set_ui (z->z, bottom); if (top != 0) { mpz_t tem; mpz_init_set_ui (tem, top); mpz_mul_2exp (tem, tem, CHAR_BIT * sizeof (long)); mpz_add (z->z, z->z, tem); mpz_clear (tem); } if (sign < 0) mpz_neg (z->z, z->z); #else rep_number_z *z = make_number (rep_NUMBER_BIGNUM); z->z = in; #endif return rep_VAL (z); } } rep_long_long rep_get_longlong_int (repv in) { if (rep_INTP (in)) return rep_INT (in); else if (rep_NUMBERP (in)) { switch (rep_NUMBER_TYPE(in)) { case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP { int sign = mpz_sgn (rep_NUMBER(in,z)); rep_long_long bottom, top, out; mpz_t tem; mpz_init_set (tem, rep_NUMBER(in,z)); if (sign < 0) mpz_neg (tem, tem); bottom = mpz_get_ui (tem); mpz_tdiv_q_2exp (tem, tem, CHAR_BIT * sizeof (long)); top = mpz_get_ui (tem); out = bottom | (top << (CHAR_BIT * sizeof (long))); if (sign < 0) out = -out; mpz_clear (tem); return out; } #else return rep_NUMBER (in,z); #endif #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: return (rep_long_long) mpq_get_d (rep_NUMBER(in,q)); #endif case rep_NUMBER_FLOAT: return (rep_long_long) rep_NUMBER(in,f); } } else if (rep_CONSP (in) && rep_INTP (rep_CAR (in)) && rep_INTP (rep_CDR (in))) { rep_long_long out = rep_INT (rep_CDR (in)); out = (out << 24) | rep_INT (rep_CAR (in)); return out; } return 0; } #else /* SIZEOF_LONG_LONG > SIZEOF_LONG */ repv rep_make_longlong_int (rep_long_long in) { return rep_make_long_int (in); } rep_long_long rep_get_longlong_int (repv in) { return rep_get_long_int (in); } #endif /* ! SIZEOF_LONG_LONG > SIZEOF_LONG */ repv rep_make_float (double in, rep_bool force) { rep_number_f *f; if (!force && floor (in) == in) { if (in < LONG_MAX && in > LONG_MIN) return rep_make_long_int ((long) in); #if SIZEOF_LONG_LONG > SIZEOF_LONG else if (in < LONG_LONG_MAX && in > LONG_LONG_MIN) return rep_make_longlong_int (in); #endif } f = make_number (rep_NUMBER_FLOAT); f->f = in; return rep_VAL (f); } double rep_get_float (repv in) { if (rep_NUMERICP (in)) { switch (rep_NUMERIC_TYPE (in)) { case rep_NUMBER_INT: return rep_INT (in); case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP return mpz_get_d (rep_NUMBER(in,z)); #else return rep_NUMBER (in,z); #endif #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: return mpq_get_d (rep_NUMBER(in,q)); #endif case rep_NUMBER_FLOAT: return rep_NUMBER(in,f); } } return 0.0; } /* this ignores exactness */ int rep_compare_numbers (repv v1, repv v2) { if(!rep_NUMERICP(v1) || !rep_NUMERICP(v2)) return 1; promote (&v1, &v2); switch (rep_NUMERIC_TYPE (v1)) { double d; case rep_NUMBER_INT: return rep_INT(v1) - rep_INT(v2); case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP return mpz_cmp (rep_NUMBER(v1,z), rep_NUMBER(v2,z)); #else return rep_NUMBER(v1,z) - rep_NUMBER(v2,z); #endif #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: return mpq_cmp (rep_NUMBER(v1,q), rep_NUMBER(v2,q)); #endif case rep_NUMBER_FLOAT: d = rep_NUMBER(v1,f) - rep_NUMBER(v2,f); return (d < 0) ? -1 : (d > 0) ? +1 : 0; } return 1; } /* this includes exactness in the comparison */ static int number_cmp (repv v1, repv v2) { int i1, i2; if(!rep_NUMERICP(v1) || !rep_NUMERICP(v2)) return 1; i1 = rep_NUMBER_INEXACT_P (v1); i2 = rep_NUMBER_INEXACT_P (v2); if ((i1 && !i2) || (!i1 && i2)) return 1; promote (&v1, &v2); switch (rep_NUMERIC_TYPE (v1)) { double d; case rep_NUMBER_INT: return rep_INT(v1) - rep_INT(v2); case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP return mpz_cmp (rep_NUMBER(v1,z), rep_NUMBER(v2,z)); #else return rep_NUMBER(v1,z) - rep_NUMBER(v2,z); #endif #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: return mpq_cmp (rep_NUMBER(v1,q), rep_NUMBER(v2,q)); #endif case rep_NUMBER_FLOAT: d = rep_NUMBER(v1,f) - rep_NUMBER(v2,f); return (d < 0) ? -1 : (d > 0) ? +1 : 0; } return 1; } static const signed int map[] = { 0, 1, 2, 3, 4, 5, 6, 7, /* 0x30 -> 0x37 */ 8, 9, -1, -1, -1, -1, -1, -1, -1, 10, 11, 12, 13, 14, 15, 16, /* 0x40 -> 0x48 */ 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, /* 0x50 -> 0x58 */ 33, 34, 35, 36 }; #define MAP_SIZE 0x2c #ifndef HAVE_GMP static rep_bool parse_integer_to_float (char *buf, unsigned int len, unsigned int radix, int sign, double *output) { double value = 0.0; while (len-- > 0) { int d; char c = *buf++; d = toupper (c) - '0'; if (d < 0 || d >= MAP_SIZE) return rep_FALSE; d = map [d]; if (d < 0 || d >= radix) return rep_FALSE; value = value * radix + d; } *output = (sign < 0) ? value * -1.0 : value; return rep_TRUE; } #endif #define INSTALL_LOCALE(var, type, locale) \ do { \ char *tem = setlocale (type, 0); \ if (tem != 0) \ { \ int len = strlen (tem); \ char *copy = alloca (len + 1); \ memcpy (copy, tem, len); \ copy[len] = 0; \ (var) = copy; \ setlocale (type, locale); \ } \ else \ (var) = 0; \ } while (0) repv rep_parse_number (char *buf, unsigned int len, unsigned int radix, int sign, unsigned int type) { if (len == 0) goto error; switch (type) { rep_number_z *z; #ifdef HAVE_GMP rep_number_q *q; #endif rep_number_f *f; char *tem, *copy, *old_locale; double d; unsigned int bits; case 0: switch (radix) { case 2: bits = len; break; case 8: bits = len * 3; break; case 10: /* log_2 10 = 3.3219.. ~ 27/8 */ bits = (len * 27) / 8; break; case 16: bits = len * 4; break; default: abort(); } if (bits < rep_LISP_INT_BITS) { long value = 0; char c; if (radix == 10) { /* optimize most common case */ while (len-- > 0) { c = *buf++; if (c < '0' || c > '9') goto error; value = value * 10 + (c - '0'); } } else { while (len-- > 0) { int d; c = *buf++; d = toupper (c) - '0'; if (d < 0 || d >= MAP_SIZE) goto error; d = map [d]; if (d < 0 || d >= radix) goto error; value = value * radix + d; } } return ((sign > 0) ? rep_MAKE_INT (value) : rep_MAKE_INT (value * -1)); } else { z = make_number (rep_NUMBER_BIGNUM); #ifdef HAVE_GMP copy = alloca (len + 1); memcpy (copy, buf, len); copy[len] = 0; if (mpz_init_set_str (z->z, copy, radix) == 0) { if (sign < 0) mpz_neg (z->z, z->z); return maybe_demote (rep_VAL (z)); } else goto error; #else { rep_long_long value; char *tail; copy = alloca (len + 1); memcpy (copy, buf, len); copy[len] = 0; errno = 0; # ifdef HAVE_STRTOLL value = strtoll (copy, &tail, radix); # else value = strtol (copy, &tail, radix); # endif if (errno == ERANGE) { /* Overflow - parse to a double, then try to convert back to an int.. */ double d; if (parse_integer_to_float (buf, len, radix, sign, &d)) { if (d > BIGNUM_MIN && d < BIGNUM_MAX) { z->z = d; return maybe_demote (rep_VAL (z)); } else { f = make_number (rep_NUMBER_FLOAT); f->f = d; return rep_VAL (f); } } else goto error; } else if (*tail != 0 || errno != 0) goto error; /* not all characters used */ z->z = (sign < 0) ? -value : value; return maybe_demote (rep_VAL (z)); } #endif /* !HAVE_GMP */ } case rep_NUMBER_RATIONAL: tem = strchr (buf, '/'); assert (tem != 0); #ifdef HAVE_GMP q = make_number (rep_NUMBER_RATIONAL); mpq_init (q->q); copy = alloca (tem - buf + 1); memcpy (copy, buf, tem - buf); copy[tem - buf] = 0; if (mpz_set_str (mpq_numref (q->q), copy, radix) == 0 && mpz_set_str (mpq_denref (q->q), tem + 1, radix) == 0) { if (mpz_sgn (mpq_denref (q->q)) == 0) goto error; mpq_canonicalize (q->q); if (sign < 0) mpq_neg (q->q, q->q); return maybe_demote (rep_VAL (q)); } else goto error; #else { repv num = rep_parse_number (buf, tem - buf, radix, 1, 0); repv den = rep_parse_number (tem + 1, len - (tem + 1 - buf), radix, 1, 0); if (!num || !den) goto error; num = rep_number_div (num, den); if (num && sign < 0) num = rep_number_neg (num); return num; } #endif case rep_NUMBER_FLOAT: #ifdef HAVE_SETLOCALE INSTALL_LOCALE (old_locale, LC_NUMERIC, "C"); #endif d = strtod (buf, &tem); #ifdef HAVE_SETLOCALE if (old_locale != 0) setlocale (LC_NUMERIC, old_locale); #endif if (tem - buf != len) goto error; f = make_number (rep_NUMBER_FLOAT); f->f = d * sign; return rep_VAL (f); } error: return rep_NULL; } char * rep_print_number_to_string (repv obj, int radix, int prec) { char *out = 0; if (!rep_NUMERICP (obj)) return strdup ("#"); switch (rep_NUMERIC_TYPE (obj)) { char buf[128], fmt[8], *tem, *old_locale; case rep_NUMBER_INT: if (radix == 10) tem = "%" rep_PTR_SIZED_INT_CONV "d"; else if (radix == 16) tem = "%" rep_PTR_SIZED_INT_CONV "x"; else if (radix == 8) tem = "%" rep_PTR_SIZED_INT_CONV "o"; else { /* XXX implement properly..? */ obj = promote_to (obj, rep_NUMBER_BIGNUM); goto do_bignum; } if (tem != 0) { #ifdef HAVE_SNPRINTF snprintf(buf, sizeof(buf), tem, rep_INT(obj)); #else sprintf(buf, tem, rep_INT(obj)); #endif out = strdup (buf); } break; case rep_NUMBER_BIGNUM: do_bignum: #ifdef HAVE_GMP out = mpz_get_str (0, radix, rep_NUMBER(obj,z)); #else { static const char *map = "0123456789abcdefghijklmnopqrstuvwxyz"; char *ptr = buf, *optr; rep_long_long value = rep_NUMBER(obj,z); int sign = (value < 0) ? -1 : +1; while (value != 0) { int digit = value % radix; *ptr++ = map[ABS (digit)]; value = value / radix; } if (sign < 0) *ptr++ = '-'; out = malloc ((ptr - buf) + 1); for (optr = out; ptr > buf;) *optr++ = *(--ptr); *optr = 0; } #endif break; #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: { size_t len; len = (mpz_sizeinbase (mpq_numref (rep_NUMBER (obj, q)), radix) + mpz_sizeinbase (mpq_denref (rep_NUMBER (obj, q)), radix) + 4); out = malloc (len); mpz_get_str (out, radix, mpq_numref (rep_NUMBER (obj,q))); len = strlen (out); out[len++] = '/'; mpz_get_str (out + len, radix, mpq_denref (rep_NUMBER (obj,q))); break; } #endif case rep_NUMBER_FLOAT: /* XXX handle radix arg */ sprintf (fmt, "%%.%dg", prec < 0 ? 16 : prec); #ifdef HAVE_SETLOCALE INSTALL_LOCALE (old_locale, LC_NUMERIC, "C"); #endif #ifdef HAVE_SNPRINTF snprintf(buf, sizeof(buf), fmt, rep_NUMBER(obj,f)); #else sprintf(buf, fmt, rep_NUMBER(obj,f)); #endif #ifdef HAVE_SETLOCALE if (old_locale != 0) setlocale (LC_NUMERIC, old_locale); #endif /* libc doesn't always add a point */ if (!strchr (buf, '.') && !strchr (buf, 'e') && !strchr (buf, 'E')) strcat (buf, "."); out = strdup (buf); } return out; } static void number_prin (repv stream, repv obj) { if (rep_INTP (obj)) { char buf[64]; #ifdef HAVE_SNPRINTF snprintf(buf, sizeof(buf), "%" rep_PTR_SIZED_INT_CONV "d", rep_INT(obj)); #else sprintf(buf, "%" rep_PTR_SIZED_INT_CONV "d", rep_INT(obj)); #endif rep_stream_puts(stream, buf, -1, rep_FALSE); } else { char *string = rep_print_number_to_string (obj, 10, -1); if (string != 0) { rep_stream_puts (stream, string, -1, rep_FALSE); free (string); } else rep_stream_puts (stream, "#", -1, rep_FALSE); } } /* lisp functions */ repv rep_number_foldl (repv args, repv (*op)(repv, repv)) { if (rep_CONSP (args) && rep_NUMERICP (rep_CAR (args))) { repv sum = rep_CAR (args); int i = 2; args = rep_CDR (args); while (rep_CONSP (args)) { repv arg = rep_CAR (args); if (!rep_NUMERICP (arg)) return rep_signal_arg_error (arg, i); sum = op (sum, arg); args = rep_CDR (args); i++; } return sum; } return (rep_CONSP(args) ? rep_signal_arg_error (rep_CAR (args), 1) : rep_signal_missing_arg (1)); } static inline repv number_foldv (int argc, repv *argv, repv (*op) (repv, repv)) { repv sum; int i; if (argc < 1) return rep_signal_missing_arg (1); if (!rep_NUMERICP (argv[0])) return rep_signal_arg_error (argv[0], 1); sum = argv[0]; for (i = 1; i < argc; i++) { if (!rep_NUMERICP (argv[i])) return rep_signal_arg_error (argv[i], i + 1); sum = op (sum, argv[i]); } return sum; } repv rep_integer_foldl (repv args, repv (*op)(repv, repv)) { if (rep_CONSP (args) && rep_INTEGERP (rep_CAR (args))) { repv sum = rep_CAR (args); int i = 2; args = rep_CDR (args); while (rep_CONSP (args)) { repv arg = rep_CAR (args); if (!rep_INTEGERP (arg)) return rep_signal_arg_error (arg, i); sum = op (sum, arg); args = rep_CDR (args); i++; } return sum; } return (rep_CONSP(args) ? rep_signal_arg_error (rep_CAR (args), 1) : rep_signal_missing_arg (1)); } static inline repv integer_foldv (int argc, repv *argv, repv (*op) (repv, repv)) { repv sum; int i; if (argc < 1) return rep_signal_missing_arg (1); if (!rep_INTEGERP (argv[0])) return rep_signal_arg_error (argv[0], 1); sum = argv[0]; for (i = 1; i < argc; i++) { if (!rep_INTEGERP (argv[i])) return rep_signal_arg_error (argv[i], i + 1); sum = op (sum, argv[i]); } return sum; } repv rep_foldl (repv args, repv (*op)(repv, repv)) { if (rep_CONSP (args)) { repv sum = rep_CAR (args); int i = 2; args = rep_CDR (args); while (sum && rep_CONSP (args)) { repv arg = rep_CAR (args); sum = op (sum, arg); args = rep_CDR (args); i++; } return sum; } return rep_signal_missing_arg (1); } static inline repv foldv (int argc, repv *argv, repv (*op) (repv, repv)) { repv sum; int i; if (argc < 1) return rep_signal_missing_arg (1); sum = argv[0]; for (i = 1; i < argc; i++) { sum = op (sum, argv[i]); } return sum; } repv rep_number_add (repv x, repv y) { repv out; rep_DECLARE1 (x, rep_NUMERICP); rep_DECLARE2 (y, rep_NUMERICP); out = promote_dup (&x, &y); switch (rep_NUMERIC_TYPE (out)) { case rep_NUMBER_INT: out = rep_make_long_int (rep_INT (x) + rep_INT (y)); break; case rep_NUMBER_BIGNUM: { #ifdef HAVE_GMP mpz_add (rep_NUMBER (out,z), rep_NUMBER (x,z), rep_NUMBER (y,z)); #else double t = (double) rep_NUMBER(x,z) + (double) rep_NUMBER (y,z); if (t > BIGNUM_MIN && t < BIGNUM_MAX) rep_NUMBER(out,z) = rep_NUMBER(x,z) + rep_NUMBER(y,z); else out = rep_make_float (t, rep_TRUE); #endif out = maybe_demote (out); break; } #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: mpq_add (rep_NUMBER (out,q), rep_NUMBER (x,q), rep_NUMBER (y,q)); out = maybe_demote (out); break; #endif case rep_NUMBER_FLOAT: rep_NUMBER (out,f) = rep_NUMBER (x,f) + rep_NUMBER (y,f); break; } return out; } repv rep_number_neg (repv x) { repv out; rep_DECLARE1 (x, rep_NUMERICP); out = dup (x); switch (rep_NUMERIC_TYPE (out)) { case rep_NUMBER_INT: out = rep_make_long_int (-rep_INT (x)); break; case rep_NUMBER_BIGNUM: { #ifdef HAVE_GMP mpz_neg (rep_NUMBER(out,z), rep_NUMBER(x,z)); #else double t = - (double) rep_NUMBER(x,z); if (t > BIGNUM_MIN && t < BIGNUM_MAX) rep_NUMBER(out,z) = - rep_NUMBER(x,z); else out = rep_make_float (t, rep_TRUE); #endif break; } #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: mpq_neg (rep_NUMBER(out,q), rep_NUMBER(x,q)); break; #endif case rep_NUMBER_FLOAT: rep_NUMBER(out,f) = -rep_NUMBER(x,f); break; } return out; } repv rep_number_sub (repv x, repv y) { repv out; rep_DECLARE1 (x, rep_NUMERICP); rep_DECLARE2 (y, rep_NUMERICP); out = promote_dup (&x, &y); switch (rep_NUMERIC_TYPE (out)) { case rep_NUMBER_INT: out = rep_make_long_int (rep_INT (x) - rep_INT (y)); break; case rep_NUMBER_BIGNUM: { #ifdef HAVE_GMP mpz_sub (rep_NUMBER (out,z), rep_NUMBER (x,z), rep_NUMBER (y,z)); #else double t = (double) rep_NUMBER (x,z) - (double) rep_NUMBER (y,z); if (t > BIGNUM_MIN && t < BIGNUM_MAX) rep_NUMBER (out,z) = rep_NUMBER (x,z) - rep_NUMBER (y,z); else out = rep_make_float (t, rep_TRUE); #endif out = maybe_demote (out); break; } #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: mpq_sub (rep_NUMBER (out,q), rep_NUMBER (x,q), rep_NUMBER (y,q)); out = maybe_demote (out); break; #endif case rep_NUMBER_FLOAT: rep_NUMBER (out,f) = rep_NUMBER (x,f) - rep_NUMBER (y,f); break; } return out; } repv rep_number_mul (repv x, repv y) { repv out; rep_DECLARE1 (x, rep_NUMERICP); rep_DECLARE2 (y, rep_NUMERICP); out = promote_dup (&x, &y); switch (rep_NUMERIC_TYPE (out)) { rep_long_long tot; case rep_NUMBER_INT: tot = ((rep_long_long) rep_INT (x)) * ((rep_long_long) rep_INT (y)); out = rep_make_longlong_int (tot); break; case rep_NUMBER_BIGNUM: { #ifdef HAVE_GMP mpz_mul (rep_NUMBER (out,z), rep_NUMBER (x,z), rep_NUMBER (y,z)); #else double t = (double) rep_NUMBER (x,z) * (double) rep_NUMBER (y,z); if (t > BIGNUM_MIN && t < BIGNUM_MAX) rep_NUMBER (out,z) = rep_NUMBER (x,z) * rep_NUMBER (y,z); else out = rep_make_float (t, rep_TRUE); #endif out = maybe_demote (out); break; } #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: mpq_mul (rep_NUMBER (out,q), rep_NUMBER (x,q), rep_NUMBER (y,q)); out = maybe_demote (out); break; #endif case rep_NUMBER_FLOAT: rep_NUMBER (out,f) = rep_NUMBER (x,f) * rep_NUMBER (y,f); break; } return out; } repv rep_number_div (repv x, repv y) { repv out; rep_DECLARE1 (x, rep_NUMERICP); rep_DECLARE2 (y, rep_NUMERICP); if (ZEROP (y)) return Fsignal (Qarith_error, rep_LIST_1 (rep_VAL (&div_zero))); out = promote_dup (&x, &y); switch (rep_NUMERIC_TYPE (out)) { case rep_NUMBER_INT: if (rep_INT (x) % rep_INT (y) == 0) out = rep_MAKE_INT (rep_INT (x) / rep_INT (y)); else { #ifdef HAVE_GMP unsigned long uy = (rep_INT (y) < 0 ? - rep_INT (y) : rep_INT (y)); rep_number_q *q = make_number (rep_NUMBER_RATIONAL); mpq_init (q->q); mpq_set_si (q->q, rep_INT (x), uy); mpq_canonicalize (q->q); if (rep_INT (y) < 0) mpq_neg (q->q, q->q); out = rep_VAL (q); #else rep_number_f *f = make_number (rep_NUMBER_FLOAT); f->f = ((double) rep_INT (x)) / ((double) rep_INT (y)); out = rep_VAL (f); #endif } break; case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP { mpz_t rem; int sign; mpz_init (rem); mpz_tdiv_r (rem, rep_NUMBER (x,z), rep_NUMBER (y,z)); sign = mpz_sgn (rem); mpz_clear (rem); if (sign == 0) { mpz_tdiv_q (rep_NUMBER (out,z), rep_NUMBER (x,z), rep_NUMBER (y,z)); out = maybe_demote (out); } else { mpq_t div; rep_number_q *q = make_number (rep_NUMBER_RATIONAL); mpq_init (q->q); mpq_set_z (q->q, rep_NUMBER (x,z)); mpq_init (div); mpq_set_z (div, rep_NUMBER (y,z)); mpq_div (q->q, q->q, div); mpq_clear (div); out = rep_VAL (q); } } #else if (rep_NUMBER (x,z) % rep_NUMBER (y,z) == 0) { rep_number_z *z = make_number (rep_NUMBER_BIGNUM); z->z = rep_NUMBER (x,z) / rep_NUMBER (y,z); out = rep_VAL (z); } else { rep_number_f *f = make_number (rep_NUMBER_FLOAT); f->f = ((double) rep_NUMBER (x,z)) / ((double) rep_NUMBER (y,z)); out = rep_VAL (f); } #endif break; #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: mpq_div (rep_NUMBER (out,q), rep_NUMBER (x,q), rep_NUMBER (y,q)); out = maybe_demote (out); break; #endif case rep_NUMBER_FLOAT: rep_NUMBER (out,f) = rep_NUMBER (x,f) / rep_NUMBER (y,f); break; } return out; } repv rep_number_lognot (repv x) { repv out; rep_DECLARE1 (x, rep_NUMERICP); switch (rep_NUMERIC_TYPE (x)) { rep_number_z *z; case rep_NUMBER_INT: out = rep_MAKE_INT (~rep_INT (x)); break; case rep_NUMBER_BIGNUM: z = make_number (rep_NUMBER_BIGNUM); #ifdef HAVE_GMP mpz_init (z->z); mpz_com (z->z, rep_NUMBER (x,z)); #else z->z = ~ rep_NUMBER (x,z); #endif out = rep_VAL (z); break; default: return rep_signal_arg_error (x, 1); } return out; } repv rep_number_logior (repv x, repv y) { repv out; rep_DECLARE1 (x, rep_NUMERICP); rep_DECLARE2 (y, rep_NUMERICP); out = promote_dup (&x, &y); switch (rep_NUMERIC_TYPE (out)) { case rep_NUMBER_INT: out = rep_MAKE_INT (rep_INT (x) | rep_INT (y)); break; case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP mpz_ior (rep_NUMBER (out,z), rep_NUMBER (x,z), rep_NUMBER (y,z)); #else rep_NUMBER (out,z) = rep_NUMBER (x,z) | rep_NUMBER (y,z); #endif break; default: return rep_signal_arg_error (x, 1); } return out; } repv rep_number_logxor (repv x, repv y) { repv out; rep_DECLARE1 (x, rep_NUMERICP); rep_DECLARE2 (y, rep_NUMERICP); out = promote_dup (&x, &y); switch (rep_NUMERIC_TYPE (out)) { #ifdef HAVE_GMP mpz_t tem; #endif case rep_NUMBER_INT: out = rep_MAKE_INT (rep_INT (x) ^ rep_INT (y)); break; case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP /* XXX is this correct: x^y = x|y & ~(x&y) */ mpz_init (tem); mpz_ior (tem, rep_NUMBER (x,z), rep_NUMBER (y,z)); mpz_and (rep_NUMBER (out,z), rep_NUMBER (x,z), rep_NUMBER (y,z)); mpz_com (rep_NUMBER (out,z), rep_NUMBER (out,z)); mpz_and (rep_NUMBER (out,z), rep_NUMBER (out,z), tem); mpz_clear (tem); #else rep_NUMBER (out,z) = rep_NUMBER (x,z) ^ rep_NUMBER (y,z); #endif break; default: return rep_signal_arg_error (x, 1); } return out; } repv rep_number_logand (repv x, repv y) { repv out; rep_DECLARE1 (x, rep_NUMERICP); rep_DECLARE2 (y, rep_NUMERICP); out = promote_dup (&x, &y); switch (rep_NUMERIC_TYPE (out)) { case rep_NUMBER_INT: out = rep_MAKE_INT (rep_INT (x) & rep_INT (y)); break; case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP mpz_and (rep_NUMBER (out,z), rep_NUMBER (x,z), rep_NUMBER (y,z)); #else rep_NUMBER (out,z) = rep_NUMBER (x,z) & rep_NUMBER (y,z); #endif break; default: return rep_signal_arg_error (x, 1); } return out; } repv rep_number_max (repv x, repv y) { repv max; if (rep_NUMBERP (x) || rep_NUMBERP (y)) { max = (rep_compare_numbers (x, y) >= 0) ? x : y; if (rep_NUMBER_INEXACT_P (x) || rep_NUMBER_INEXACT_P (y)) max = Fexact_to_inexact (max); } else max = (rep_value_cmp(x, y) >= 0) ? x : y; return max; } repv rep_number_min (repv x, repv y) { repv min; if (rep_NUMBERP (x) || rep_NUMBERP (y)) { min = (rep_compare_numbers (x, y) <= 0) ? x : y; if (rep_NUMBER_INEXACT_P (x) || rep_NUMBER_INEXACT_P (y)) min = Fexact_to_inexact (min); } else min = (rep_value_cmp(x, y) <= 0) ? x : y; return min; } repv rep_integer_gcd (repv x, repv y) { repv out = promote_dup (&x, &y); if (rep_INTP (x)) { /* Euclid's algorithm */ long m = rep_INT (x), n = rep_INT (y); m = ABS (m); n = ABS (n); while(m != 0) { long t = n % m; n = m; m = t; } out = rep_MAKE_INT (n); } else { #ifdef HAVE_GMP mpz_gcd (rep_NUMBER(out,z), rep_NUMBER(x,z), rep_NUMBER(y,z)); #else /* Euclid's algorithm */ rep_long_long m = rep_NUMBER (x,z), n = rep_NUMBER (y,z); m = ABS (m); n = ABS (n); while(m != 0) { rep_long_long t = n % m; n = m; m = t; } rep_NUMBER (out,z) = n; #endif } return out; } DEFUN("+", Fplus, Splus, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#+:: + NUMBERS... Adds all NUMBERS together. If no arguments are given returns 0. ::end:: */ { if (argc == 0) return rep_MAKE_INT (0); else return number_foldv (argc, argv, rep_number_add); } DEFUN("-", Fminus, Sminus, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#-:: - NUMBER [NUMBERS...] Either returns the negation of NUMBER or the value of NUMBER minus NUMBERS ::end:: */ { if (argc == 0) return rep_signal_missing_arg (1); else if (argc == 1) return rep_number_neg (argv[0]); else return number_foldv (argc, argv, rep_number_sub); } DEFUN("*", Fproduct, Sproduct, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#*:: * NUMBERS... Multiplies all NUMBERS together. If no numbers are given returns 1. ::end:: */ { if (argc == 0) return rep_MAKE_INT (1); else return number_foldv (argc, argv, rep_number_mul); } DEFUN("/", Fdivide, Sdivide, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#/:: / NUMBERS... Divides NUMBERS (in left-to-right order). ::end:: */ { if (argc == 0) return rep_signal_missing_arg (1); else if (argc == 1) return rep_number_div (rep_MAKE_INT (1), argv[0]); else return number_foldv (argc, argv, rep_number_div); } DEFUN("remainder", Fremainder, Sremainder, (repv n1, repv n2), rep_Subr2) /* ::doc:rep.lang.math#remainder:: remainder DIVIDEND DIVISOR Returns the integer remainder after dividing DIVIDEND by DIVISOR. ::end:: */ { repv out; rep_DECLARE1(n1, rep_NUMERICP); rep_DECLARE2(n2, rep_NUMERICP); if(ZEROP (n2)) return Fsignal (Qarith_error, rep_LIST_1 (rep_VAL (&div_zero))); out = promote_dup (&n1, &n2); switch (rep_NUMERIC_TYPE (out)) { case rep_NUMBER_INT: out = rep_MAKE_INT (rep_INT (n1) % rep_INT (n2)); break; case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP mpz_tdiv_r (rep_NUMBER(out,z), rep_NUMBER(n1,z), rep_NUMBER(n2,z)); #else { rep_number_z *z = make_number (rep_NUMBER_BIGNUM); z->z = rep_NUMBER (n1,z) % rep_NUMBER (n2,z); out = rep_VAL (z); } #endif out = maybe_demote (out); break; default: return rep_signal_arg_error (n1, 1); } return out; } DEFUN("mod", Fmod, Smod, (repv n1, repv n2), rep_Subr2) /* ::doc:rep.lang.math#mod:: mod DIVIDEND DIVISOR Returns the value of DIVIDEND modulo DIVISOR; unlike the % (remainder) function the behaviour of `mod' is well-defined for negative arguments, we have that, (mod X Y) == X - (* Y (floor (/ X Y))), for Y not equal to zero assuming that (floor Z) gives the least integer greater than or equal to Z, and that floating point division is used. ::end:: */ { repv out; rep_DECLARE1(n1, rep_NUMERICP); rep_DECLARE2(n2, rep_NUMERICP); if(ZEROP (n2)) return Fsignal (Qarith_error, rep_LIST_1 (rep_VAL (&div_zero))); out = promote_dup (&n1, &n2); switch (rep_NUMERIC_TYPE (out)) { long tem; #ifdef HAVE_GMP int sign; #else rep_number_z *z; #endif case rep_NUMBER_INT: /* This code from GNU Emacs */ tem = rep_INT (n1) % rep_INT (n2); /* If the "remainder" comes out with the wrong sign, fix it. */ if (rep_INT (n2) < 0 ? tem > 0 : tem < 0) tem += rep_INT (n2); out = rep_MAKE_INT (tem); break; case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP mpz_tdiv_r (rep_NUMBER(out,z), rep_NUMBER(n1,z), rep_NUMBER(n2,z)); /* If the "remainder" comes out with the wrong sign, fix it. */ sign = mpz_sgn (rep_NUMBER(out,z)); if (mpz_sgn (rep_NUMBER(n2,z)) < 0 ? sign > 0 : sign < 0) mpz_add (rep_NUMBER(out,z), rep_NUMBER(out,z), rep_NUMBER(n2,z)); #else z = make_number (rep_NUMBER_BIGNUM); z->z = rep_NUMBER (n1,z) % rep_NUMBER (n2,z); if (rep_NUMBER (n2,z) < 0 ? z->z > 0 : z->z < 0) z->z += rep_NUMBER (n2,z); out = rep_VAL (z); #endif out = maybe_demote (out); break; default: return rep_signal_arg_error (n1, 1); } return out; } DEFUN("quotient", Fquotient, Squotient, (repv x, repv y), rep_Subr2) /* ::doc:rep.lang.math#quotient:: quotient DIVIDEND DIVISOR Returns the integer quotient from dividing integers DIVIDEND and DIVISOR. ::end:: */ { repv out; rep_DECLARE1 (x, rep_INTEGERP); rep_DECLARE2 (y, rep_INTEGERP); if(ZEROP (y)) return Fsignal (Qarith_error, rep_LIST_1 (rep_VAL (&div_zero))); out = promote_dup (&x, &y); if (rep_INTP (x)) out = rep_MAKE_INT (rep_INT (x) / rep_INT (y)); else { #ifdef HAVE_GMP mpz_tdiv_q (rep_NUMBER(out,z), rep_NUMBER(x,z), rep_NUMBER(y,z)); #else rep_NUMBER(out,z) = rep_NUMBER (x,z) / rep_NUMBER (y,z); #endif out = maybe_demote (out); } return out; } DEFUN("lognot", Flognot, Slognot, (repv num), rep_Subr1) /* ::doc:rep.lang.math#lognot:: lognot NUMBER Returns the bitwise logical `not' of NUMBER. ::end:: */ { rep_DECLARE1(num, rep_NUMERICP); return rep_number_lognot (num); } DEFUN("logior", Flogior, Slogior, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#logior:: logior NUMBERS... Returns the bitwise logical `inclusive-or' of its arguments. ::end:: */ { if (argc == 0) return rep_MAKE_INT (0); else return number_foldv (argc, argv, rep_number_logior); } DEFUN("logxor", Flogxor, Slogxor, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#logxor:: logxor NUMBERS... Returns the bitwise logical `exclusive-or' of its arguments. ::end:: */ { return number_foldv (argc, argv, rep_number_logxor); } DEFUN("logand", Flogand, Slogand, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#logand:: logand NUMBERS... Returns the bitwise logical `and' of its arguments. ::end:: */ { return number_foldv (argc, argv, rep_number_logand); } DEFUN("eql", Feql, Seql, (repv arg1, repv arg2), rep_Subr2) /* ::doc:rep.data#eql:: eql ARG1 ARG2 Similar to `eq' except that numbers with the same value will always be considered `eql' (this may or may not be the case with `eq'). Note however that exact and inexact versions of the same number are not considered the same value. As a rule of thumb, if two numbers print the same, they will be considered `eql'. ::end:: */ { if(rep_NUMERICP (arg1) && rep_NUMERICP (arg2)) return number_cmp (arg1, arg2) == 0 ? Qt : Qnil; else return arg1 == arg2 ? Qt : Qnil; } DEFUN("zerop", Fzerop, Szerop, (repv num), rep_Subr1) /* ::doc:rep.lang.math#zerop:: zerop NUMBER Return t if NUMBER is zero. ::end:: */ { if(rep_NUMERICP (num)) { switch (rep_NUMERIC_TYPE (num)) { case rep_NUMBER_INT: return num == rep_MAKE_INT (0) ? Qt : Qnil; case rep_NUMBER_BIGNUM: #ifdef HAVE_GMP return mpz_sgn (rep_NUMBER(num,z)) == 0 ? Qt : Qnil; #else return rep_NUMBER (num,z) == 0 ? Qt : Qnil; #endif #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: return mpq_sgn (rep_NUMBER(num,q)) == 0 ? Qt : Qnil; #endif case rep_NUMBER_FLOAT: return rep_NUMBER(num,f) == 0 ? Qt : Qnil; } } return Qnil; } DEFUN("1+", Fplus1, Splus1, (repv num), rep_Subr1) /* ::doc:rep.lang.math#1+:: 1+ NUMBER Return NUMBER plus 1. ::end:: */ { rep_DECLARE1(num, rep_NUMERICP); switch (rep_NUMERIC_TYPE (num)) { #ifdef HAVE_GMP mpq_t temq; #endif case rep_NUMBER_INT: return rep_make_long_int (rep_INT (num) + 1); case rep_NUMBER_BIGNUM: num = dup (num); #ifdef HAVE_GMP mpz_add_ui (rep_NUMBER (num,z), rep_NUMBER (num,z), 1); #else rep_NUMBER (num,z) = rep_NUMBER (num,z) + 1; #endif return maybe_demote (num); #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: num = dup (num); mpq_init (temq); mpq_set_ui (temq, 1, 1); mpq_add (rep_NUMBER (num,q), rep_NUMBER (num,q), temq); mpq_clear (temq); return maybe_demote (num); #endif case rep_NUMBER_FLOAT: num = dup (num); rep_NUMBER (num,f) = rep_NUMBER (num,f) + 1; return num; } abort (); } DEFUN("1-", Fsub1, Ssub1, (repv num), rep_Subr1) /* ::doc:rep.lang.math#1-:: 1- NUMBER Return NUMBER minus 1. ::end:: */ { rep_DECLARE1(num, rep_NUMERICP); switch (rep_NUMERIC_TYPE (num)) { #ifdef HAVE_GMP mpq_t temq; #endif case rep_NUMBER_INT: return rep_make_long_int (rep_INT (num) - 1); case rep_NUMBER_BIGNUM: num = dup (num); #ifdef HAVE_GMP mpz_sub_ui (rep_NUMBER (num,z), rep_NUMBER (num,z), 1); #else rep_NUMBER (num,z) = rep_NUMBER (num,z) - 1; #endif return maybe_demote (num); #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: num = dup (num); mpq_init (temq); mpq_set_si (temq, 1, 1); mpq_sub (rep_NUMBER (num,q), rep_NUMBER (num,q), temq); mpq_clear (temq); return maybe_demote (num); #endif case rep_NUMBER_FLOAT: num = dup (num); rep_NUMBER (num,f) = rep_NUMBER (num,f) - 1; return num; } abort (); } DEFUN("ash", Fash, Sash, (repv num, repv shift), rep_Subr2) /* ::doc:rep.lang.math#ash:: ash NUMBER COUNT Use an arithmetic shift to shift the bits in NUMBER by COUNT bits to the left, a negative COUNT means shift right. Both NUMBER and COUNT must be integers. ::end:: */ { rep_DECLARE1(num, rep_INTEGERP); rep_DECLARE2(shift, rep_INTEGERP); shift = coerce (shift, rep_NUMBER_INT); switch (rep_NUMERIC_TYPE (num)) { rep_number_z *z; rep_long_long tot; case rep_NUMBER_INT: if (rep_INT (shift) >= rep_LISP_INT_BITS) { num = promote_to (num, rep_NUMBER_BIGNUM); goto do_bignum; } else { if (rep_INT (shift) > 0) tot = ((rep_long_long) rep_INT (num)) << rep_INT (shift); else tot = ((rep_long_long) rep_INT (num)) >> -rep_INT (shift); } return rep_make_longlong_int (tot); case rep_NUMBER_BIGNUM: do_bignum: z = make_number (rep_NUMBER_BIGNUM); #ifdef HAVE_GMP mpz_init (z->z); if (rep_INT (shift) > 0) mpz_mul_2exp (z->z, rep_NUMBER (num,z), rep_INT (shift)); else mpz_div_2exp (z->z, rep_NUMBER (num,z), - rep_INT (shift)); #else if (rep_INT (shift) > 0) { long i, this; double factor = 1, t; for (i = rep_INT (shift); i > 0; i -= this) { this = MIN (sizeof (long) * CHAR_BIT - 1, i); factor = factor * (1L << this); } t = (double) rep_NUMBER (num,z) * factor; if (t > BIGNUM_MIN && t < BIGNUM_MAX) z->z = rep_NUMBER (num,z) << rep_INT (shift); else return rep_make_float (t, rep_TRUE); } else z->z = rep_NUMBER (num,z) >> -rep_INT (shift); #endif return maybe_demote (rep_VAL (z)); default: return rep_signal_arg_error (num, 1); } } DEFUN("floor", Ffloor, Sfloor, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#floor:: floor NUMBER Round NUMBER downwards to the nearest integer less than or equal to NUMBER. ::end:: */ { rep_DECLARE1 (arg, rep_NUMERICP); switch (rep_NUMERIC_TYPE (arg)) { case rep_NUMBER_INT: case rep_NUMBER_BIGNUM: return arg; #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: return rep_make_long_int (floor (mpq_get_d (rep_NUMBER (arg,q)))); #endif case rep_NUMBER_FLOAT: return rep_make_float (floor (rep_NUMBER (arg,f)), rep_TRUE); } abort (); } DEFUN("ceiling", Fceiling, Sceiling, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#ceiling:: ceiling NUMBER Round NUMBER upwards to the nearest integer greater than or equal to NUMBER. ::end:: */ { rep_DECLARE1 (arg, rep_NUMERICP); switch (rep_NUMERIC_TYPE (arg)) { case rep_NUMBER_INT: case rep_NUMBER_BIGNUM: return arg; #ifdef HAVE_GMP case rep_NUMBER_RATIONAL: return rep_make_long_int (ceil (mpq_get_d (rep_NUMBER (arg,q)))); #endif case rep_NUMBER_FLOAT: return rep_make_float (ceil (rep_NUMBER (arg,f)), rep_TRUE); } abort (); } DEFUN("truncate", Ftruncate, Struncate, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#truncate:: truncate NUMBER Round NUMBER to the nearest integer between NUMBER and zero. ::end:: */ { rep_DECLARE1 (arg, rep_NUMERICP); switch (rep_NUMERIC_TYPE (arg)) { double d; case rep_NUMBER_INT: case rep_NUMBER_BIGNUM: return arg; default: #ifdef HAVE_GMP if (rep_NUMBER_RATIONAL_P (arg)) d = mpq_get_d (rep_NUMBER(arg,q)); else #endif d = rep_NUMBER(arg,f); d = (d < 0.0) ? -floor (-d) : floor (d); #ifdef HAVE_GMP if (rep_NUMBER_RATIONAL_P (arg)) return rep_make_long_int ((long) d); else #endif return rep_make_float (d, rep_TRUE); } abort (); } DEFUN("round", Fround, Sround, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#round:: round NUMBER Round NUMBER to the nearest integer. Halfway cases are rounded to the nearest even integer. ::end:: */ { rep_DECLARE1 (arg, rep_NUMERICP); switch (rep_NUMERIC_TYPE (arg)) { double d, plus_half, result; case rep_NUMBER_INT: case rep_NUMBER_BIGNUM: return arg; default: #ifdef HAVE_GMP if (rep_NUMBER_RATIONAL_P (arg)) d = mpq_get_d (rep_NUMBER(arg,q)); else #endif d = rep_NUMBER(arg,f); /* from guile */ plus_half = d + 0.5; result = floor (plus_half); /* Adjust so that the round is towards even. */ d = ((plus_half == result && plus_half / 2 != floor (plus_half / 2)) ? result - 1 : result); #ifdef HAVE_GMP if (rep_NUMBER_RATIONAL_P (arg)) return rep_make_long_int ((long) d); else #endif return rep_make_float (d, rep_TRUE); } abort (); } DEFUN("exp", Fexp, Sexp, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#exp:: exp X Return `e' (the base of natural logarithms) raised to the power X. ::end:: */ { rep_DECLARE1 (arg, rep_NUMERICP); return rep_make_float (exp (rep_get_float (arg)), rep_TRUE); } DEFUN("log", Flog_, Slog, (repv arg, repv base), rep_Subr2) /* ::doc:rep.lang.math#log:: log X [BASE] Return the logarithm of X in base BASE. An arithmetic error is signalled if X is less than zero. If BASE isn't defined, return the natural logarithm of X. ::end:: */ { double d, b; rep_DECLARE1 (arg, rep_NUMERICP); rep_DECLARE2_OPT (base, rep_NUMERICP); d = rep_get_float (arg); if (base != Qnil) { b = rep_get_float (base); if (d >= 0 && b >= 0) return rep_make_float (log (d) / log (b), rep_TRUE); } else { if (d >= 0) return rep_make_float (log (d), rep_TRUE); } return Fsignal (Qarith_error, rep_LIST_1 (rep_VAL (&domain_error))); } /* XXX compat */ repv Flog (repv x) { return Flog_ (x, Qnil); } DEFUN("sin", Fsin, Ssin, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#sin:: sin X Returns the sine of X, in radians. ::end:: */ { rep_DECLARE1 (arg, rep_NUMERICP); return rep_make_float (sin (rep_get_float (arg)), rep_TRUE); } DEFUN("cos", Fcos, Scos, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#cos:: cos X Returns the cosine of X, in radians. ::end:: */ { rep_DECLARE1 (arg, rep_NUMERICP); return rep_make_float (cos (rep_get_float (arg)), rep_TRUE); } DEFUN("tan", Ftan, Stan, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#tan:: tan X Returns the tangent of X, in radians. ::end:: */ { rep_DECLARE1 (arg, rep_NUMERICP); return rep_make_float (tan (rep_get_float (arg)), rep_TRUE); } DEFUN("asin", Fasin, Sasin, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#asin:: asin X Return the arc sine of X (the value whose sine is X), in radians. ::end:: */ { double d; rep_DECLARE1 (arg, rep_NUMERICP); d = rep_get_float (arg); if (d >= -1.0 && d <= 1.0) return rep_make_float (asin (d), rep_TRUE); else return Fsignal (Qarith_error, rep_LIST_1 (rep_VAL (&domain_error))); } DEFUN("acos", Facos, Sacos, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#acos:: acos X Return the arc cosine of X (the value whose cosine is X), in radians. ::end:: */ { double d; rep_DECLARE1 (arg, rep_NUMERICP); d = rep_get_float (arg); if (d >= -1.0 && d <= 1.0) return rep_make_float (acos (d), rep_TRUE); else return Fsignal (Qarith_error, rep_LIST_1 (rep_VAL (&domain_error))); } DEFUN("atan", Fatan, Satan, (repv y, repv x), rep_Subr2) /* ::doc:rep.lang.math#atan:: atan X Returns the arc tangent of X (the value whose tangent is X), in radians. atan Y X Returns the arc tangent of Y/X, in radians. The signs of both arguments are used to determine the quadrant of the result, and X is permitted to be zero. ::end:: */ { rep_DECLARE1 (y, rep_NUMERICP); if (!rep_NUMERICP (x)) return rep_make_float (atan (rep_get_float (y)), rep_TRUE); else return rep_make_float (atan2 (rep_get_float (y), rep_get_float (x)), rep_TRUE); } DEFUN("sqrt", Fsqrt, Ssqrt, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#sqrt:: sqrt X Returns the nonnegative square root of X. If X is negative, signals an arithmetic error (should return a complex number). ::end:: */ { double d; rep_DECLARE1 (arg, rep_NUMERICP); d = rep_get_float (arg); if (d >= 0) return rep_make_float (sqrt (d), rep_NUMBER_INEXACT_P (arg)); else return Fsignal (Qarith_error, rep_LIST_1 (rep_VAL (&domain_error))); } DEFUN("expt", Fexpt, Sexpt, (repv arg1, repv arg2), rep_Subr2) /* ::doc:rep.lang.math#expt:: expt X Y Returns X raised to the power Y. If X is negative and Y is a non-integer, then an arithmetic error is signalled (mathematically should return a complex number). ::end:: */ { repv out; rep_DECLARE1 (arg1, rep_NUMERICP); rep_DECLARE1 (arg2, rep_NUMERICP); if (rep_INTEGERP (arg1) && rep_INTP (arg2)) { if (rep_INTP (arg1)) { arg1 = promote_to (arg1, rep_NUMBER_BIGNUM); out = arg1; } else out = dup (arg1); #ifdef HAVE_GMP { int neg = rep_INT (arg2) < 0; mpz_pow_ui (rep_NUMBER(out,z), rep_NUMBER(arg1,z), neg ? -rep_INT(arg2) : rep_INT (arg2)); if (neg) out = rep_number_div (rep_MAKE_INT (1), out); } #else { double t = pow (rep_NUMBER (arg1,z), rep_INT (arg2)); out = rep_make_float (t, rep_FALSE); } #endif } else { double x, y; x = rep_get_float (arg1); y = rep_get_float (arg2); if (x >= 0 || ceil (y) == y) { out = rep_make_float (pow (x, y), rep_NUMBER_INEXACT_P (arg1) || rep_NUMBER_INEXACT_P (arg2)); } else out = Fsignal (Qarith_error, rep_LIST_1 (rep_VAL (&domain_error))); } return out; } DEFUN("gcd", Fgcd, Sgcd, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#gcd:: gcd ... Return the greatest common divisor of the integer arguments. The result is always non-negative. Returns 0 with arguments. ::end:: */ { if (argc == 0) return rep_MAKE_INT (0); else if (argc == 1) { rep_DECLARE1 (argv[0], rep_INTEGERP); return rep_integer_gcd (argv[0], argv[0]); } else return integer_foldv (argc, argv, rep_integer_gcd); } DEFUN("numberp", Fnumberp, Snumberp, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#numberp:: numberp ARG Return t if ARG is a number. ::end:: */ { return rep_NUMERICP (arg) ? Qt : Qnil; } DEFUN("integerp", Fintegerp, Sintegerp, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#integerp:: integerp ARG Return t if ARG is a integer. ::end:: */ { if (!rep_NUMERICP (arg)) return Qnil; switch (rep_NUMERIC_TYPE (arg)) { case rep_NUMBER_INT: case rep_NUMBER_BIGNUM: return Qt; case rep_NUMBER_RATIONAL: return Qnil; case rep_NUMBER_FLOAT: return (floor (rep_NUMBER(arg,f)) == rep_NUMBER(arg,f)) ? Qt : Qnil; default: abort (); } } DEFUN("fixnump", Ffixnump, Sfixnump, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#fixnump:: fixnump ARG Return t if ARG is a fixnum (i.e. an integer that fits in a Lisp pointer). ::end:: */ { return rep_INTP (arg) ? Qt : Qnil; } DEFUN("exactp", Fexactp, Sexactp, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#exactp:: exactp ARG Return t if ARG is an exact number. ::end:: */ { return (rep_INTP (arg) || (rep_NUMBERP (arg) && !rep_NUMBER_FLOAT_P (arg))) ? Qt : Qnil; } DEFUN("exact->inexact", Fexact_to_inexact, Sexact_to_inexact, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#exact->inexact:: exact->inexact X Returns an inexact (i.e. floating point) representation of X. ::end:: */ { rep_DECLARE1(arg, rep_NUMERICP); if (!rep_INTP (arg) && rep_NUMBER_FLOAT_P (arg)) return arg; else return rep_make_float (rep_get_float (arg), rep_TRUE); } static void rationalize (repv arg, double *numerator, double *denominator) { double x, y; int expt; /* X/Y always equals the input value. Tactic is to iteratively multiply both X and Y by 2 until X is an integer. We bound the number of iterations to the size of the mantissa by starting with the normalized value... */ x = frexp (rep_get_float (arg), &expt); y = pow (2.0, -expt); while (x - floor (x) > DBL_EPSILON) { x = x * 2.0; y = y * 2.0; } if (numerator != NULL) *numerator = x; if (denominator != NULL) *denominator = y; } DEFUN("inexact->exact", Finexact_to_exact, Sinexact_to_exact, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#inexact->exact:: inexact->exact X Returns an exact representation of X. This may involve a loss of accuracy. ::end:: */ { rep_DECLARE1(arg, rep_NUMERICP); if (rep_INTP (arg) || !rep_NUMBER_FLOAT_P (arg)) return arg; #ifdef HAVE_GMP else { double x, y; rep_number_z *z; rationalize (arg, &x, &y); z = make_number (rep_NUMBER_BIGNUM); mpz_init_set_d (z->z, (x / y)); return maybe_demote (rep_VAL (z)); } #else else { double x, y; rep_number_z *z; rationalize (arg, &x, &y); z = make_number (rep_NUMBER_BIGNUM); z->z = x / y; return maybe_demote (rep_VAL (z)); } #endif } DEFUN("numerator", Fnumerator, Snumerator, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#numerator:: numerator X Return the numerator of rational number X. ::end:: */ { rep_bool inexact = rep_FALSE; double x; rep_DECLARE1(arg, rep_NUMERICP); #ifdef HAVE_GMP if (rep_NUMBER_RATIONAL_P (arg)) { rep_number_z *z = make_number (rep_NUMBER_BIGNUM); mpz_init_set (z->z, mpq_numref (rep_NUMBER(arg,q))); return maybe_demote (rep_VAL (z)); } #endif if (rep_NUMBER_INEXACT_P (arg)) inexact = rep_TRUE; rationalize (arg, &x, NULL); return rep_make_float (x, inexact); } DEFUN("denominator", Fdenominator, Sdenominator, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#denominator:: denominator X Return the denominator of rational number X. ::end:: */ { rep_bool inexact = rep_FALSE; double y; rep_DECLARE1(arg, rep_NUMERICP); #ifdef HAVE_GMP if (rep_NUMBER_RATIONAL_P (arg)) { rep_number_z *z = make_number (rep_NUMBER_BIGNUM); mpz_init_set (z->z, mpq_denref (rep_NUMBER(arg,q))); return maybe_demote (rep_VAL (z)); } #endif if (rep_NUMBER_INEXACT_P (arg)) inexact = rep_TRUE; rationalize (arg, NULL, &y); return rep_make_float (y, inexact); } DEFUN("max", Fmax, Smax, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#max:: max ARGS... Returns the greatest of its arguments. There must be at least two arguments. When comparing numbers, any inexact arguments cause the result to be inexact. ::end:: */ { return foldv (argc, argv, rep_number_max); } DEFUN("min", Fmin, Smin, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.lang.math#min:: min ARGS... Returns the smallest of its arguments. There must be at least two arguments. When comparing numbers, any inexact arguments cause the result to be inexact. ::end:: */ { return foldv (argc, argv, rep_number_min); } DEFUN("string->number", Fstring_to_number, Sstring_to_number, (repv string, repv radix_), rep_Subr2) /* ::doc:rep.lang.math#string->number:: string->number STRING [RADIX] Return the number represented by STRING. If RADIX is specified, the number is parsed from that base, otherwise base 10 is assumed. ::end:: */ { int type = 0; int sign = 1; int force_exactness = 0; int radix; char *ptr; repv ret; rep_DECLARE1 (string, rep_STRINGP); if (radix_ == Qnil) radix_ = rep_MAKE_INT (10); rep_DECLARE (2, radix_, rep_INTP (radix_) && rep_INT (radix_) > 0); ptr = rep_STR (string); radix = rep_INT (radix_); while (*ptr == '#') { switch (ptr[1]) { case 'b': case 'B': radix = 2; break; case 'o': case 'O': radix = 8; break; case 'd': case 'D': radix = 10; break; case 'x': case 'X': radix = 16; break; case 'e': case 'E': force_exactness = +1; break; case 'i': case 'I': force_exactness = -1; break; default: return Qnil; } ptr += 2; } if (*ptr == '-' || *ptr == '+') { if (*ptr == '-') sign = -1; ptr++; } if (strchr (ptr, '/')) type = rep_NUMBER_RATIONAL; else if (radix == 10) { if (strchr (ptr, '.') || strchr (ptr, 'e') || strchr (ptr, 'E')) type = rep_NUMBER_FLOAT; } ret = rep_parse_number (ptr, rep_STRING_LEN (string) - (ptr - rep_STR (string)), radix, sign, type); if (ret == rep_NULL) ret = Qnil; else if (force_exactness > 0) ret = Finexact_to_exact (ret); else if (force_exactness < 0) ret = Fexact_to_inexact (ret); return ret; } DEFUN("number->string", Fnumber_to_string, Snumber_to_string, (repv z, repv radix), rep_Subr2) /* ::doc:rep.lang.math#number->string:: number->string Z [RADIX] Return a string containing a printed representation of the number Z. If RADIX is specified, print the number in that base, otherwise print it in base 10. ::end:: */ { char *out; rep_DECLARE1 (z, rep_NUMERICP); if (radix == Qnil) radix = rep_MAKE_INT (10); rep_DECLARE (2, radix, rep_INTP (radix) && rep_INT (radix) > 0); out = rep_print_number_to_string (z, rep_INT (radix), -1); if (out == 0) return Qnil; else return rep_box_string (out, strlen (out)); } /* Random number generation */ #if defined (HAVE_GMP) && defined (HAVE_GMP_RANDINIT) && __GNU_MP__ >= 4 static gmp_randstate_t random_state; static void ensure_random_state (void) { static rep_bool initialized; if (!initialized) { /* Generate the best random numbers up to 128 bits, the maximum allowed by gmp */ gmp_randinit (random_state, GMP_RAND_ALG_DEFAULT, 128); /* Initialize to a known seed */ gmp_randseed_ui (random_state, 0); initialized = rep_TRUE; } } static void random_seed (unsigned long seed) { ensure_random_state (); gmp_randseed_ui (random_state, seed); } static repv random_new (repv limit_) { rep_number_z *z = make_number (rep_NUMBER_BIGNUM); repv limit = promote_to (limit_, rep_NUMBER_BIGNUM); ensure_random_state (); mpz_init (z->z); mpz_urandomm (z->z, random_state, rep_NUMBER (limit, z)); return maybe_demote (rep_VAL (z)); } #else /* HAVE_GMP */ /* Try to work out how many bits of randomness rand() will give.. */ #ifdef HAVE_LRAND48 # define RAND_BITS 31 # define rand lrand48 # define srand srand48 #else # if RAND_MAX == 32768 # define RAND_BITS 15 # elif RAND_MAX == 2147483647 # define RAND_BITS 31 # else # define RAND_BITS 63 # endif #endif static void random_seed (unsigned long seed) { srand (seed); } static repv random_new (repv limit_) { long limit = rep_get_long_int (limit_); long divisor, val; if (limit <= 0 || limit > rep_LISP_MAX_INT) return rep_signal_arg_error (limit_, 1); divisor = rep_LISP_MAX_INT / limit; do { val = rand (); if (rep_LISP_INT_BITS-1 > RAND_BITS) { val = (val << RAND_BITS) | rand (); if (rep_LISP_INT_BITS-1 > 2*RAND_BITS) { val = (val << RAND_BITS) | rand (); if (rep_LISP_INT_BITS-1 > 3*RAND_BITS) { val = (val << RAND_BITS) | rand (); if (rep_LISP_INT_BITS-1 > 4*RAND_BITS) val = (val << RAND_BITS) | rand (); } } } /* Ensure VAL is positive (assumes twos-complement) */ val &= ~(~rep_VALUE_CONST(0) << (rep_LISP_INT_BITS - 1)); val /= divisor; } while (val >= limit); return rep_make_long_int (val); } #endif /* !HAVE_GMP */ DEFUN("random", Frandom, Srandom, (repv arg), rep_Subr1) /* ::doc:rep.lang.math#random:: random [LIMIT] Produce a pseudo-random number between zero and LIMIT (or the largest positive integer representable). If LIMIT is the symbol `t' the generator is seeded with the current time of day. ::end:: */ { repv limit; if (arg == Qt) { unsigned long seed = time (0); seed = (seed << 8) | (rep_getpid () & 0xff); random_seed (seed); return Qt; } rep_DECLARE1_OPT (arg, rep_INTEGERP); if (rep_INTEGERP (arg)) limit = arg; else limit = rep_MAKE_INT (rep_LISP_MAX_INT); if (rep_compare_numbers (limit, rep_MAKE_INT (0)) <= 0) return rep_signal_arg_error (limit, 1); return random_new (limit); } /* init */ void rep_numbers_init (void) { int i; repv tem; rep_register_type(rep_Int, "integer", number_cmp, number_prin, number_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0); rep_register_type(rep_Number, "number", number_cmp, number_prin, number_prin, number_sweep, 0, 0, 0, 0, 0, 0, 0, 0); number_sizeofs[0] = sizeof (rep_number_z); number_sizeofs[1] = sizeof (rep_number_q); number_sizeofs[2] = sizeof (rep_number_f); for (i = 0; i < 3; i++) { number_allocations[i] = ((2040 - sizeof (rep_number_block)) / number_sizeofs[i]); } tem = rep_push_structure ("rep.lang.math"); rep_ADD_SUBR(Splus); rep_ADD_SUBR(Sminus); rep_ADD_SUBR(Sproduct); rep_ADD_SUBR(Sdivide); rep_ADD_SUBR(Sremainder); rep_ADD_SUBR(Smod); rep_ADD_SUBR(Squotient); rep_ADD_SUBR(Slognot); rep_ADD_SUBR(Slogior); rep_ADD_SUBR(Slogxor); rep_ADD_SUBR(Slogand); rep_ADD_SUBR(Szerop); rep_ADD_SUBR(Splus1); rep_ADD_SUBR(Ssub1); rep_ADD_SUBR(Sash); rep_ADD_SUBR(Sfloor); rep_ADD_SUBR(Sceiling); rep_ADD_SUBR(Struncate); rep_ADD_SUBR(Sround); rep_ADD_SUBR(Sexp); rep_ADD_SUBR(Slog); rep_ADD_SUBR(Ssin); rep_ADD_SUBR(Scos); rep_ADD_SUBR(Stan); rep_ADD_SUBR(Sasin); rep_ADD_SUBR(Sacos); rep_ADD_SUBR(Satan); rep_ADD_SUBR(Ssqrt); rep_ADD_SUBR(Sexpt); rep_ADD_SUBR(Sgcd); rep_ADD_SUBR(Snumberp); rep_ADD_SUBR(Sintegerp); rep_ADD_SUBR(Sfixnump); rep_ADD_SUBR(Sexactp); rep_ADD_SUBR(Sexact_to_inexact); rep_ADD_SUBR(Sinexact_to_exact); rep_ADD_SUBR(Snumerator); rep_ADD_SUBR(Sdenominator); rep_ADD_SUBR(Smax); rep_ADD_SUBR(Smin); rep_ADD_SUBR(Sstring_to_number); rep_ADD_SUBR(Snumber_to_string); rep_ADD_SUBR(Srandom); rep_pop_structure (tem); tem = rep_push_structure ("rep.data"); rep_ADD_SUBR(Seql); rep_pop_structure (tem); } librep-0.90.2/src/misc.c0000644000175200017520000004364111245011153013754 0ustar chrischris/* misc.c -- Miscellaneous functions Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #include "build.h" #include #include /* needed for strncasecmp () on UnixWare */ #include #include #include #ifdef HAVE_UNISTD_H # include #endif void (*rep_beep_fun)(void); DEFSTRING(build_id_string, BUILD_DATE " by " BUILD_USER "@" BUILD_HOST ", for " HOST_TYPE "."); DEFSTRING(rep_version_string, REP_VERSION); DEFSYM(operating_system, "operating-system"); DEFSYM(process_environment, "process-environment"); DEFSYM(rep_version, "rep-version"); DEFSYM(rep_interface_id, "rep-interface-id"); DEFSYM(rep_build_id, "rep-build-id"); /* ::doc:rep.system#operating-system:: A symbol defining the type of operating system that Jade is running under. Currently this is always the symbol `unix'. ::end:: ::doc:process-environment:: A list of all environment variables (as strings "NAME=VALUE") passed to the interpreter. Also used to specify the environment of subprocesses. ::end:: ::doc:rep.system#rep-version:: A string defining the current version of the REP interpreter. ::end:: ::doc:rep.system#rep-build-id:: A string describing when, where, and by who the running version of the LISP interpreter was built. ::end:: */ #ifdef rep_HAVE_UNIX DEFSYM(unix, "unix"); #endif DEFSYM(upcase_table, "upcase-table"); DEFSYM(downcase_table, "downcase-table"); DEFSYM(flatten_table, "flatten-table"); /* Some doc strings ::doc:rep.data#upcase-table:: 256-byte string holding translations to turn each character into its upper-case equivalent. ::end:: ::doc:rep.data#downcase-table:: 256-byte string holding translations to turn each character into its lower-case equivalent. ::end:: ::doc:rep.data#flatten-table:: Translation table to convert newline characters to spaces. ::end:: */ #ifndef HAVE_STPCPY /* * copy src to dst, returning pointer to terminating '\0' of dst. * Although this has a prototype in my it doesn't seem to be * in the actual library?? */ char * stpcpy(register char *dst, register const char *src) { while((*dst++ = *src++) != 0) ; return(dst - 1); } #endif /* !HAVE_STPCPY */ #ifndef HAVE_STRNCASECMP /* Compare no more than N characters of S1 and S2, ignoring case, returning less than, equal to or greater than zero if S1 is lexicographically less than, equal to or greater than S2. (from glibc) */ int strncasecmp (const char *s1, const char *s2, size_t n) { const unsigned char *p1 = (const unsigned char *) s1; const unsigned char *p2 = (const unsigned char *) s2; unsigned char c1, c2; if (p1 == p2 || n == 0) return 0; do { c1 = tolower (*p1++); c2 = tolower (*p2++); if (c1 == '\0' || c1 != c2) return c1 - c2; } while (--n > 0); return c1 - c2; } #endif char * rep_str_dupn(const char *old, int len) { char *new = rep_alloc(len + 1); if(new) { memcpy(new, old, len); new[len] = 0; } return new; } static void default_beep (void) { fputc (7, stdout); fflush (stdout); } DEFUN_INT("beep", Fbeep, Sbeep, (void), rep_Subr0, "") /* ::doc:rep.system#beep:: beep Rings a bell. ::end:: */ { if (rep_beep_fun != 0) (*rep_beep_fun)(); return Qt; } DEFUN("complete-string", Fcomplete_string, Scomplete_string, (repv existing, repv arg_list, repv fold), rep_Subr3) /* ::doc:rep.data#complete-string:: complete-string TEMPLATE LIST [FOLD-CASE] Return a string whose beginning matches the string TEMPLATE, and is unique in the set of all strings in LIST which also match TEMPLATE. If FOLD-CASE is t, all matching ignores character case. ::end:: */ { char *orig, *match = NULL; int matchlen = 0, origlen; rep_DECLARE1(existing, rep_STRINGP); rep_DECLARE2(arg_list, rep_LISTP); orig = rep_STR(existing); origlen = rep_STRING_LEN(existing); while(rep_CONSP(arg_list)) { repv arg = rep_CAR(arg_list); if(rep_STRINGP(arg)) { char *tmp = rep_STR(arg); if((rep_NILP(fold) ? strncmp (orig, tmp, origlen) : strncasecmp (orig, tmp, origlen)) == 0) { if(match) { char *tmp2 = match + origlen; tmp += origlen; while(*tmp2 && *tmp) { if(rep_NILP(fold) ? (*tmp2 != *tmp) : (tolower(*tmp2) != tolower(*tmp))) { break; } tmp2++; tmp++; } if((tmp2 - match) < matchlen) matchlen = tmp2 - match; } else { match = tmp; matchlen = strlen(tmp); } } } arg_list = rep_CDR(arg_list); } if(match) return rep_string_dupn(match, matchlen); else return Qnil; } DEFUN("current-time", Fcurrent_time, Scurrent_time, (void), rep_Subr0) /* ::doc:rep.system#current-time:: current-time Return a value denoting the current system time. This will be a cons cell containing (DAYS . SECONDS), the number of DAYS since the epoch, and the number of seconds since the start of the day (universal time). ::end:: */ { unsigned long time = rep_time(); return rep_MAKE_TIME(time); } DEFUN("current-utime", Fcurrent_utime, Scurrent_utime, (void), rep_Subr0) /* ::doc:rep.system#current-utime:: current-utime Return the current time in microseconds. ::end:: */ { rep_long_long time = rep_utime (); return rep_make_longlong_int (time); } DEFUN("fix-time", Ffix_time, Sfix_time, (repv time), rep_Subr1) /* ::doc:rep.system#fix-time:: fix-time TIMESTAMP Ensure that the two parts of TIMESTAMP are mutually consistent. If not TIMESTAMP is altered. Returns TIMESTAMP. ::end:: */ { unsigned long timestamp; rep_DECLARE1(time, rep_TIMEP); timestamp = rep_GET_TIME(time); rep_CAR(time) = rep_MAKE_INT(timestamp / 86400); rep_CDR(time) = rep_MAKE_INT(timestamp % 86400); return time; } DEFUN("current-time-string", Fcurrent_time_string, Scurrent_time_string, (repv time, repv format), rep_Subr2) /* ::doc:rep.system#current-time-string:: current-time-string [TIME] [FORMAT] Returns a human-readable string defining the current date and time, or if specified, that defining TIME. If defined, FORMAT is a string defining how to create the string. It has the same conventions as the template to the C library's strftime function. ::end:: */ { time_t timestamp; if(rep_TIMEP(time)) timestamp = rep_GET_TIME(time); else timestamp = rep_time(); if(rep_STRINGP(format)) { struct tm *loctime = localtime(×tamp); char buf[256]; int len = strftime(buf, sizeof(buf), rep_STR(format), loctime); if(len > 0) return rep_string_dupn(buf, len); else return rep_null_string (); } else { char *str = ctime(×tamp); if(str != 0) return rep_string_dupn(str, strlen(str) - 1); else return rep_null_string (); } } DEFUN("time-later-p", Ftime_later_p, Stime_later_p, (repv t1, repv t2), rep_Subr2) /* ::doc:rep.system#time-later-p:: time-later-p TIME-STAMP1 TIME-STAMP2 Returns t when TIME-STAMP1 refers to a later time than TIME-STAMP2. ::end:: */ { unsigned long time1, time2; rep_DECLARE1(t1, rep_TIMEP); rep_DECLARE2(t2, rep_TIMEP); time1 = rep_GET_TIME(t1); time2 = rep_GET_TIME(t2); return time1 > time2 ? Qt : Qnil; } DEFUN("sleep-for", Fsleep_for, Ssleep_for, (repv secs, repv msecs), rep_Subr2) /* ::doc:rep.system#sleep-for:: sleep-for SECONDS [MILLISECONDS] Pause for SECONDS (plus the optional MILLISECOND component) length of time. ::end:: */ { rep_DECLARE1(secs, rep_NUMERICP); rep_DECLARE2_OPT(msecs, rep_NUMERICP); rep_sleep_for(rep_get_long_int (secs), rep_get_long_int (msecs)); return Qt; } DEFUN("sit-for", Fsit_for, Ssit_for, (repv secs, repv msecs), rep_Subr2) /* ::doc:rep.system#sit-for:: sit-for [SECONDS] [MILLISECONDS] Wait for input to arrive and be processed. No more than SECONDS seconds plus MILLISECONDS milliseconds will be waited. If at the end of this time no input has arrived, return t. Otherwise return nil if input was found. If neither SECONDS nor MILLISECONDS is defined the command will return immediately, using a null timeout. ::end:: */ { rep_DECLARE1_OPT(secs, rep_NUMERICP); rep_DECLARE2_OPT(msecs, rep_NUMERICP); return rep_sit_for(((rep_get_long_int (secs)) * 1000) + rep_get_long_int (msecs)); } DEFUN("user-login-name", Fuser_login_name, Suser_login_name, (void), rep_Subr0) /* ::doc:rep.system#user-login-name:: user-login-name Returns the login name of the user (a string). ::end:: */ { return rep_user_login_name(); } DEFUN("user-full-name", Fuser_full_name, Suser_full_name, (repv arg), rep_Subr1) /* ::doc:rep.system#user-full-name:: user-full-name [REAL-NAME] Returns the real name of the user (a string). If REAL-NAME is non-nil, it's the name to return in subsequent calls. ::end:: */ { static repv saved_name; rep_DECLARE1_OPT (arg, rep_STRINGP); if(arg != Qnil) { if(!saved_name) rep_mark_static(&saved_name); saved_name = arg; } return saved_name ? saved_name : rep_user_full_name(); } DEFUN("user-home-directory", Fuser_home_directory, Suser_home_directory, (repv user), rep_Subr1) /* ::doc:rep.system#user-home-directory:: user-home-directory [USER] Return the path to USER's home directory (a string). When USER is undefined the directory of the user who executed Jade is found. ::end:: */ { rep_DECLARE1_OPT(user, rep_STRINGP); return rep_user_home_directory(user); } DEFUN("system-name", Fsystem_name, Ssystem_name, (void), rep_Subr0) /* ::doc:rep.system#system-name:: system-name Returns the name of the host which the editor is running on. ::end:: */ { return rep_system_name(); } DEFUN("message", Fmessage, Smessage, (repv string, repv now), rep_Subr2) /* ::doc:rep.system#message:: message STRING [DISPLAY-NOW] Temporarily sets the status display to STRING, this may not happen until the next complete redisplay, unless DISPLAY-NOW is non-nil. ::end:: */ { rep_DECLARE1(string, rep_STRINGP); if (rep_message_fun != 0) { (*rep_message_fun)(rep_message, rep_STR(string)); if(!rep_NILP(now)) (*rep_message_fun)(rep_redisplay_message); } return string; } DEFUN("translate-string", Ftranslate_string, Stranslate_string, (repv string, repv table), rep_Subr2) /* ::doc:rep.data#translate-string: translate-string STRING TRANSLATION-TABLE Applies the TRANSLATION-TABLE to each character in the string STRING. TRANSLATION-TABLE is a string, each character represents the translation for an ascii character of that characters position in the string. If the string is less than 256 chars long any undefined characters will remain unchanged. Note that the STRING really is modified, no copy is made! ::end:: */ { int tablen, slen; register unsigned char *str; rep_DECLARE1(string, rep_STRINGP); rep_DECLARE2(table, rep_STRINGP); tablen = rep_STRING_LEN(table); if(!rep_STRING_WRITABLE_P(string)) return(rep_signal_arg_error(string, 1)); str = (unsigned char *)rep_STR(string); slen = rep_STRING_LEN(string); while(slen-- > 0) { register unsigned char c = *str; *str++ = (c < tablen) ? ((unsigned char *)rep_STR(table))[c] : c; } rep_string_modified (string); return(string); } DEFUN("alpha-char-p", Falpha_char_p, Salpha_char_p, (repv ch), rep_Subr1) /* ::doc:rep.data#alpha-char-p:: alpha-char-p CHAR Returns t if CHAR is an alphabetic character. ::end:: */ { return (rep_INTP(ch) && isalpha(rep_INT(ch))) ? Qt : Qnil; } DEFUN("upper-case-p", Fupper_case_p, Supper_case_p, (repv ch), rep_Subr1) /* ::doc:rep.data#upper-case-p:: upper-case-p CHAR Returns t if CHAR is upper case. ::end:: */ { return (rep_INTP(ch) && isupper(rep_INT(ch))) ? Qt : Qnil; } DEFUN("lower-case-p", Flower_case_p, Slower_case_p, (repv ch), rep_Subr1) /* ::doc:rep.data#lower-case-p:: lower-case-p CHAR Returns t if CHAR is lower case. ::end:: */ { return (rep_INTP(ch) && islower(rep_INT(ch))) ? Qt : Qnil; } DEFUN("digit-char-p", Fdigit_char_p, Sdigit_char_p, (repv ch), rep_Subr1) /* ::doc:rep.data#digit-char-p:: digit-char-p CHAR Returns t if CHAR is a digit. ::end:: */ { return (rep_INTP(ch) && isdigit(rep_INT(ch))) ? Qt : Qnil; } DEFUN("alphanumericp", Falphanumericp, Salphanumericp, (repv ch), rep_Subr1) /* ::doc:rep.data#alphanumericp:: alphanumericp CHAR Returns t if CHAR is alpha-numeric. ::end:: */ { return (rep_INTP(ch) && isalnum(rep_INT(ch))) ? Qt : Qnil; } DEFUN("space-char-p", Fspace_char_p, Sspace_char_p, (repv ch), rep_Subr1) /* ::doc:rep.data#space-char-p:: space-char-p CHAR Returns t if CHAR is whitespace. ::end:: */ { return (rep_INTP(ch) && isspace(rep_INT(ch))) ? Qt : Qnil; } DEFUN("char-upcase", Fchar_upcase, Schar_upcase, (repv ch), rep_Subr1) /* ::doc:rep.data#char-upcase:: char-upcase CHAR Returns the upper-case equivalent of CHAR. ::end:: */ { rep_DECLARE1(ch, rep_INTP); return rep_MAKE_INT(toupper(rep_INT(ch))); } DEFUN("char-downcase", Fchar_downcase, Schar_downcase, (repv ch), rep_Subr1) /* ::doc:rep.data#char-downcase:: char-downcase CHAR Returns the lower-case equivalent of CHAR. ::end:: */ { rep_DECLARE1(ch, rep_INTP); return rep_MAKE_INT(tolower(rep_INT(ch))); } DEFUN_INT("system", Fsystem, Ssystem, (repv command), rep_Subr1, "sShell command:") /* ::doc:rep.system#system:: system SHELL-COMMAND Synchronously execute the shell command string SHELL-COMMAND. Returns the exit status of the command, or signals an error if the shell couldn't be started. Note that the exit status is _not_ the same as the return code. It depends on the operating system, but under unix the return code may be found by right-shifting the exit status by eight bits. Low non-zero values represent that the process was killed by a signal. ::end:: */ { rep_DECLARE1(command, rep_STRINGP); return rep_system (rep_STR (command)); } DEFUN("get-command-line-option", Fget_command_line_option, Sget_command_line_option, (repv opt, repv arg), rep_Subr2) /* ::doc:rep.system#get-command-line-option:: get-command-line-option OPTION [REQUIRES-ARGUMENT] Returns t if OPTION was specified on the command line (OPTION is typically a word beginning with `--'). If REQUIRES-ARGUMENT is non-nil, this option requires a parameter, the value of which is returned. If a parameters isn't supplied an error is signalled. ::end:: */ { repv param = Qt; rep_DECLARE1(opt, rep_STRINGP); if (rep_get_option (rep_STR(opt), (arg == Qnil) ? 0 : ¶m)) return param; else return Qnil; } DEFUN ("crypt", Fcrypt, Scrypt, (repv key, repv salt), rep_Subr2) /* ::doc:rep.system#crypt:: crypt KEY SALT The `crypt' function takes a password, KEY, as a string, and a SALT character array, and returns a printable ASCII string which starts with another salt. It is believed that, given the output of the function, the best way to find a KEY that will produce that output is to guess values of KEY until the original value of KEY is found. See crypt(3) for more information. ::end:: */ { const char *output; rep_DECLARE1 (key, rep_STRINGP); rep_DECLARE2 (salt, rep_STRINGP); #ifdef HAVE_CRYPT output = crypt (rep_STR (key), rep_STR (salt)); return rep_string_dup (output); #else { DEFSTRING (err, "crypt () isn't supported on this system"); return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&err))); } #endif } void rep_misc_init(void) { int i; repv tem; if (rep_beep_fun == 0) rep_beep_fun = default_beep; tem = rep_push_structure ("rep.system"); rep_INTERN(operating_system); #ifdef rep_HAVE_UNIX rep_INTERN(unix); Fset (Qoperating_system, Qunix); #endif rep_INTERN_SPECIAL(process_environment); Fset (Qprocess_environment, Qnil); rep_INTERN(rep_version); Fset (Qrep_version, rep_VAL(&rep_version_string)); rep_INTERN(rep_interface_id); Fset (Qrep_interface_id, rep_VAL(rep_MAKE_INT(rep_INTERFACE))); rep_INTERN(rep_build_id); Fset (Qrep_build_id, rep_VAL(&build_id_string)); rep_ADD_SUBR_INT(Sbeep); rep_ADD_SUBR(Scurrent_time); rep_ADD_SUBR(Scurrent_utime); rep_ADD_SUBR(Sfix_time); rep_ADD_SUBR(Scurrent_time_string); rep_ADD_SUBR(Stime_later_p); rep_ADD_SUBR(Ssleep_for); rep_ADD_SUBR(Ssit_for); rep_ADD_SUBR(Sget_command_line_option); rep_ADD_SUBR(Scrypt); rep_ADD_SUBR_INT(Ssystem); rep_ADD_SUBR(Suser_login_name); rep_ADD_SUBR(Suser_full_name); rep_ADD_SUBR(Suser_home_directory); rep_ADD_SUBR(Ssystem_name); rep_ADD_SUBR(Smessage); rep_pop_structure (tem); tem = rep_push_structure ("rep.data"); rep_ADD_SUBR(Stranslate_string); rep_ADD_SUBR(Salpha_char_p); rep_ADD_SUBR(Supper_case_p); rep_ADD_SUBR(Slower_case_p); rep_ADD_SUBR(Sdigit_char_p); rep_ADD_SUBR(Salphanumericp); rep_ADD_SUBR(Sspace_char_p); rep_ADD_SUBR(Schar_upcase); rep_ADD_SUBR(Schar_downcase); rep_ADD_SUBR(Scomplete_string); { repv up = rep_make_string (257); repv down = rep_make_string (257); for(i = 0; i < 256; i++) { ((unsigned char *)rep_STR(up))[i] = toupper(i); ((unsigned char *)rep_STR(down))[i] = tolower(i); } rep_STR(up)[256] = 0; rep_STR(down)[256] = 0; rep_INTERN(upcase_table); rep_INTERN(downcase_table); Fset (Qupcase_table, up); Fset (Qdowncase_table, down); } { repv flatten = rep_make_string (12); for(i = 0; i < 10; i++) ((unsigned char *)rep_STR(flatten))[i] = i; rep_STR(flatten)[10] = ' '; rep_STR(flatten)[11] = 0; rep_INTERN(flatten_table); Fset (Qflatten_table, flatten); } rep_pop_structure (tem); } librep-0.90.2/src/message.c0000644000175200017520000000400711245011153014436 0ustar chrischris/* message.c -- Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #ifdef HAVE_CONFIG_H # include #endif #include "rep.h" #include static void default_message (enum rep_message fn, ...) { va_list args; va_start (args, fn); switch (fn) { int len; char *msg; unsigned long *old_lenp; char **old_msgp; case rep_messagen: msg = (char *)va_arg(args, char *); len = (int)va_arg(args, int); fwrite(msg, 1, len, stderr); fputc('\n', stderr); break; case rep_message: msg = (char *)va_arg(args, char *); fputs (msg, stderr); fputc ('\n', stderr); break; case rep_messagef: msg = (char *)va_arg(args, char *); vfprintf (stderr, msg, args); fputc ('\n', stderr); break; case rep_save_message: old_msgp = (char **)va_arg(args, char **); old_lenp = (unsigned long *)va_arg(args, unsigned long *); *old_msgp = ""; *old_lenp = 0; break; case rep_append_message: msg = (char *)va_arg(args, char *); len = (int)va_arg(args, int); fwrite(msg, len, 1, stderr); fputc('\n', stderr); break; case rep_reset_message: /* (void) */ case rep_restore_message: /* (char *msg, unsigned long len) */ case rep_redisplay_message: /* (void) */ break; } } void (*rep_message_fun)(enum rep_message fn, ...) = default_message; librep-0.90.2/src/memcmp.c0000644000175200017520000000175611245011153014300 0ustar chrischris/* memcmp.c -- Implementation of memcmp Copyright (C) 1998 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include int memcmp(unsigned char *s1, unsigned char *s2, unsigned int n) { while(n-- > 0) { if(*s1 != *s2) return *s1 - *s2; s1++; s2++; } return 0; } librep-0.90.2/src/md5.h0000644000175200017520000001166111245011153013510 0ustar chrischris/* md5.h - Declaration of functions and data types used for MD5 sum computing library functions. Copyright (C) 1995, 1996 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C Library. Bugs can be reported to bug-glibc@prep.ai.mit.edu. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef _MD5_H #define _MD5_H 1 #include #if defined HAVE_LIMITS_H || _LIBC # include #endif /* The following contortions are an attempt to use the C preprocessor to determine an unsigned integral type that is 32 bits wide. An alternative approach is to use autoconf's AC_CHECK_SIZEOF macro, but doing that would require that the configure script compile and *run* the resulting executable. Locally running cross-compiled executables is usually not possible. */ #ifdef _LIBC # include typedef unsigned int32_t md5_uint32; #else # if defined __STDC__ && __STDC__ # define UINT_MAX_32_BITS 4294967295U # else # define UINT_MAX_32_BITS 0xFFFFFFFF # endif /* If UINT_MAX isn't defined, assume it's a 32-bit type. This should be valid for all systems GNU cares about because that doesn't include 16-bit systems, and only modern systems (that certainly have ) have 64+-bit integral types. */ # ifndef UINT_MAX # define UINT_MAX UINT_MAX_32_BITS # endif # if UINT_MAX == UINT_MAX_32_BITS typedef unsigned int md5_uint32; # else # if USHRT_MAX == UINT_MAX_32_BITS typedef unsigned short md5_uint32; # else # if ULONG_MAX == UINT_MAX_32_BITS typedef unsigned long md5_uint32; # else /* The following line is intended to evoke an error. Using #error is not portable enough. */ "Cannot determine unsigned 32-bit data type." # endif # endif # endif #endif #undef __P #if defined (__STDC__) && __STDC__ #define __P(x) x #else #define __P(x) () #endif /* Structure to save state of computation between the single steps. */ struct md5_ctx { md5_uint32 A; md5_uint32 B; md5_uint32 C; md5_uint32 D; md5_uint32 total[2]; md5_uint32 buflen; char buffer[128]; }; /* * The following three functions are build up the low level used in * the functions `md5_stream' and `md5_buffer'. */ /* Initialize structure containing state of computation. (RFC 1321, 3.3: Step 3) */ extern void md5_init_ctx __P ((struct md5_ctx *ctx)); /* Starting with the result of former calls of this function (or the initialization function update the context for the next LEN bytes starting at BUFFER. It is necessary that LEN is a multiple of 64!!! */ extern void md5_process_block __P ((const void *buffer, size_t len, struct md5_ctx *ctx)); /* Starting with the result of former calls of this function (or the initialization function update the context for the next LEN bytes starting at BUFFER. It is NOT required that LEN is a multiple of 64. */ extern void md5_process_bytes __P ((const void *buffer, size_t len, struct md5_ctx *ctx)); /* Process the remaining bytes in the buffer and put result from CTX in first 16 bytes following RESBUF. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. IMPORTANT: On some systems it is required that RESBUF is correctly aligned for a 32 bits value. */ extern void *md5_finish_ctx __P ((struct md5_ctx *ctx, void *resbuf)); /* Put result from CTX in first 16 bytes following RESBUF. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. IMPORTANT: On some systems it is required that RESBUF is correctly aligned for a 32 bits value. */ extern void *md5_read_ctx __P ((const struct md5_ctx *ctx, void *resbuf)); /* Compute MD5 message digest for bytes read from STREAM. The resulting message digest number will be written into the 16 bytes beginning at RESBLOCK. */ extern int md5_stream __P ((FILE *stream, void *resblock)); /* Compute MD5 message digest for LEN bytes beginning at BUFFER. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ extern void *md5_buffer __P ((const char *buffer, size_t len, void *resblock)); #endif librep-0.90.2/src/md5.c0000644000175200017520000003101711245011153013500 0ustar chrischris/* md5.c - Functions to compute MD5 message digest of files or memory blocks according to the definition of MD5 in RFC 1321 from April 1992. Copyright (C) 1995, 1996 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C Library. Bugs can be reported to bug-glibc@prep.ai.mit.edu. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Written by Ulrich Drepper , 1995. */ #ifdef HAVE_CONFIG_H # include #endif #include #if STDC_HEADERS || defined _LIBC # include # include #else # ifndef HAVE_MEMCPY # define memcpy(d, s, n) bcopy ((s), (d), (n)) # endif #endif #include "md5.h" #ifdef _LIBC # include # if __BYTE_ORDER == __BIG_ENDIAN # define WORDS_BIGENDIAN 1 # endif #endif #ifdef WORDS_BIGENDIAN # define SWAP(n) \ (((n) << 24) | (((n) & 0xff00) << 8) | (((n) >> 8) & 0xff00) | ((n) >> 24)) #else # define SWAP(n) (n) #endif /* This array contains the bytes used to pad the buffer to the next 64-byte boundary. (RFC 1321, 3.1: Step 1) */ static const unsigned char fillbuf[64] = { 0x80, 0 /* , 0, 0, ... */ }; /* Initialize structure containing state of computation. (RFC 1321, 3.3: Step 3) */ void md5_init_ctx (ctx) struct md5_ctx *ctx; { ctx->A = 0x67452301; ctx->B = 0xefcdab89; ctx->C = 0x98badcfe; ctx->D = 0x10325476; ctx->total[0] = ctx->total[1] = 0; ctx->buflen = 0; } /* Put result from CTX in first 16 bytes following RESBUF. The result must be in little endian byte order. IMPORTANT: On some systems it is required that RESBUF is correctly aligned for a 32 bits value. */ void * md5_read_ctx (ctx, resbuf) const struct md5_ctx *ctx; void *resbuf; { ((md5_uint32 *) resbuf)[0] = SWAP (ctx->A); ((md5_uint32 *) resbuf)[1] = SWAP (ctx->B); ((md5_uint32 *) resbuf)[2] = SWAP (ctx->C); ((md5_uint32 *) resbuf)[3] = SWAP (ctx->D); return resbuf; } /* Process the remaining bytes in the internal buffer and the usual prolog according to the standard and write the result to RESBUF. IMPORTANT: On some systems it is required that RESBUF is correctly aligned for a 32 bits value. */ void * md5_finish_ctx (ctx, resbuf) struct md5_ctx *ctx; void *resbuf; { /* Take yet unprocessed bytes into account. */ md5_uint32 bytes = ctx->buflen; size_t pad; /* Now count remaining bytes. */ ctx->total[0] += bytes; if (ctx->total[0] < bytes) ++ctx->total[1]; pad = bytes >= 56 ? 64 + 56 - bytes : 56 - bytes; memcpy (&ctx->buffer[bytes], fillbuf, pad); /* Put the 64-bit file length in *bits* at the end of the buffer. */ *(md5_uint32 *) &ctx->buffer[bytes + pad] = SWAP (ctx->total[0] << 3); *(md5_uint32 *) &ctx->buffer[bytes + pad + 4] = SWAP ((ctx->total[1] << 3) | (ctx->total[0] >> 29)); /* Process last bytes. */ md5_process_block (ctx->buffer, bytes + pad + 8, ctx); return md5_read_ctx (ctx, resbuf); } /* Compute MD5 message digest for bytes read from STREAM. The resulting message digest number will be written into the 16 bytes beginning at RESBLOCK. */ int md5_stream (stream, resblock) FILE *stream; void *resblock; { /* Important: BLOCKSIZE must be a multiple of 64. */ #define BLOCKSIZE 4096 struct md5_ctx ctx; char buffer[BLOCKSIZE + 72]; size_t sum; /* Initialize the computation context. */ md5_init_ctx (&ctx); /* Iterate over full file contents. */ while (1) { /* We read the file in blocks of BLOCKSIZE bytes. One call of the computation function processes the whole buffer so that with the next round of the loop another block can be read. */ size_t n; sum = 0; /* Read block. Take care for partial reads. */ do { n = fread (buffer + sum, 1, BLOCKSIZE - sum, stream); sum += n; } while (sum < BLOCKSIZE && n != 0); if (n == 0 && ferror (stream)) return 1; /* If end of file is reached, end the loop. */ if (n == 0) break; /* Process buffer with BLOCKSIZE bytes. Note that BLOCKSIZE % 64 == 0 */ md5_process_block (buffer, BLOCKSIZE, &ctx); } /* Add the last bytes if necessary. */ if (sum > 0) md5_process_bytes (buffer, sum, &ctx); /* Construct result in desired memory. */ md5_finish_ctx (&ctx, resblock); return 0; } /* Compute MD5 message digest for LEN bytes beginning at BUFFER. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ void * md5_buffer (buffer, len, resblock) const char *buffer; size_t len; void *resblock; { struct md5_ctx ctx; /* Initialize the computation context. */ md5_init_ctx (&ctx); /* Process whole buffer but last len % 64 bytes. */ md5_process_bytes (buffer, len, &ctx); /* Put result in desired memory area. */ return md5_finish_ctx (&ctx, resblock); } void md5_process_bytes (buffer, len, ctx) const void *buffer; size_t len; struct md5_ctx *ctx; { /* When we already have some bits in our internal buffer concatenate both inputs first. */ if (ctx->buflen != 0) { size_t left_over = ctx->buflen; size_t add = 128 - left_over > len ? len : 128 - left_over; memcpy (&ctx->buffer[left_over], buffer, add); ctx->buflen += add; if (left_over + add > 64) { md5_process_block (ctx->buffer, (left_over + add) & ~63, ctx); /* The regions in the following copy operation cannot overlap. */ memcpy (ctx->buffer, &ctx->buffer[(left_over + add) & ~63], (left_over + add) & 63); ctx->buflen = (left_over + add) & 63; } buffer = (const char *) buffer + add; len -= add; } /* Process available complete blocks. */ if (len > 64) { md5_process_block (buffer, len & ~63, ctx); buffer = (const char *) buffer + (len & ~63); len &= 63; } /* Move remaining bytes in internal buffer. */ if (len > 0) { memcpy (ctx->buffer, buffer, len); ctx->buflen = len; } } /* These are the four functions used in the four steps of the MD5 algorithm and defined in the RFC 1321. The first function is a little bit optimized (as found in Colin Plumbs public domain implementation). */ /* #define FF(b, c, d) ((b & c) | (~b & d)) */ #define FF(b, c, d) (d ^ (b & (c ^ d))) #define FG(b, c, d) FF (d, b, c) #define FH(b, c, d) (b ^ c ^ d) #define FI(b, c, d) (c ^ (b | ~d)) /* Process LEN bytes of BUFFER, accumulating context into CTX. It is assumed that LEN % 64 == 0. */ void md5_process_block (buffer, len, ctx) const void *buffer; size_t len; struct md5_ctx *ctx; { md5_uint32 correct_words[16]; const md5_uint32 *words = buffer; size_t nwords = len / sizeof (md5_uint32); const md5_uint32 *endp = words + nwords; md5_uint32 A = ctx->A; md5_uint32 B = ctx->B; md5_uint32 C = ctx->C; md5_uint32 D = ctx->D; /* First increment the byte count. RFC 1321 specifies the possible length of the file up to 2^64 bits. Here we only compute the number of bytes. Do a double word increment. */ ctx->total[0] += len; if (ctx->total[0] < len) ++ctx->total[1]; /* Process all bytes in the buffer with 64 bytes in each round of the loop. */ while (words < endp) { md5_uint32 *cwp = correct_words; md5_uint32 A_save = A; md5_uint32 B_save = B; md5_uint32 C_save = C; md5_uint32 D_save = D; /* First round: using the given function, the context and a constant the next context is computed. Because the algorithms processing unit is a 32-bit word and it is determined to work on words in little endian byte order we perhaps have to change the byte order before the computation. To reduce the work for the next steps we store the swapped words in the array CORRECT_WORDS. */ #define OP(a, b, c, d, s, T) \ do \ { \ a += FF (b, c, d) + (*cwp++ = SWAP (*words)) + T; \ ++words; \ CYCLIC (a, s); \ a += b; \ } \ while (0) /* It is unfortunate that C does not provide an operator for cyclic rotation. Hope the C compiler is smart enough. */ #define CYCLIC(w, s) (w = (w << s) | (w >> (32 - s))) /* Before we start, one word to the strange constants. They are defined in RFC 1321 as T[i] = (int) (4294967296.0 * fabs (sin (i))), i=1..64 */ /* Round 1. */ OP (A, B, C, D, 7, 0xd76aa478); OP (D, A, B, C, 12, 0xe8c7b756); OP (C, D, A, B, 17, 0x242070db); OP (B, C, D, A, 22, 0xc1bdceee); OP (A, B, C, D, 7, 0xf57c0faf); OP (D, A, B, C, 12, 0x4787c62a); OP (C, D, A, B, 17, 0xa8304613); OP (B, C, D, A, 22, 0xfd469501); OP (A, B, C, D, 7, 0x698098d8); OP (D, A, B, C, 12, 0x8b44f7af); OP (C, D, A, B, 17, 0xffff5bb1); OP (B, C, D, A, 22, 0x895cd7be); OP (A, B, C, D, 7, 0x6b901122); OP (D, A, B, C, 12, 0xfd987193); OP (C, D, A, B, 17, 0xa679438e); OP (B, C, D, A, 22, 0x49b40821); /* For the second to fourth round we have the possibly swapped words in CORRECT_WORDS. Redefine the macro to take an additional first argument specifying the function to use. */ #undef OP #define OP(f, a, b, c, d, k, s, T) \ do \ { \ a += f (b, c, d) + correct_words[k] + T; \ CYCLIC (a, s); \ a += b; \ } \ while (0) /* Round 2. */ OP (FG, A, B, C, D, 1, 5, 0xf61e2562); OP (FG, D, A, B, C, 6, 9, 0xc040b340); OP (FG, C, D, A, B, 11, 14, 0x265e5a51); OP (FG, B, C, D, A, 0, 20, 0xe9b6c7aa); OP (FG, A, B, C, D, 5, 5, 0xd62f105d); OP (FG, D, A, B, C, 10, 9, 0x02441453); OP (FG, C, D, A, B, 15, 14, 0xd8a1e681); OP (FG, B, C, D, A, 4, 20, 0xe7d3fbc8); OP (FG, A, B, C, D, 9, 5, 0x21e1cde6); OP (FG, D, A, B, C, 14, 9, 0xc33707d6); OP (FG, C, D, A, B, 3, 14, 0xf4d50d87); OP (FG, B, C, D, A, 8, 20, 0x455a14ed); OP (FG, A, B, C, D, 13, 5, 0xa9e3e905); OP (FG, D, A, B, C, 2, 9, 0xfcefa3f8); OP (FG, C, D, A, B, 7, 14, 0x676f02d9); OP (FG, B, C, D, A, 12, 20, 0x8d2a4c8a); /* Round 3. */ OP (FH, A, B, C, D, 5, 4, 0xfffa3942); OP (FH, D, A, B, C, 8, 11, 0x8771f681); OP (FH, C, D, A, B, 11, 16, 0x6d9d6122); OP (FH, B, C, D, A, 14, 23, 0xfde5380c); OP (FH, A, B, C, D, 1, 4, 0xa4beea44); OP (FH, D, A, B, C, 4, 11, 0x4bdecfa9); OP (FH, C, D, A, B, 7, 16, 0xf6bb4b60); OP (FH, B, C, D, A, 10, 23, 0xbebfbc70); OP (FH, A, B, C, D, 13, 4, 0x289b7ec6); OP (FH, D, A, B, C, 0, 11, 0xeaa127fa); OP (FH, C, D, A, B, 3, 16, 0xd4ef3085); OP (FH, B, C, D, A, 6, 23, 0x04881d05); OP (FH, A, B, C, D, 9, 4, 0xd9d4d039); OP (FH, D, A, B, C, 12, 11, 0xe6db99e5); OP (FH, C, D, A, B, 15, 16, 0x1fa27cf8); OP (FH, B, C, D, A, 2, 23, 0xc4ac5665); /* Round 4. */ OP (FI, A, B, C, D, 0, 6, 0xf4292244); OP (FI, D, A, B, C, 7, 10, 0x432aff97); OP (FI, C, D, A, B, 14, 15, 0xab9423a7); OP (FI, B, C, D, A, 5, 21, 0xfc93a039); OP (FI, A, B, C, D, 12, 6, 0x655b59c3); OP (FI, D, A, B, C, 3, 10, 0x8f0ccc92); OP (FI, C, D, A, B, 10, 15, 0xffeff47d); OP (FI, B, C, D, A, 1, 21, 0x85845dd1); OP (FI, A, B, C, D, 8, 6, 0x6fa87e4f); OP (FI, D, A, B, C, 15, 10, 0xfe2ce6e0); OP (FI, C, D, A, B, 6, 15, 0xa3014314); OP (FI, B, C, D, A, 13, 21, 0x4e0811a1); OP (FI, A, B, C, D, 4, 6, 0xf7537e82); OP (FI, D, A, B, C, 11, 10, 0xbd3af235); OP (FI, C, D, A, B, 2, 15, 0x2ad7d2bb); OP (FI, B, C, D, A, 9, 21, 0xeb86d391); /* Add the starting values of the context. */ A += A_save; B += B_save; C += C_save; D += D_save; } /* Put checksum in context given as argument. */ ctx->A = A; ctx->B = B; ctx->C = C; ctx->D = D; } librep-0.90.2/src/main.c0000644000175200017520000003427411245011153013747 0ustar chrischris/* main.c -- Entry point for Jade Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #include #include void *rep_common_db; int rep_recurse_depth = -1; rep_bool (*rep_on_idle_fun)(int since_last); DEFSYM(idle_hook, "idle-hook"); /* ::doc:idle-hook:: This hook gets evaluated every second while the editor is idle. Don't depend on how regularly this gets called, any events from the window-system will delay it. Also, auto-saving files and garbage-collection take precedence when there's idle time available. Use this hook sparingly, or for short periods only! ::end:: ::doc:program-name:: The name of the program running the rep interpreter. ::end:: ::doc:error-mode:: When nil, errors are handled at the current event loop, other possible values include `exit' and `top-level'. ::end:: ::doc:interrupt-mode:: When nil, interrupts are handled at the current event loop, other possible values include `exit' and `top-level'. ::end:: */ /* Called when we get a termination signal. */ void (*rep_on_termination_fun)(void); /* The event-loop function, may be entered recursively. */ repv (*rep_event_loop_fun)(void) = rep_event_loop; /* rep_init () will set this to an early stack pointer */ char *rep_stack_bottom; DEFSYM(exit, "exit"); DEFSYM(quit, "quit"); DEFSYM(top_level, "top-level"); DEFSYM(command_line_args, "command-line-args"); DEFSYM(batch_mode, "batch-mode"); DEFSYM(interpreted_mode, "interpreted-mode"); DEFSYM(program_name, "program-name"); DEFSYM(error_mode, "error-mode"); DEFSYM(interrupt_mode, "interrupt-mode"); DEFSYM(before_exit_hook, "before-exit-hook"); static void rep_main_init(void); DEFSTRING(noarg, "No argument for option"); /* Look for the command line option called OPTION. If ARGP is non-null, the option requires an argument, it will be stored in *ARGP. If the option isn't given return false, else return true. */ rep_bool rep_get_option (char *option, repv *argp) { int optlen = strlen(option); repv tem = Fsymbol_value (Qcommand_line_args, Qt); while (!rep_INTERRUPTP && rep_CONSP(tem) && rep_STRINGP(rep_CAR(tem))) { if (strncmp (option, rep_STR(rep_CAR(tem)), optlen) == 0) { repv opt = rep_CAR(tem), cdr = rep_CDR(tem); if (rep_STR(opt)[optlen] == '=' || rep_STR(opt)[optlen] == 0) { Fset (Qcommand_line_args, Fdelq (opt, Fsymbol_value (Qcommand_line_args, Qt))); if (argp != 0) { if (rep_STR(opt)[optlen] == '=') { *argp = rep_string_dup (rep_STR(opt) + optlen + 1); return rep_TRUE; } else if (rep_CONSP(cdr) && rep_STRINGP(rep_CAR(cdr))) { *argp = rep_CAR(cdr); Fset (Qcommand_line_args, Fdelq (*argp, Fsymbol_value(Qcommand_line_args, Qt))); return rep_TRUE; } else { Fsignal (Qerror, rep_list_2(rep_VAL(&noarg), rep_string_dup(option))); return rep_FALSE; } } else return rep_TRUE; } } tem = rep_CDR(tem); rep_TEST_INT; } return rep_FALSE; } static int get_main_options(char *prog_name, int *argc_p, char ***argv_p) { int argc = *argc_p; char **argv = *argv_p; repv head, *last; /* any command line args are made into a list of strings in symbol command-line-args. */ head = Qnil; last = &head; while(argc > 0) { *last = Fcons(rep_string_dup(*argv), Qnil); last = &rep_CDR(*last); argc--; argv++; } Fset (Qcommand_line_args, head); *argc_p = argc; *argv_p = argv; if (rep_get_option("--batch", 0)) Fset (Qbatch_mode, Qt); if (rep_get_option("--interp", 0)) { Fset (Qinterpreted_mode, Qt); /* XXX somewhat non-related, but.. */ rep_record_origins = rep_TRUE; } return rep_TRUE; } /* GCC 4 helpfully inlines this function and breaks the stack check. */ #if __GNUC__ >= 4 static void check_configuration (int *stack_low) __attribute__ ((noinline)); #endif void check_configuration (int *stack_low) { int stack_high; int stack_dir = (&stack_high < stack_low) ? -1 : +1; if (sizeof (rep_PTR_SIZED_INT) < sizeof(void *)) { fprintf (stderr, " ** error: --with-value-type is incorrect; it should be `%s'\n", (sizeof (int) >= sizeof (void *)) ? "int" : (sizeof (long) >= sizeof (void *)) ? "long" : (sizeof (rep_long_long) >= sizeof (void *)) ? "long long" : ""); exit (10); } if (sizeof (rep_PTR_SIZED_INT) != rep_PTR_SIZED_INT_SIZEOF) { fprintf (stderr, " ** error: --with-value-sizeof is incorrect; it should be %d\n", (int) sizeof (rep_PTR_SIZED_INT)); exit (10); } if (stack_dir != STACK_DIRECTION) { fprintf (stderr, " ** error: --with-stack-direction is incorrect; it should be %d\n", stack_dir); exit (10); } } /* Note that `argc' _must_ (I mean _must_!) be a pointer to the real argc on the stack frame of the outermost procedure */ void rep_init(char *prog_name, int *argc, char ***argv, void (*sys_symbols)(void), void (*obsolete_sys_usage)(void)) { #ifdef ENABLE_BROKEN_DUMPING char *dump_file = getenv ("REPDUMPFILE"); #else char *dump_file = 0; #endif rep_init_from_dump (prog_name, argc, argv, sys_symbols, obsolete_sys_usage, dump_file); } void rep_init_from_dump(char *prog_name, int *argc, char ***argv, void (*sys_symbols)(void), void (*obsolete_sys_usage)(void), char *dump_file) { int dummy; check_configuration (&dummy); if(!sys_memory_init()) exit(10); rep_common_db = rep_db_alloc("common", 4096); rep_pre_values_init(); rep_pre_sys_os_init(); if(rep_pre_symbols_init()) { #ifdef ENABLE_BROKEN_DUMPING char *tem = getenv ("REPUNDUMPED"); if (dump_file && (!tem || atoi(tem) == 0)) rep_dumped_init (dump_file); #endif rep_symbols_init(); rep_structures_init (); rep_numbers_init (); rep_lisp_init(); rep_values_init(); rep_origin_init (); /* must be after values */ rep_macros_init (); rep_lispcmds_init(); rep_lispmach_init(); rep_find_init(); rep_main_init(); rep_misc_init(); rep_streams_init(); rep_files_init(); rep_datums_init(); rep_fluids_init(); rep_weak_refs_init (); rep_sys_os_init(); /* XXX Assumes that argc is on the stack. I can't think of XXX any other way to reliably find the real base of the XXX stack.. */ rep_stack_bottom = (char *) argc; rep_continuations_init (); if (sys_symbols != 0) (*sys_symbols)(); Fset (Qprogram_name, rep_string_dup (prog_name)); if(get_main_options(prog_name, argc, argv)) return; } exit (10); } /* Should be called sometime after calling rep_init*. It will load the standard init scripts, plus FILE if non-nil. Returns the result of the last form evaluated. */ repv rep_load_environment (repv file) { /* Modules that have Lisp code stored in the filing system. */ static const char *init[] = { "rep.lang.interpreter", "rep.structures", "rep.module-system", "rep.lang.math", "rep.data", "rep.regexp", "rep.system", "rep.io.streams", "rep.io.files", "rep.io.file-handlers", "rep", 0 }; const char **ptr; repv res = Qnil; rep_GC_root gc_file; rep_PUSHGC (gc_file, file); /* 1. Do the rep bootstrap */ if (rep_dumped_non_constants != rep_NULL) res = Feval (rep_dumped_non_constants); for (ptr = init; res != rep_NULL && *ptr != 0; ptr++) { res = rep_bootstrap_structure (*ptr); } /* 2. Do the caller-local bootstrap */ if (res != rep_NULL && rep_STRINGP(file)) res = Fload (file, Qnil, Qnil, Qnil, Qnil); rep_POPGC; return res; } void rep_kill(void) { rep_sys_os_kill(); rep_find_kill(); rep_files_kill(); #ifdef HAVE_DYNAMIC_LOADING rep_kill_dl_libraries(); #endif rep_lispmach_kill(); rep_db_kill(); rep_tuples_kill(); rep_values_kill(); sys_memory_kill(); } /* This function gets called when we have idle time available. The single argument is the number of seconds since we weren't idle. The first idle period after a non-idle period should pass zero. Returns rep_TRUE if the display should be refreshed. */ rep_bool rep_on_idle(long since_last_event) { static rep_bool called_hook; static int depth; rep_bool res = rep_FALSE; depth++; /* A timeout; do one of: * Remove messages in minibuffers * Print the current key-prefix * Auto-save a buffer * GC if enough data allocated * Run the `idle-hook' (only once per idle-period) */ if(since_last_event == 0) called_hook = rep_FALSE; if(rep_on_idle_fun != 0 && (*rep_on_idle_fun)(since_last_event)) res = rep_TRUE; else if(rep_data_after_gc > rep_idle_gc_threshold) /* nothing was saved so try a GC */ Fgarbage_collect (Qnil); else if(!called_hook && depth == 1) { repv hook = Fsymbol_value(Qidle_hook, Qt); if(!rep_VOIDP(hook) && !rep_NILP(hook)) { Fcall_hook(hook, Qnil, Qnil); res = rep_TRUE; } called_hook = rep_TRUE; } depth--; return res; } /* The input loop should call this function when rep_throw_value == rep_NULL. It returns rep_TRUE when the input loop should exit, returning whatever is stored in *RESULT-P. */ rep_bool rep_handle_input_exception(repv *result_p) { repv tv = rep_throw_value; repv car = rep_CAR(tv); rep_throw_value = rep_NULL; *result_p = rep_NULL; if(car == Qexit) { *result_p = rep_CDR(tv); if(rep_recurse_depth > 0) return rep_TRUE; } else if((car == Qtop_level) && (rep_recurse_depth == 0)) *result_p = rep_CDR(tv); else if(car == Qquit) { *result_p = rep_CDR(tv); return rep_TRUE; } else if(car == Quser_interrupt) { repv tem = Fsymbol_value (Qinterrupt_mode, Qt); if (tem == Qexit && rep_recurse_depth == 0) goto terminate; else if (rep_recurse_depth == 0 || tem != Qtop_level) rep_handle_error(car, Qnil); else goto unhandled; } else if(car == Qerror) { repv tem = Fsymbol_value (Qerror_mode, Qt); if (tem == Qexit && rep_recurse_depth == 0) { rep_handle_error(rep_CAR(rep_CDR(tv)), rep_CDR(rep_CDR(tv))); goto terminate; } else if (rep_recurse_depth == 0 || tem != Qtop_level) rep_handle_error(rep_CAR(rep_CDR(tv)), rep_CDR(rep_CDR(tv))); else goto unhandled; } else if(car == Qterm_interrupt) { terminate: if(rep_recurse_depth == 0 && rep_on_termination_fun != 0) (*rep_on_termination_fun)(); *result_p = Qnil; return rep_TRUE; } #if 0 else if(rep_recurse_depth == 0) rep_handle_error(Qno_catcher, rep_LIST_1(car)); #endif else { unhandled: rep_throw_value = tv; return rep_TRUE; } return rep_FALSE; } /* should be called before exiting (for any reason). returns the value that should be returned by the process */ int rep_top_level_exit (void) { rep_GC_root gc_throw; repv throw = rep_throw_value; rep_throw_value = rep_NULL; if(throw && rep_CAR(throw) == Qerror) { /* If quitting due to an error, print the error cell if at all possible. */ repv stream = Fstderr_file(); if(stream && rep_FILEP(stream)) { fputs("error--> ", stderr); Fprin1(rep_CDR(throw), stream); fputc('\n', stderr); } else fputs("error in initialisation\n", stderr); return 10; } rep_PUSHGC(gc_throw, throw); Fcall_hook (Qbefore_exit_hook, Qnil, Qnil); rep_throw_value = rep_NULL; rep_POPGC; if (throw && rep_CAR (throw) == Qquit && rep_INTP (rep_CDR(throw))) return (rep_INT (rep_CDR(throw))); return 0; } DEFUN_INT("recursive-edit", Frecursive_edit, Srecursive_edit, (void), rep_Subr0, "") /* ::doc:rep.system#recursive-edit:: recursive-edit Enter a new recursive-edit. ::end:: */ { repv ret; rep_recurse_depth++; ret = (*rep_event_loop_fun)(); rep_recurse_depth--; #ifdef C_ALLOCA /* Using the C implementation of alloca. So garbage collect anything below the current stack depth. */ alloca(0); #endif return ret; } /* Called from the main function of input-driven programs. Avoids the program exiting due to an unhandled exception */ repv rep_top_level_recursive_edit (void) { repv ret; again: ret = Frecursive_edit (); if (rep_recurse_depth < 0 && rep_throw_value && rep_CONSP (rep_throw_value)) { repv type = rep_CAR (rep_throw_value); if (type != Qquit && type != Qerror && type != Qterm_interrupt && type != Quser_interrupt) { rep_throw_value = rep_NULL; rep_handle_error (Qno_catcher, rep_LIST_1 (type)); goto again; } } return ret; } DEFUN("recursion-depth", Frecursion_depth, Srecursion_depth, (void), rep_Subr0) /* ::doc:rep.system#recursion-depth:: recursion-depth Returns the number of recursive-edit's deep we are, zero signifies the original level. ::end:: */ { return rep_MAKE_INT(rep_recurse_depth); } void rep_deprecated (rep_bool *seen, const char *desc) { if (!*seen) { fprintf (stderr, "rep: using deprecated feature - %s\n", desc); *seen = rep_TRUE; } } static void check_configuration (int *stack_low) __attribute__((noinline)); static void rep_main_init(void) { repv tem = rep_push_structure ("rep.system"); rep_ADD_SUBR_INT(Srecursive_edit); rep_ADD_SUBR(Srecursion_depth); rep_pop_structure (tem); rep_INTERN(quit); rep_INTERN(exit); rep_INTERN(top_level); rep_INTERN_SPECIAL(command_line_args); rep_INTERN_SPECIAL(idle_hook); rep_INTERN_SPECIAL(batch_mode); Fset (Qbatch_mode, Qnil); rep_INTERN_SPECIAL(interpreted_mode); Fset (Qinterpreted_mode, Qnil); rep_INTERN_SPECIAL(program_name); rep_INTERN_SPECIAL(error_mode); Fset (Qerror_mode, Qnil); rep_INTERN_SPECIAL(interrupt_mode); Fset (Qinterrupt_mode, Qnil); rep_INTERN_SPECIAL(before_exit_hook); } librep-0.90.2/src/macros.c0000644000175200017520000001276611245011153014311 0ustar chrischris/* macros.c -- macroexpand etc Copyright (C) 1993, 1994, 2000 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* Commentary: The idea is to memoize macro expansions, but only until the next garbage collection. This introduces very little memory overhead, two cons cells per expansion (the expansion is around anyway until gc) Whether it would be useful to keep expansions around for longer is something that needs to be looked at later.. It's actually pretty good on its own. E.g. doing (compile-compiler) with all interpreted code gives a miss ratio of about .023 */ #define _GNU_SOURCE #include "repint.h" #include #ifdef NEED_MEMORY_H # include #endif #define HIST_SIZE 256 #define HIST_HASH_FN(x) (((x) >> 4) % HIST_SIZE) /* Each entry is a chain of cons cells. But note that the last cell's cdr is dotted to ((repv)0) not Qnil */ static repv history[HIST_SIZE]; static int macro_hits, macro_misses; DEFSYM(macro_environment, "macro-environment"); static inline repv symbol_value_in_structure (repv structure, repv sym) { repv old = rep_structure, value; rep_structure = structure; value = Fsymbol_value (sym, Qt); rep_structure = old; return value; } DEFUN("macroexpand-1", Fmacroexpand_1, Smacroexpand_1, (repv form, repv env), rep_Subr2) /* ::doc:rep.lang.interpreter#macroexpand-1:: macroexpand-1 FORM [ENVIRONMENT] If FORM is a macro call, expand it once and return the resulting form. If ENVIRONMENT is specified it is a function to call to do the actual expansion. Any macro expanders recursively calling macroexpand should pass the value of the `macro-environment' variable to this parameter. ::end:: */ { rep_GC_root gc_bindings; repv car, bindings; if (!rep_CONSP (form)) return form; if (env != Qnil && Ffunctionp (env) != Qnil) return rep_call_lisp1 (env, form); again: car = rep_CAR(form); if(rep_SYMBOLP(car)) { if (rep_STRUCTUREP (env)) /* deref the symbol in the module that it appeared in.. */ car = symbol_value_in_structure (env, car); else car = Fsymbol_value (car, Qt); if (!rep_CONSP(car) || rep_CAR(car) != Qmacro) return form; car = rep_CDR(car); } else if (rep_CONSP(car) && rep_CAR(car) == Qmacro) car = rep_CDR(car); if (Ffunctionp(car) == Qnil) return form; if (rep_FUNARGP (car)) { repv fun = rep_FUNARG (car)->fun; if (rep_CONSP (fun) && rep_CAR (fun) == Qautoload) { /* an autoload. handle this locally. */ struct rep_Call lc; rep_GC_root gc_form, gc_env; lc.fun = Qnil; lc.args = Qnil; rep_PUSH_CALL (lc); rep_USE_FUNARG (car); rep_PUSHGC (gc_form, form); rep_PUSHGC (gc_env, env); car = rep_load_autoload (car); rep_POPGC; rep_POPGC; rep_POP_CALL (lc); if (car != rep_NULL) goto again; else return rep_NULL; } } bindings = rep_bind_symbol (Qnil, Qmacro_environment, rep_structure); rep_PUSHGC(gc_bindings, bindings); form = rep_funcall (car, rep_CDR(form), rep_FALSE); rep_POPGC; rep_unbind_symbols (bindings); return form; } DEFUN("macroexpand", Fmacroexpand, Smacroexpand, (repv form, repv env), rep_Subr2) /* ::doc:rep.lang.interpreter#macroexpand:: macroexpand FORM [ENVIRONMENT] If FORM is a macro call, expand it until it isn't. If ENVIRONMENT is specified it is a function to call to do the actual expansion. Any macro expanders recursively calling macroexpand should pass the value of the `macro-environment' variable to this parameter. ::end:: */ { repv input = form, pred, ptr; rep_GC_root gc_input, gc_pred; if (!rep_CONSP (form)) return form; /* Search the history */ ptr = history[HIST_HASH_FN(form)]; while (ptr != 0) { if (rep_CAAR (ptr) == form) { macro_hits++; return rep_CDAR (ptr); } ptr = rep_CDR (ptr); } macro_misses++; rep_PUSHGC(gc_input, input); rep_PUSHGC(gc_pred, pred); pred = form; while (1) { form = Fmacroexpand_1 (pred, env); if (form == rep_NULL || form == pred) break; pred = form; } rep_POPGC; rep_POPGC; if (form != rep_NULL) { /* Cache for future use */ unsigned int hash = HIST_HASH_FN(input); history[hash] = Fcons (Fcons (input, form), history[hash]); } return form; } void rep_macros_before_gc (void) { /* XXX Perhaps be more discerning? (We would need to arrange some XXX marking then though..) */ rep_macros_clear_history (); } void rep_macros_clear_history (void) { memset (history, 0, sizeof (history)); } void rep_macros_init (void) { repv tem = rep_push_structure ("rep.lang.interpreter"); rep_ADD_SUBR(Smacroexpand); rep_ADD_SUBR(Smacroexpand_1); rep_INTERN_SPECIAL(macro_environment); Fset (Qmacro_environment, Qnil); rep_macros_clear_history (); rep_pop_structure (tem); } librep-0.90.2/src/lispmach.h0000644000175200017520000014551411245011153014630 0ustar chrischris/* lispmach.h -- Interpreter for compiled Lisp forms $Id$ Copyright (C) 1993, 1994, 2000 John Harper This file is part of Librep. Librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* free macros: ASSERT (expr) BYTECODE_PROFILE THREADED_VM CACHE_TOS BC_APPLY_SELF EXTRA_VM_CODE OPTIMIZE_FOR_SPACE defined functions: vm (repv code, repv consts, int argc, repv *argv, int v_stkreq, int b_stkreq, int s_stkreq); inline_apply_bytecode (repv subr, int nargs, repv *args); */ /* Use the threaded interpreter with GNU CC. */ #ifdef __GNUC__ # define THREADED_VM 1 #endif #include "bytecodes.h" #include DEFSTRING(err_bytecode_error, "Byte-code error"); DEFSTRING(unknown_op, "Unknown lisp opcode"); static repv vm (repv code, repv consts, int argc, repv *argv, int v_stkreq, int b_stkreq, int s_stkreq); #ifndef OPTIMIZE_FOR_SPACE # define maybe_inline inline #else # define maybe_inline # undef inline_Fcons # define inline_Fcons Fcons #endif /* Helper functions Note the careful use of inlining.. the icache is crucial, we want the VM to be as small as possible, so that as much other code as possible fits in cache as well. However, if a helper function is only called once (or maybe is in a crucial path), then inline it.. The speedup from this (_not_ inlining everything) is _huge_ */ static maybe_inline repv list_tail (repv list, int n) { while (n-- > 0) list = rep_CDR (list); return list; } /* Unbind one level of the BIND-STACK and return the new head of the stack. Each item in the BIND-STACK may be one of: INTEGER variable binding frame (error . (PC . STACK-DEPTH)) not unbound here; install exception handler at PC returns the number of dynamic bindings removed */ static maybe_inline int inline_unbind (repv item) { if (rep_INTP (item)) { /* A set of symbol bindings (let or let*). */ int lexicals = rep_LEX_BINDINGS (item); int specials = rep_SPEC_BINDINGS (item); rep_env = list_tail (rep_env, lexicals); rep_special_bindings = list_tail (rep_special_bindings, specials); return specials; } else if (item == Qnil || (rep_CONSP (item) && rep_CAR (item) == Qerror)) return 0; else abort (); } #ifdef OPTIMIZE_FOR_SPACE # define unbind inline_unbind #else static int unbind (repv item) { return inline_unbind (item); } #endif static maybe_inline void unbind_n (repv *ptr, int n) { while (n-- > 0) unbind (ptr[n]); } /* Walk COUNT entries down the environment */ static inline repv snap_environment (int count) { register repv ptr = rep_env; while (count-- > 0) ptr = rep_CDR(ptr); return ptr; } static repv search_special_bindings (repv sym) { register repv env = rep_special_bindings; while (env != Qnil && rep_CAAR(env) != sym) env = rep_CDR(env); return env != Qnil ? rep_CAR(env) : env; } /* Zero out N lisp pointers starting from address S */ #define repv_bzero(s, n) \ do { \ register repv *s__ = (s); \ register int n__ = (n); \ while (n__-- > 0) \ *s__++ = 0; \ } while (0) /* Lisp VM. */ static maybe_inline repv list_ref (repv list, int elt) { while (rep_CONSP(list) && elt-- > 0) list = rep_CDR(list); return rep_CONSP(list) ? rep_CAR(list) : Qnil; } #ifdef CACHE_TOS # define RELOAD tos = *stackp # define UPDATE *stackp = tos # define TOP tos # define POP do { stackp--; RELOAD; } while (0) # define POPN(n) do { stackp -= (n); RELOAD; } while (0) # define POP1(a) do { (a) = tos; stackp--; RELOAD; } while (0) # define POP2(a,b) do { (a) = tos; (b) = stackp[-1]; stackp -= 2; RELOAD; } while (0) # define PUSH(v) do { UPDATE; tos = (v); ++stackp; } while (0) #else # define RELOAD # define UPDATE # define TOP (*stackp) # define POP do { stackp--; } while (0) # define POPN(n) do { stackp -= (n); } while (0) # define POP1(a) do { (a) = *stackp--; } while (0) # define POP2(a,b) do { (a) = stackp[0]; (b) = stackp[-1]; stackp -= 2; } while (0) # define PUSH(v) do { *(++stackp) = (v); } while (0) #endif #define STK_USE (stackp - stack) #define BIND_USE (bindp - (bindstack - 1)) #define BIND_RET_POP (*bindp--) #define BIND_TOP (*bindp) #define BIND_TOP_P (bindp < bindstack) #define BIND_PUSH(x) (*(++bindp) = (x)) #define CHECK_NEXT \ do { \ ASSERT (STK_USE <= v_stkreq); \ ASSERT (BIND_USE <= b_stkreq + 1); \ ASSERT (((char *)pc - rep_STR (code)) < rep_STRING_LEN (code)); \ } while (0) #ifdef BYTECODE_PROFILE # define PROFILE_NEXT do { bytecode_profile[*pc]++; } while (0) #else # define PROFILE_NEXT #endif #define SAFE_NEXT__ \ do { \ CHECK_NEXT; \ PROFILE_NEXT; \ X_SAFE_NEXT; \ } while (0) #ifndef OPTIMIZE_FOR_SPACE # define SAFE_NEXT SAFE_NEXT__ #else # define SAFE_NEXT goto safe_next #endif #define FETCH (*pc++) #define FETCH2(var) ((var) = (FETCH << ARG_SHIFT), (var) += FETCH) #define SYNC_GC \ do { \ UPDATE; \ gc_stack.count = STK_USE; \ gc_bindstack.count = BIND_USE; \ } while (0) /* These macros pop as many args as required then call the specified function properly. */ #define CALL_1(cmd) \ TOP = cmd (TOP); \ NEXT; #define CALL_2(cmd) \ POP1 (tmp); \ TOP = cmd (TOP, tmp); \ NEXT; #define CALL_3(cmd) \ POP2 (tmp, tmp2); \ TOP = cmd (TOP, tmp2, tmp); \ NEXT; /* We used to check for both rep_throw_value != 0, and TOP == 0. But since rep_throw_value is a (volatile) global, this is slower than just checking TOP (by about 1%) */ #define ERROR_OCCURRED_P (TOP == rep_NULL) #ifndef THREADED_VM /* Non-threaded interpretation, just use a big switch statement in a while loop. */ # define BEGIN_DISPATCH fetch: switch (FETCH) { # define END_DISPATCH } /* Output the case statement for an instruction OP, with an embedded argument. The code for the instruction should start at the following piece of code. */ # define BEGIN_INSN_WITH_ARG(op) \ case op+7: \ FETCH2(arg); goto rep_CONCAT(op_, op); \ case op+6: \ arg = FETCH; goto rep_CONCAT(op_, op); \ case op: case op+1: case op+2: case op+3: case op+4: case op+5: \ arg = pc[-1] - op; \ rep_CONCAT(op_, op): { # define BEGIN_INSN(op) case op: { # define BEGIN_DEFAULT_INSN default: { # define END_INSN } # define X_SAFE_NEXT goto fetch # define INLINE_NEXT if (!ERROR_OCCURRED_P) SAFE_NEXT; else HANDLE_ERROR # define NEXT goto check_error # define RETURN goto quit # define HANDLE_ERROR goto error #else /* !THREADED_VM */ /* Indirect threading, as described in: A Portable Forth Engine. @InProceedings{ertl93, author = "M. Anton Ertl", title = "A Portable {Forth} Engine", booktitle = "EuroFORTH '93 conference proceedings", year = "1993", address = "Mari\'ansk\'e L\'azn\`e (Marienbad)", url = "http://www.complang.tuwien.ac.at/papers/ertl93.ps.Z", } the intitial implementation by Ceri Storey, completed by John Harper. */ # define BEGIN_DISPATCH SAFE_NEXT; { # define END_DISPATCH } # define TAG(op) rep_CONCAT(insn_, op) # define TAG0(op) rep_CONCAT(insn_0_, op) # define TAG1(op) rep_CONCAT(insn_1_, op) # define TAG2(op) rep_CONCAT(insn_2_, op) # define TAG_DEFAULT insn_default # define BEGIN_INSN(op) TAG(op): { # define BEGIN_DEFAULT_INSN TAG_DEFAULT: { # define END_INSN } # define BEGIN_INSN_WITH_ARG(op) \ TAG2(op): \ FETCH2(arg); goto TAG(op); \ TAG1(op): \ arg = FETCH; goto TAG(op); \ TAG0(op): \ arg = pc[-1] - op; \ BEGIN_INSN(op) # define X_SAFE_NEXT goto *cfa[FETCH] # define INLINE_NEXT if (!ERROR_OCCURRED_P) SAFE_NEXT; else HANDLE_ERROR # define NEXT goto check_error # define RETURN goto quit # define HANDLE_ERROR goto error # ifdef OPTIMIZE_FOR_SPACE # define SLOT_REF_TAGS \ &&TAG0(OP_SLOT_REF), &&TAG0(OP_SLOT_REF), &&TAG0(OP_SLOT_REF), &&TAG0(OP_SLOT_REF), \ &&TAG0(OP_SLOT_REF), &&TAG0(OP_SLOT_REF), &&TAG1(OP_SLOT_REF), &&TAG2(OP_SLOT_REF), # define SLOT_SET_TAGS \ &&TAG0(OP_SLOT_SET), &&TAG0(OP_SLOT_SET), &&TAG0(OP_SLOT_SET), &&TAG0(OP_SLOT_SET), \ &&TAG0(OP_SLOT_SET), &&TAG0(OP_SLOT_SET), &&TAG1(OP_SLOT_SET), &&TAG2(OP_SLOT_SET), # define REFN_TAGS \ &&TAG0(OP_REFN), &&TAG0(OP_REFN), &&TAG0(OP_REFN), &&TAG0(OP_REFN), \ &&TAG0(OP_REFN), &&TAG0(OP_REFN), &&TAG1(OP_REFN), &&TAG2(OP_REFN), # else # define SLOT_REF_TAGS \ &&TAG(OP_SLOT_REF_0), &&TAG(OP_SLOT_REF_1), &&TAG(OP_SLOT_REF_2), &&TAG(OP_SLOT_REF_3), \ &&TAG(OP_SLOT_REF_4), &&TAG(OP_SLOT_REF_5), &&TAG(OP_SLOT_REF_6), &&TAG(OP_SLOT_REF_7), # define SLOT_SET_TAGS \ &&TAG(OP_SLOT_SET_0), &&TAG(OP_SLOT_SET_1), &&TAG(OP_SLOT_SET_2), &&TAG(OP_SLOT_SET_3), \ &&TAG(OP_SLOT_SET_4), &&TAG(OP_SLOT_SET_5), &&TAG(OP_SLOT_SET_6), &&TAG(OP_SLOT_SET_7), # define REFN_TAGS \ &&TAG(OP_REFN_0), &&TAG(OP_REFN_1), &&TAG(OP_REFN_2), &&TAG(OP_REFN_3), \ &&TAG(OP_REFN_4), &&TAG(OP_REFN_5), &&TAG(OP_REFN_6), &&TAG(OP_REFN_7), # endif # define JUMP_TABLE \ SLOT_REF_TAGS /* 00 */ \ &&TAG0(OP_CALL), &&TAG0(OP_CALL), &&TAG0(OP_CALL), &&TAG0(OP_CALL), /*08*/ \ &&TAG0(OP_CALL), &&TAG0(OP_CALL), &&TAG1(OP_CALL), &&TAG2(OP_CALL), \ &&TAG0(OP_PUSH), &&TAG0(OP_PUSH), &&TAG0(OP_PUSH), &&TAG0(OP_PUSH), /*10*/ \ &&TAG0(OP_PUSH), &&TAG0(OP_PUSH), &&TAG1(OP_PUSH), &&TAG2(OP_PUSH), \ &&TAG0(OP_REFG), &&TAG0(OP_REFG), &&TAG0(OP_REFG), &&TAG0(OP_REFG), /*18*/ \ &&TAG0(OP_REFG), &&TAG0(OP_REFG), &&TAG1(OP_REFG), &&TAG2(OP_REFG), \ &&TAG0(OP_SETG), &&TAG0(OP_SETG), &&TAG0(OP_SETG), &&TAG0(OP_SETG), /*20*/ \ &&TAG0(OP_SETG), &&TAG0(OP_SETG), &&TAG1(OP_SETG), &&TAG2(OP_SETG), \ &&TAG0(OP_SETN), &&TAG0(OP_SETN), &&TAG0(OP_SETN), &&TAG0(OP_SETN), /*28*/ \ &&TAG0(OP_SETN), &&TAG0(OP_SETN), &&TAG1(OP_SETN), &&TAG2(OP_SETN), \ SLOT_SET_TAGS /* 30 */ \ REFN_TAGS /* 38 */ \ \ &&TAG(OP_REF), &&TAG(OP__SET), &&TAG(OP_FLUID_REF), &&TAG(OP_ENCLOSE), /*40*/ \ &&TAG(OP_INIT_BIND), &&TAG(OP_UNBIND), &&TAG(OP_DUP), &&TAG(OP_SWAP), \ &&TAG(OP_POP), &&TAG(OP_NIL), &&TAG(OP_T), &&TAG(OP_CONS), /*48*/ \ &&TAG(OP_CAR), &&TAG(OP_CDR), &&TAG(OP_RPLACA), &&TAG(OP_RPLACD), \ &&TAG(OP_NTH), &&TAG(OP_NTHCDR), &&TAG(OP_ASET), &&TAG(OP_AREF), /*50*/ \ &&TAG(OP_LENGTH), &&TAG(OP_BIND), &&TAG(OP_ADD), &&TAG(OP_NEG), \ &&TAG(OP_SUB), &&TAG(OP_MUL), &&TAG(OP_DIV), &&TAG(OP_REM), /*58*/ \ &&TAG(OP_LNOT), &&TAG(OP_NOT), &&TAG(OP_LOR), &&TAG(OP_LAND), \ \ &&TAG(OP_EQUAL), &&TAG(OP_EQ), &&TAG(OP_STRUCT_REF), &&TAG(OP_SCM_TEST), /*60*/ \ &&TAG(OP_GT), &&TAG(OP_GE), &&TAG(OP_LT), &&TAG(OP_LE), \ &&TAG(OP_INC), &&TAG(OP_DEC), &&TAG(OP_ASH), &&TAG(OP_ZEROP), /*68*/ \ &&TAG(OP_NULL), &&TAG(OP_ATOM), &&TAG(OP_CONSP), &&TAG(OP_LISTP), \ \ &&TAG(OP_NUMBERP), &&TAG(OP_STRINGP), &&TAG(OP_VECTORP), &&TAG(OP_CATCH), /*70*/ \ &&TAG(OP_THROW), &&TAG(OP_BINDERR), &&TAG(OP_RETURN), &&TAG(OP_UNBINDALL), \ &&TAG(OP_BOUNDP), &&TAG(OP_SYMBOLP), &&TAG(OP_GET), &&TAG(OP_PUT), /*78*/ \ &&TAG(OP_ERRORPRO), &&TAG(OP_SIGNAL), &&TAG(OP_QUOTIENT), &&TAG(OP_REVERSE), \ \ &&TAG(OP_NREVERSE), &&TAG(OP_ASSOC), &&TAG(OP_ASSQ), &&TAG(OP_RASSOC), /*80*/ \ &&TAG(OP_RASSQ), &&TAG(OP_LAST), &&TAG(OP_MAPCAR), &&TAG(OP_MAPC), \ &&TAG(OP_MEMBER), &&TAG(OP_MEMQ), &&TAG(OP_DELETE), &&TAG(OP_DELQ), /*88*/ \ &&TAG(OP_DELETE_IF), &&TAG(OP_DELETE_IF_NOT), &&TAG(OP_COPY_SEQUENCE), &&TAG(OP_SEQUENCEP), \ \ &&TAG(OP_FUNCTIONP), &&TAG(OP_SPECIAL_FORM_P), &&TAG(OP_SUBRP), &&TAG(OP_EQL), /*90*/ \ &&TAG(OP_LXOR), &&TAG(OP_MAX), &&TAG(OP_MIN), &&TAG(OP_FILTER), \ &&TAG(OP_MACROP), &&TAG(OP_BYTECODEP), &&TAG(OP_PUSHI0), &&TAG(OP_PUSHI1), /*98*/ \ &&TAG(OP_PUSHI2), &&TAG(OP_PUSHIM1), &&TAG(OP_PUSHIM2), &&TAG(OP_PUSHI), \ \ &&TAG(OP_PUSHIWN), &&TAG(OP_PUSHIWP), &&TAG(OP_CAAR), &&TAG(OP_CADR), /*A0*/ \ &&TAG(OP_CDAR), &&TAG(OP_CDDR), &&TAG(OP_CADDR), &&TAG(OP_CADDDR), \ &&TAG(OP_CADDDDR), &&TAG(OP_CADDDDDR), &&TAG(OP_CADDDDDDR), &&TAG(OP_CADDDDDDDR), /*A8*/ \ &&TAG(OP_FLOOR), &&TAG(OP_CEILING), &&TAG(OP_TRUNCATE), &&TAG(OP_ROUND), \ \ &&TAG(OP_APPLY), &&TAG(OP_FORBID), &&TAG(OP_PERMIT), &&TAG(OP_EXP), /*B0*/ \ &&TAG(OP_LOG), &&TAG(OP_SIN), &&TAG(OP_COS), &&TAG(OP_TAN), \ &&TAG(OP_SQRT), &&TAG(OP_EXPT), &&TAG(OP_SWAP2), &&TAG(OP_MOD), /*B8*/ \ &&TAG(OP_MAKE_CLOSURE), &&TAG(OP_UNBINDALL_0), &&TAG(OP_CLOSUREP), &&TAG(OP_POP_ALL), \ \ &&TAG(OP_FLUID_SET), &&TAG(OP_FLUID_BIND), &&TAG(OP_MEMQL), &&TAG(OP_NUM_EQ), /*C0*/ \ &&TAG(OP_TEST_SCM), &&TAG(OP_TEST_SCM_F), &&TAG(OP__DEFINE), &&TAG(OP_SPEC_BIND), \ &&TAG(OP_SET), &&TAG(OP_REQUIRED_ARG), &&TAG(OP_OPTIONAL_ARG), &&TAG(OP_REST_ARG), /*C8*/ \ &&TAG(OP_NOT_ZERO_P), &&TAG(OP_KEYWORD_ARG), &&TAG(OP_OPTIONAL_ARG_), &&TAG(OP_KEYWORD_ARG_), \ \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, /*D0*/ \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, /*D8*/ \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, /*E0*/ \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, /*E8*/ \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, \ \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, /*F0*/ \ &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, &&TAG_DEFAULT, \ \ &&TAG(OP_EJMP), &&TAG(OP_JPN), &&TAG(OP_JPT), &&TAG(OP_JMP), /*F8*/ \ &&TAG(OP_JN), &&TAG(OP_JT), &&TAG(OP_JNP), &&TAG(OP_JTP) #endif /* THREADED_VM */ /* Register optimization. [ stolen from ocaml-3.00/byterun/interp.c ] Some compilers underestimate the use of the local variables representing the abstract machine registers, and don't put them in hardware registers, which slows down the interpreter considerably. For GCC, I have hand-assigned hardware registers for several architectures. */ #ifdef __GNUC__ #ifdef __mips__ #define PC_REG asm("$16") #define SP_REG asm("$17") #define SLOTS_REG asm("$18") #endif #ifdef __sparc__ #define PC_REG asm("%l0") #define SP_REG asm("%l1") #define SLOTS_REG asm("%l2") #endif #ifdef __alpha__ #ifdef __CRAY__ #define PC_REG asm("r9") #define SP_REG asm("r10") #define SLOTS_REG asm("r11") #else #define PC_REG asm("$9") #define SP_REG asm("$10") #define SLOTS_REG asm("$11") #endif #endif #ifdef __i386__ #define PC_REG asm("%esi") #define SP_REG asm("%edi") #endif #if defined(PPC) || defined(_POWER) || defined(_IBMR2) #define PC_REG asm("26") #define SP_REG asm("27") #define SLOTS_REG asm("28") #endif #if defined (__ppc__) || defined (__powerpc__) #define PC_REG asm("r26") #define SP_REG asm("r27") #define SLOTS_REG asm("r28") #endif #ifdef __hppa__ #define PC_REG asm("%r18") #define SP_REG asm("%r17") #define SLOTS_REG asm("%r16") #endif #if 0 /* this seems to be broken */ #ifdef __mc68000__ #define PC_REG asm("a5") #define SP_REG asm("a4") #endif #endif #ifdef __arm__ #define PC_REG asm("r9") #define SP_REG asm("r8") #define SLOTS_REG asm("r7") #endif #endif #ifndef PC_REG #define PC_REG #endif #ifndef SP_REG #define SP_REG #endif #ifndef BP_REG #define BP_REG #endif #ifndef SLOTS_REG #define SLOTS_REG #endif #ifndef CFA_REG #define CFA_REG #endif #ifndef TOS_REG #define TOS_REG #endif DEFSTRING(max_depth, "max-lisp-depth exceeded, possible infinite recursion?"); static inline repv inline_apply_bytecode (repv subr, int nargs, repv *args) { return vm (rep_COMPILED_CODE (subr), rep_COMPILED_CONSTANTS (subr), nargs, args, rep_INT (rep_COMPILED_STACK (subr)) & 0x3ff, (rep_INT (rep_COMPILED_STACK (subr)) >> 10) & 0x3ff, rep_INT (rep_COMPILED_STACK (subr) >> 20)); } static repv vm (repv code, repv consts, int argc, repv *argv, int v_stkreq, int b_stkreq, int s_stkreq) { rep_GC_root gc_code, gc_consts; /* The `gcv_N' field is only filled in with the stack-size when there's a chance of gc. */ rep_GC_n_roots gc_stack, gc_bindstack, gc_slots, gc_argv; repv *stack, *bindstack, *slots; /* Actual reusable size of the argv array. I did try reusing the passed in argv, but that caused stack corruption in some cases.. */ repv *argv_base = 0; int argv_size = 0; /* this is the number of dynamic `bindings' in effect (including non-variable bindings). */ int impurity; if(++rep_lisp_depth > rep_max_lisp_depth) { rep_lisp_depth--; return Fsignal(Qerror, rep_LIST_1(rep_VAL(&max_depth))); } /* When tail-calling we'll only allocate a new stack if the current is too small. (this guarantees bounded space requirements) */ stack = alloca (sizeof (repv) * (v_stkreq + 1)); bindstack = alloca (sizeof (repv) * (b_stkreq + 1)); slots = alloca (sizeof (repv) * (s_stkreq)); repv_bzero (slots, s_stkreq); #ifdef SLOW_GC_PROTECT rep_PUSHGC(gc_code, code); rep_PUSHGC(gc_consts, consts); rep_PUSHGCN(gc_bindstack, bindstack, 0); rep_PUSHGCN(gc_stack, stack + 1, 0); rep_PUSHGCN(gc_slots, slots, s_stkreq); rep_PUSHGCN(gc_argv, argv, argc); #else /* avoid multiple accesses to global variables [ this ordering is known by popping code at end of fn ] */ gc_code.ptr = &code; gc_consts.ptr = &consts; gc_bindstack.first= bindstack; gc_stack.first = stack + 1; gc_slots.first = slots; gc_slots.count = s_stkreq; gc_argv.first = argv; gc_argv.count = argc; gc_code.next = &gc_consts; gc_consts.next = rep_gc_root_stack; rep_gc_root_stack = &gc_code; gc_bindstack.next = &gc_stack; gc_stack.next = &gc_slots; gc_slots.next = &gc_argv; gc_argv.next = rep_gc_n_roots_stack; rep_gc_n_roots_stack = &gc_bindstack; #endif /* Jump to this label when tail-calling */ again: { register unsigned char *pc PC_REG; register repv *stackp SP_REG; register repv *bindp BP_REG; register repv *slotp SLOTS_REG; #ifdef CACHE_TOS register repv tos TOS_REG; #endif int argptr = 0; /* Make sure that even when the stack has no entries, the TOP element still != 0 (for the error-detection at label quit:) */ stack[0] = Qt; /* Always start with a null frame. Functions will add their args */ bindstack[0] = rep_NEW_FRAME; /* Initialize the various virtual registers */ stackp = stack; RELOAD; bindp = bindstack; slotp = slots; impurity = 0; pc = (unsigned char *) rep_STR(code); /* Start of the VM fetch-execute sequence. */ { #ifdef THREADED_VM static void *cfa__[256] = { JUMP_TABLE }; register void **cfa CFA_REG = cfa__; #endif unsigned int arg; repv tmp, tmp2; BEGIN_DISPATCH BEGIN_INSN_WITH_ARG (OP_CALL) struct rep_Call lc; rep_bool was_closed; /* args are still available above the top of the stack, this just makes things a bit easier. */ UPDATE; POPN(arg); tmp = TOP; lc.fun = tmp; lc.args = rep_void_value; rep_PUSH_CALL (lc); SYNC_GC; was_closed = rep_FALSE; if (rep_FUNARGP(tmp)) { rep_USE_FUNARG(tmp); tmp = rep_FUNARG(tmp)->fun; was_closed = rep_TRUE; } if (!rep_CELLP (tmp)) goto invalid; if (rep_CELL8P (tmp)) { switch (rep_CELL8_TYPE (tmp)) { case rep_Subr0: TOP = rep_SUBR0FUN(tmp)(); break; case rep_Subr1: TOP = rep_SUBR1FUN(tmp)(arg >= 1 ? stackp[1] : Qnil); break; case rep_Subr2: switch(arg) { case 0: TOP = rep_SUBR2FUN(tmp)(Qnil, Qnil); break; case 1: TOP = rep_SUBR2FUN(tmp)(stackp[1], Qnil); break; default: TOP = rep_SUBR2FUN(tmp)(stackp[1], stackp[2]); break; } break; case rep_Subr3: switch(arg) { case 0: TOP = rep_SUBR3FUN(tmp)(Qnil, Qnil, Qnil); break; case 1: TOP = rep_SUBR3FUN(tmp)(stackp[1], Qnil, Qnil); break; case 2: TOP = rep_SUBR3FUN(tmp)(stackp[1], stackp[2], Qnil); break; default: TOP = rep_SUBR3FUN(tmp)(stackp[1], stackp[2], stackp[3]); break; } break; case rep_Subr4: switch(arg) { case 0: TOP = rep_SUBR4FUN(tmp)(Qnil, Qnil, Qnil, Qnil); break; case 1: TOP = rep_SUBR4FUN(tmp)(stackp[1], Qnil, Qnil, Qnil); break; case 2: TOP = rep_SUBR4FUN(tmp)(stackp[1], stackp[2], Qnil, Qnil); break; case 3: TOP = rep_SUBR4FUN(tmp)(stackp[1], stackp[2], stackp[3], Qnil); break; default: TOP = rep_SUBR4FUN(tmp)(stackp[1], stackp[2], stackp[3], stackp[4]); break; } break; case rep_Subr5: switch(arg) { case 0: TOP = rep_SUBR5FUN(tmp)(Qnil, Qnil, Qnil, Qnil, Qnil); break; case 1: TOP = rep_SUBR5FUN(tmp)(stackp[1], Qnil, Qnil, Qnil, Qnil); break; case 2: TOP = rep_SUBR5FUN(tmp)(stackp[1], stackp[2], Qnil, Qnil, Qnil); break; case 3: TOP = rep_SUBR5FUN(tmp)(stackp[1], stackp[2], stackp[3], Qnil, Qnil); break; case 4: TOP = rep_SUBR5FUN(tmp)(stackp[1], stackp[2], stackp[3], stackp[4], Qnil); break; default: TOP = rep_SUBR5FUN(tmp)(stackp[1], stackp[2], stackp[3], stackp[4], stackp[5]); break; } break; case rep_SubrN: if (rep_SUBR_VEC_P (tmp)) { TOP = rep_SUBRVFUN (tmp) (arg, stackp + 1); } else { tmp2 = Qnil; POPN(- ((int) arg)); /* reclaim my args */ while(arg-- != 0) { repv x; POP1 (x); tmp2 = inline_Fcons(x, tmp2); } lc.args = tmp2; TOP = rep_SUBRNFUN(tmp)(tmp2); } break; case rep_Compiled: if (was_closed) { repv (*bc_apply) (repv, int, repv *); bc_apply = rep_STRUCTURE (rep_structure)->apply_bytecode; if (bc_apply == BC_APPLY_SELF) /* calling self */ { if (impurity != 0 || *pc != OP_RETURN) { TOP = inline_apply_bytecode (tmp, arg, stackp+1); } else { /* A tail call that's safe for eliminating */ int n_req_v, n_req_b, n_req_s; /* snap the call stack when tail calling */ rep_call_stack = lc.next; rep_call_stack->fun = lc.fun; rep_call_stack->args = lc.args; /* since impurity==0 there can only be lexical bindings; these were unbound when switching environments.. */ /* Arguments for the function call */ argv = stackp + 1; argc = arg; /* Switch old argv and stack, or reallocate? */ n_req_v = rep_INT (rep_COMPILED_STACK (tmp)) & 0x3ff; if (argv_size >= n_req_v) { /* argv is big enough to be new stack */ repv *tem_stack = stack; int tem_size = v_stkreq; stack = argv_base; v_stkreq = argv_size; argv_base = tem_stack; argv_size = tem_size; } else { argv_base = stack; argv_size = v_stkreq; stack = alloca (sizeof (repv) * (n_req_v+1)); v_stkreq = n_req_v; } /* inputs: tmp=bytecode-subr */ do_tail_recursion: /* Allocate new bind-stack? */ n_req_b = (rep_INT (rep_COMPILED_STACK (tmp)) >> 10) & 0x3ff; if (b_stkreq < n_req_b) { bindstack = alloca (sizeof (repv) * (n_req_b+1)); b_stkreq = n_req_b; } /* Allocate new slots? */ n_req_s = rep_INT (rep_COMPILED_STACK (tmp)) >> 20; if (s_stkreq < n_req_s) { slots = alloca (sizeof (repv) * n_req_s); s_stkreq = n_req_s; repv_bzero (slots, s_stkreq); } code = rep_COMPILED_CODE (tmp); consts = rep_COMPILED_CONSTANTS (tmp); gc_bindstack.first = bindstack; gc_stack.first = stack + 1; gc_slots.first = slots; gc_slots.count = s_stkreq; gc_argv.first = argv; gc_argv.count = argc; goto again; } } else { TOP = bc_apply (tmp, arg, stackp+1); } } else goto invalid; break; default: invalid: TOP = Fsignal(Qinvalid_function, rep_LIST_1(TOP)); } } else /* !consp */ { /* a call to intepreted code, just cons up the args and send it to the interpreter.. */ POPN(- ((int) arg)); for (tmp2 = Qnil; arg-- > 0;) { repv x; POP1 (x); tmp2 = Fcons (x, tmp2); } rep_POP_CALL (lc); TOP = rep_funcall(TOP, tmp2, rep_FALSE); NEXT; } rep_POP_CALL(lc); INLINE_NEXT; END_INSN BEGIN_INSN_WITH_ARG (OP_PUSH) ASSERT (arg < rep_VECT_LEN (consts)); PUSH(rep_VECT(consts)->array[arg]); SAFE_NEXT; END_INSN BEGIN_INSN (OP_BIND) POP1 (tmp2); rep_env = inline_Fcons (tmp2, rep_env); BIND_TOP = rep_MARK_LEX_BINDING (BIND_TOP); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SPEC_BIND) POP2 (tmp, tmp2); impurity++; BIND_TOP = rep_bind_special (BIND_TOP, tmp, tmp2); if (rep_throw_value != rep_NULL) HANDLE_ERROR; NEXT; END_INSN #ifdef OPTIMIZE_FOR_SPACE BEGIN_INSN_WITH_ARG (OP_REFN) ASSERT (rep_list_length (rep_env) > arg); PUSH (rep_CAR (snap_environment (arg))); SAFE_NEXT; END_INSN #else BEGIN_INSN (OP_REFN_0) ASSERT (rep_list_length (rep_env) > 0); PUSH (rep_CAR (rep_env)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_REFN_1) ASSERT (rep_list_length (rep_env) > 1); PUSH (rep_CADR (rep_env)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_REFN_2) ASSERT (rep_list_length (rep_env) > 2); PUSH (rep_CADDR (rep_env)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_REFN_3) ASSERT (rep_list_length (rep_env) > 3); PUSH (rep_CADDDR (rep_env)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_REFN_4) ASSERT (rep_list_length (rep_env) > 4); PUSH (rep_CAR (rep_CDDDDR (rep_env))); SAFE_NEXT; END_INSN BEGIN_INSN (OP_REFN_5) ASSERT (rep_list_length (rep_env) > 5); PUSH (rep_CADR (rep_CDDDDR (rep_env))); SAFE_NEXT; END_INSN BEGIN_INSN (OP_REFN_6) arg = FETCH; ASSERT (rep_list_length (rep_env) > arg); PUSH (rep_CAR (snap_environment (arg))); SAFE_NEXT; END_INSN BEGIN_INSN (OP_REFN_7) FETCH2 (arg); ASSERT (rep_list_length (rep_env) > arg); PUSH (rep_CAR (snap_environment (arg))); SAFE_NEXT; END_INSN #endif /* !OPTIMIZE_FOR_SPACE */ BEGIN_INSN_WITH_ARG (OP_SETN) ASSERT (rep_list_length (rep_env) > arg); POP1 (tmp); rep_CAR (snap_environment (arg)) = tmp; SAFE_NEXT; END_INSN BEGIN_INSN_WITH_ARG (OP_REFG) /* this code expanded from F_structure_ref () and lookup () in structures.c */ rep_struct *s = rep_STRUCTURE (rep_structure); rep_struct_node *n; repv var; ASSERT (arg < rep_VECT_LEN (consts)); var = rep_VECT(consts)->array[arg]; if (s->total_buckets != 0) { for (n = s->buckets[rep_STRUCT_HASH (var, s->total_buckets)]; n != 0; n = n->next) { if (n->symbol == var) { PUSH (n->binding); SAFE_NEXT; } } } n = rep_search_imports (s, var); if (n != 0) { PUSH (n->binding); SAFE_NEXT; } Fsignal (Qvoid_value, rep_LIST_1 (var)); HANDLE_ERROR; END_INSN BEGIN_INSN_WITH_ARG (OP_SETG) ASSERT (arg < rep_VECT_LEN (consts)); tmp = rep_VECT(consts)->array[arg]; POP1 (tmp2); Fstructure_set (rep_structure, tmp, tmp2); SAFE_NEXT; END_INSN #ifdef OPTIMIZE_FOR_SPACE BEGIN_INSN_WITH_ARG (OP_SLOT_REF) ASSERT (s_stkreq > arg); tmp = slotp[arg]; PUSH (tmp); ASSERT (TOP != 0); SAFE_NEXT; END_INSN #else BEGIN_INSN (OP_SLOT_REF_0) ASSERT (s_stkreq > 0); PUSH (slotp[0]); ASSERT (TOP != 0); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_REF_1) ASSERT (s_stkreq > 1); PUSH (slotp[1]); ASSERT (TOP != 0); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_REF_2) ASSERT (s_stkreq > 2); PUSH (slotp[2]); ASSERT (TOP != 0); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_REF_3) ASSERT (s_stkreq > 3); PUSH (slotp[3]); ASSERT (TOP != 0); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_REF_4) ASSERT (s_stkreq > 4); PUSH (slotp[4]); ASSERT (TOP != 0); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_REF_5) ASSERT (s_stkreq > 5); PUSH (slotp[5]); ASSERT (TOP != 0); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_REF_6) arg = FETCH; ASSERT (s_stkreq > arg); tmp = slotp[arg]; PUSH (tmp); ASSERT (TOP != 0); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_REF_7) FETCH2 (arg); ASSERT (s_stkreq > arg); tmp = slotp[arg]; PUSH (tmp); ASSERT (TOP != 0); SAFE_NEXT; END_INSN #endif /* !OPTIMIZE_FOR_SPACE */ #ifdef OPTIMIZE_FOR_SPACE BEGIN_INSN_WITH_ARG (OP_SLOT_SET) ASSERT (s_stkreq > arg); POP1 (slotp[arg]); SAFE_NEXT; END_INSN #else BEGIN_INSN (OP_SLOT_SET_0) ASSERT (s_stkreq > 0); POP1 (slotp[0]); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_SET_1) ASSERT (s_stkreq > 1); POP1 (slotp[1]); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_SET_2) ASSERT (s_stkreq > 2); POP1 (slotp[2]); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_SET_3) ASSERT (s_stkreq > 3); POP1 (slotp[3]); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_SET_4) ASSERT (s_stkreq > 4); POP1 (slotp[4]); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_SET_5) ASSERT (s_stkreq > 5); POP1 (slotp[5]); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_SET_6) arg = FETCH; ASSERT (s_stkreq > arg); POP1 (slotp[arg]); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SLOT_SET_7) FETCH2 (arg); ASSERT (s_stkreq > arg); POP1 (slotp[arg]); SAFE_NEXT; END_INSN #endif /* !OPTIMIZE_FOR_SPACE */ BEGIN_INSN (OP_REF) TOP = Fsymbol_value(TOP, Qnil); NEXT; END_INSN BEGIN_INSN (OP__SET) POP2 (tmp, tmp2); Freal_set (tmp, tmp2); NEXT; END_INSN BEGIN_INSN (OP_FLUID_REF) tmp = search_special_bindings (TOP); if (tmp != Qnil) { TOP = rep_CDR (tmp); SAFE_NEXT; } else if (rep_CONSP (TOP)) { TOP = rep_CDR (TOP); SAFE_NEXT; } Fsignal (Qvoid_value, rep_LIST_1 (TOP)); HANDLE_ERROR; END_INSN BEGIN_INSN (OP_ENCLOSE) TOP = Fmake_closure (TOP, Qnil); INLINE_NEXT; END_INSN BEGIN_INSN (OP_INIT_BIND) BIND_PUSH (rep_NEW_FRAME); SAFE_NEXT; END_INSN BEGIN_INSN (OP_UNBIND) impurity -= inline_unbind(BIND_RET_POP); SAFE_NEXT; END_INSN BEGIN_INSN (OP_DUP) tmp = TOP; PUSH(tmp); SAFE_NEXT; END_INSN BEGIN_INSN (OP_SWAP) tmp = TOP; TOP = stackp[-1]; stackp[-1] = tmp; SAFE_NEXT; END_INSN BEGIN_INSN (OP_POP) POP; SAFE_NEXT; END_INSN BEGIN_INSN (OP_NIL) PUSH(Qnil); SAFE_NEXT; END_INSN BEGIN_INSN (OP_T) PUSH(Qt); SAFE_NEXT; END_INSN BEGIN_INSN (OP_CONS) CALL_2(inline_Fcons); END_INSN BEGIN_INSN (OP_CAR) tmp = TOP; if(rep_CONSP(tmp)) TOP = rep_CAR(tmp); else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_CDR) tmp = TOP; if(rep_CONSP(tmp)) TOP = rep_CDR(tmp); else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_RPLACA) CALL_2(Frplaca); END_INSN BEGIN_INSN (OP_RPLACD) CALL_2(Frplacd); END_INSN BEGIN_INSN (OP_NTH) CALL_2(Fnth); END_INSN BEGIN_INSN (OP_NTHCDR) CALL_2(Fnthcdr); END_INSN BEGIN_INSN (OP_ASET) CALL_3(Faset); END_INSN BEGIN_INSN (OP_AREF) CALL_2(Faref); END_INSN BEGIN_INSN (OP_LENGTH) CALL_1(Flength); END_INSN BEGIN_INSN (OP_ADD) /* open-code fixnum arithmetic */ POP1 (tmp); tmp2 = TOP; if (rep_INTP (tmp) && rep_INTP (tmp2)) { long x = rep_INT (tmp2) + rep_INT (tmp); if (x >= rep_LISP_MIN_INT && x <= rep_LISP_MAX_INT) { TOP = rep_MAKE_INT (x); SAFE_NEXT; } } TOP = rep_number_add (tmp2, tmp); INLINE_NEXT; END_INSN BEGIN_INSN (OP_NEG) /* open-code fixnum arithmetic */ tmp = TOP; if (rep_INTP (tmp)) { long x = - rep_INT (tmp); if (x >= rep_LISP_MIN_INT && x <= rep_LISP_MAX_INT) { TOP = rep_MAKE_INT (x); SAFE_NEXT; } } TOP = rep_number_neg (tmp); INLINE_NEXT; END_INSN BEGIN_INSN (OP_SUB) /* open-code fixnum arithmetic */ POP1 (tmp); tmp2 = TOP; if (rep_INTP (tmp) && rep_INTP (tmp2)) { long x = rep_INT (tmp2) - rep_INT (tmp); if (x >= rep_LISP_MIN_INT && x <= rep_LISP_MAX_INT) { TOP = rep_MAKE_INT (x); SAFE_NEXT; } } TOP = rep_number_sub (tmp2, tmp); INLINE_NEXT; END_INSN BEGIN_INSN (OP_MUL) CALL_2(rep_number_mul); END_INSN BEGIN_INSN (OP_DIV) CALL_2(rep_number_div); END_INSN BEGIN_INSN (OP_REM) CALL_2(Fremainder); END_INSN BEGIN_INSN (OP_LNOT) CALL_1(Flognot); END_INSN BEGIN_INSN (OP_NOT) if(TOP == Qnil) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_NULL) if(TOP == Qnil) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_LOR) CALL_2(rep_number_logior); END_INSN BEGIN_INSN (OP_LXOR) CALL_2(rep_number_logxor); END_INSN BEGIN_INSN (OP_LAND) CALL_2(rep_number_logand); END_INSN BEGIN_INSN (OP_EQUAL) POP1 (tmp); TOP = (rep_value_cmp(TOP, tmp) == 0) ? Qt : Qnil; NEXT; END_INSN BEGIN_INSN (OP_EQ) POP1 (tmp); TOP = (TOP == tmp) ? Qt : Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_STRUCT_REF) CALL_2 (Fexternal_structure_ref); END_INSN BEGIN_INSN (OP_SCM_TEST) TOP = (TOP == rep_scm_f) ? Qnil : Qt; SAFE_NEXT; END_INSN BEGIN_INSN (OP_GT) POP1 (tmp); tmp2 = TOP; if (rep_INTP (tmp2) && rep_INTP (tmp)) { TOP = (rep_INT (tmp2) > rep_INT (tmp)) ? Qt : Qnil; SAFE_NEXT; } else if (rep_NUMBERP (tmp2) || rep_NUMBERP (tmp)) { TOP = (rep_compare_numbers (tmp2, tmp) > 0) ? Qt : Qnil; SAFE_NEXT; } else { TOP = (rep_value_cmp (tmp2, tmp) > 0) ? Qt : Qnil; NEXT; } END_INSN BEGIN_INSN (OP_GE) POP1 (tmp); tmp2 = TOP; if (rep_INTP (tmp2) && rep_INTP (tmp)) { TOP = (rep_INT (tmp2) >= rep_INT (tmp)) ? Qt : Qnil; SAFE_NEXT; } else if (rep_NUMBERP (tmp2) || rep_NUMBERP (tmp)) { TOP = (rep_compare_numbers (tmp2, tmp) >= 0) ? Qt : Qnil; SAFE_NEXT; } else { TOP = (rep_value_cmp (tmp2, tmp) >= 0) ? Qt : Qnil; NEXT; } END_INSN BEGIN_INSN (OP_LT) POP1 (tmp); tmp2 = TOP; if (rep_INTP (tmp2) && rep_INTP (tmp)) { TOP = (rep_INT (tmp2) < rep_INT (tmp)) ? Qt : Qnil; SAFE_NEXT; } else if (rep_NUMBERP (tmp2) || rep_NUMBERP (tmp)) { TOP = (rep_compare_numbers (tmp2, tmp) < 0) ? Qt : Qnil; SAFE_NEXT; } else { TOP = (rep_value_cmp (tmp2, tmp) < 0) ? Qt : Qnil; NEXT; } END_INSN BEGIN_INSN (OP_LE) POP1 (tmp); tmp2 = TOP; if (rep_INTP (tmp2) && rep_INTP (tmp)) { TOP = (rep_INT (tmp2) <= rep_INT (tmp)) ? Qt : Qnil; SAFE_NEXT; } else if (rep_NUMBERP (tmp2) || rep_NUMBERP (tmp)) { TOP = (rep_compare_numbers (tmp2, tmp) <= 0) ? Qt : Qnil; SAFE_NEXT; } else { TOP = (rep_value_cmp (tmp2, tmp) <= 0) ? Qt : Qnil; NEXT; } END_INSN BEGIN_INSN (OP_INC) tmp = TOP; if (rep_INTP (tmp)) { long x = rep_INT (tmp) + 1; if (x <= rep_LISP_MAX_INT) { TOP = rep_MAKE_INT (x); SAFE_NEXT; } } TOP = Fplus1 (tmp); NEXT; END_INSN BEGIN_INSN (OP_DEC) tmp = TOP; if (rep_INTP (tmp)) { long x = rep_INT (tmp) - 1; if (x >= rep_LISP_MIN_INT) { TOP = rep_MAKE_INT (x); SAFE_NEXT; } } TOP = Fsub1 (tmp); NEXT; END_INSN BEGIN_INSN (OP_ASH) CALL_2(Fash); END_INSN BEGIN_INSN (OP_ZEROP) tmp = TOP; if (rep_INTP (tmp)) { TOP = (tmp == rep_MAKE_INT (0)) ? Qt : Qnil; SAFE_NEXT; } TOP = Fzerop (tmp); NEXT; END_INSN BEGIN_INSN (OP_NOT_ZERO_P) tmp = TOP; if (rep_INTP (tmp)) { TOP = (tmp != rep_MAKE_INT (0)) ? Qt : Qnil; SAFE_NEXT; } tmp = Fzerop (tmp); if (tmp != rep_NULL) tmp = (tmp == Qnil) ? Qt : Qnil; TOP = tmp; NEXT; END_INSN BEGIN_INSN (OP_ATOM) if(!rep_CONSP(TOP)) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_CONSP) if(rep_CONSP(TOP)) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_LISTP) if(rep_CONSP(TOP) || rep_NILP(TOP)) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_NUMBERP) if(rep_NUMERICP(TOP)) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_STRINGP) if(rep_STRINGP(TOP)) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_VECTORP) if(rep_VECTORP(TOP)) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_CATCH) /* This takes two arguments, TAG and THROW-VALUE. THROW-VALUE is the saved copy of rep_throw_value, if (car THROW-VALUE) == TAG we match, and we leave two values on the stack, nil on top (to pacify EJMP), (cdr THROW-VALUE) below that. */ POP1 (tmp); /* tag */ tmp2 = TOP; /* rep_throw_value */ if(rep_CONSP(tmp2) && rep_CAR(tmp2) == tmp) { TOP = rep_CDR(tmp2); /* leave result at stk[1] */ PUSH(Qnil); /* cancel error */ } SAFE_NEXT; END_INSN BEGIN_INSN (OP_THROW) POP1 (tmp); if(rep_throw_value == rep_NULL) { rep_throw_value = Fcons(TOP, tmp); HANDLE_ERROR; } SAFE_NEXT; END_INSN BEGIN_INSN (OP_BINDERR) /* Pop our single argument and cons it onto the bind- stack in a pair with the current stack-pointer. This installs an address in the code string as an error handler. */ POP1 (tmp); BIND_PUSH (Fcons (Qerror, Fcons (tmp, rep_MAKE_INT(STK_USE)))); impurity++; SAFE_NEXT; END_INSN BEGIN_INSN (OP_RETURN) unbind_n (bindstack, BIND_USE); RETURN; END_INSN BEGIN_INSN (OP_UNBINDALL) unbind_n (bindstack + 1, BIND_USE - 1); bindp = bindstack; impurity = rep_SPEC_BINDINGS (BIND_TOP); SAFE_NEXT; END_INSN BEGIN_INSN (OP_BOUNDP) CALL_1(Fboundp); END_INSN BEGIN_INSN (OP_SYMBOLP) if(rep_SYMBOLP(TOP)) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_GET) CALL_2(Fget); END_INSN BEGIN_INSN (OP_PUT) CALL_3(Fput); END_INSN BEGIN_INSN (OP_ERRORPRO) /* This should be called with two values on the stack. 1. conditions of the error handler 2. rep_throw_value of the exception This function pops (1) and tests it against the error in (2). If they match it sets (2) to nil, and binds the error data to the next lexical slot. */ POP1 (tmp); if(rep_CONSP(TOP) && rep_CAR(TOP) == Qerror && rep_compare_error(rep_CDR(TOP), tmp)) { /* The handler matches the error. */ tmp = rep_CDR(TOP); /* the error data */ rep_env = Fcons (tmp, rep_env); BIND_PUSH(rep_MARK_LEX_BINDING (rep_NEW_FRAME)); TOP = Qnil; } NEXT; END_INSN BEGIN_INSN (OP_SIGNAL) SYNC_GC; CALL_2(Fsignal); END_INSN BEGIN_INSN (OP_QUOTIENT) CALL_2(Fquotient); END_INSN BEGIN_INSN (OP_REVERSE) CALL_1(Freverse); END_INSN BEGIN_INSN (OP_NREVERSE) CALL_1(Fnreverse); END_INSN BEGIN_INSN (OP_ASSOC) CALL_2(Fassoc); END_INSN BEGIN_INSN (OP_ASSQ) CALL_2(Fassq); END_INSN BEGIN_INSN (OP_RASSOC) CALL_2(Frassoc); END_INSN BEGIN_INSN (OP_RASSQ) CALL_2(Frassq); END_INSN BEGIN_INSN (OP_LAST) CALL_1(Flast); END_INSN BEGIN_INSN (OP_MAPCAR) SYNC_GC; CALL_2(Fmapcar); END_INSN BEGIN_INSN (OP_MAPC) SYNC_GC; CALL_2(Fmapc); END_INSN BEGIN_INSN (OP_MEMBER) CALL_2(Fmember); END_INSN BEGIN_INSN (OP_MEMQ) CALL_2(Fmemq); END_INSN BEGIN_INSN (OP_DELETE) CALL_2(Fdelete); END_INSN BEGIN_INSN (OP_DELQ) CALL_2(Fdelq); END_INSN BEGIN_INSN (OP_DELETE_IF) SYNC_GC; CALL_2(Fdelete_if); END_INSN BEGIN_INSN (OP_DELETE_IF_NOT) SYNC_GC; CALL_2(Fdelete_if_not); END_INSN BEGIN_INSN (OP_COPY_SEQUENCE) CALL_1(Fcopy_sequence); END_INSN BEGIN_INSN (OP_SEQUENCEP) CALL_1(Fsequencep); END_INSN BEGIN_INSN (OP_FUNCTIONP) CALL_1(Ffunctionp); END_INSN BEGIN_INSN (OP_SPECIAL_FORM_P) CALL_1(Fspecial_form_p); END_INSN BEGIN_INSN (OP_SUBRP) CALL_1(Fsubrp); END_INSN BEGIN_INSN (OP_EQL) CALL_2(Feql); END_INSN BEGIN_INSN (OP_MAX) CALL_2(rep_number_max); END_INSN BEGIN_INSN (OP_MIN) CALL_2(rep_number_min); END_INSN BEGIN_INSN (OP_FILTER) SYNC_GC; CALL_2(Ffilter); END_INSN BEGIN_INSN (OP_MACROP) CALL_1(Fmacrop); END_INSN BEGIN_INSN (OP_BYTECODEP) CALL_1(Fbytecodep); END_INSN BEGIN_INSN (OP_PUSHI0) PUSH(rep_MAKE_INT(0)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_PUSHI1) PUSH(rep_MAKE_INT(1)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_PUSHI2) PUSH(rep_MAKE_INT(2)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_PUSHIM1) PUSH(rep_MAKE_INT(-1)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_PUSHIM2) PUSH(rep_MAKE_INT(-2)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_PUSHI) arg = FETCH; if (arg < 128) PUSH(rep_MAKE_INT(arg)); else PUSH(rep_MAKE_INT(((int) arg) - 256)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_PUSHIWN) FETCH2(arg); PUSH(rep_MAKE_INT(- ((int) arg))); SAFE_NEXT; END_INSN BEGIN_INSN (OP_PUSHIWP) FETCH2(arg); PUSH(rep_MAKE_INT(arg)); SAFE_NEXT; END_INSN BEGIN_INSN (OP_CAAR) tmp = TOP; if (rep_CONSP(tmp) && rep_CONSP(rep_CAR(tmp))) TOP = rep_CAAR(tmp); else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_CADR) tmp = TOP; if (rep_CONSP(tmp) && rep_CONSP(rep_CDR(tmp))) TOP = rep_CADR(tmp); else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_CDAR) tmp = TOP; if (rep_CONSP(tmp) && rep_CONSP(rep_CAR(tmp))) TOP = rep_CDAR(tmp); else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_CDDR) tmp = TOP; if (rep_CONSP(tmp) && rep_CONSP(rep_CDR(tmp))) TOP = rep_CDDR(tmp); else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_CADDR) TOP = list_ref (TOP, 2); SAFE_NEXT; END_INSN BEGIN_INSN (OP_CADDDR) TOP = list_ref (TOP, 3); SAFE_NEXT; END_INSN BEGIN_INSN (OP_CADDDDR) TOP = list_ref (TOP, 4); SAFE_NEXT; END_INSN BEGIN_INSN (OP_CADDDDDR) TOP = list_ref (TOP, 5); SAFE_NEXT; END_INSN BEGIN_INSN (OP_CADDDDDDR) TOP = list_ref (TOP, 6); SAFE_NEXT; END_INSN BEGIN_INSN (OP_CADDDDDDDR) TOP = list_ref (TOP, 7); SAFE_NEXT; END_INSN BEGIN_INSN (OP_FLOOR) CALL_1(Ffloor); END_INSN BEGIN_INSN (OP_CEILING) CALL_1(Fceiling); END_INSN BEGIN_INSN (OP_TRUNCATE) CALL_1(Ftruncate); END_INSN BEGIN_INSN (OP_ROUND) CALL_1(Fround); END_INSN BEGIN_INSN (OP_APPLY) repv args; POP1 (args); tmp = TOP; SYNC_GC; if (impurity == 0 && *pc == OP_RETURN && rep_FUNARGP (tmp) && rep_COMPILEDP (rep_FUNARG (tmp)->fun) && rep_STRUCTURE (rep_FUNARG (tmp)->structure)->apply_bytecode == 0) { /* a doable tail-call */ int nargs, i, n_req_v; rep_USE_FUNARG (tmp); tmp = rep_FUNARG (tmp)->fun; nargs = rep_list_length (args); if (nargs <= argv_size) argv = argv_base; else { /* Can't just copy over argv, reallocate */ argv = alloca (sizeof (repv) * nargs); argv_base = argv; argv_size = nargs; } for (i = 0; i < nargs; i++) { argv[i] = rep_CAR (args); args = rep_CDR (args); } argc = nargs; n_req_v = rep_INT (rep_COMPILED_STACK (tmp)) & 0x3ff; if (n_req_v > v_stkreq) { /* Reallocate stack */ stack = alloca (sizeof (repv) * (n_req_v+1)); v_stkreq = n_req_v; } goto do_tail_recursion; /* passes `tmp' */ } /* not a tail call */ TOP = rep_apply (tmp, args); NEXT; END_INSN BEGIN_INSN (OP_FORBID) rep_FORBID; PUSH (rep_PREEMPTABLE_P ? Qnil : Qt); SAFE_NEXT; END_INSN BEGIN_INSN (OP_PERMIT) rep_PERMIT; PUSH (rep_PREEMPTABLE_P ? Qnil : Qt); SAFE_NEXT; END_INSN BEGIN_INSN (OP_EXP) CALL_1(Fexp); END_INSN BEGIN_INSN (OP_LOG) CALL_1(Flog); END_INSN BEGIN_INSN (OP_COS) CALL_1(Fcos); END_INSN BEGIN_INSN (OP_SIN) CALL_1(Fsin); END_INSN BEGIN_INSN (OP_TAN) CALL_1(Ftan); END_INSN BEGIN_INSN (OP_SQRT) CALL_1(Fsqrt); END_INSN BEGIN_INSN (OP_EXPT) CALL_2(Fexpt); END_INSN BEGIN_INSN (OP_SWAP2) tmp = TOP; TOP = stackp[-1]; stackp[-1] = stackp[-2]; stackp[-2] = tmp; SAFE_NEXT; END_INSN BEGIN_INSN (OP_MOD) CALL_2(Fmod); END_INSN BEGIN_INSN (OP_MAKE_CLOSURE) CALL_2(Fmake_closure); END_INSN BEGIN_INSN (OP_UNBINDALL_0) unbind_n (bindstack, BIND_USE); bindp = bindstack - 1; impurity = 0; SAFE_NEXT; END_INSN BEGIN_INSN (OP_CLOSUREP) if(rep_FUNARGP(TOP)) TOP = Qt; else TOP = Qnil; SAFE_NEXT; END_INSN BEGIN_INSN (OP_POP_ALL) stackp = stack; RELOAD; SAFE_NEXT; END_INSN BEGIN_INSN (OP_FLUID_SET) CALL_2 (Ffluid_set); END_INSN BEGIN_INSN (OP_FLUID_BIND) POP2 (tmp, tmp2); rep_special_bindings = Fcons (Fcons (tmp2, tmp), rep_special_bindings); BIND_TOP = rep_MARK_SPEC_BINDING (BIND_TOP); impurity++; SAFE_NEXT; END_INSN BEGIN_INSN (OP_MEMQL) CALL_2(Fmemql); END_INSN BEGIN_INSN (OP_NUM_EQ) POP1 (tmp); tmp2 = TOP; if (rep_INTP (tmp) && rep_INTP (tmp2)) { TOP = (tmp2 == tmp) ? Qt : Qnil; SAFE_NEXT; } else if (rep_NUMBERP (tmp2) || rep_NUMBERP (tmp)) { TOP = (rep_compare_numbers (tmp2, tmp) == 0) ? Qt : Qnil; SAFE_NEXT; } else { TOP = (rep_value_cmp (tmp2, tmp) == 0) ? Qt : Qnil; NEXT; } END_INSN BEGIN_INSN (OP_TEST_SCM) TOP = (TOP == Qnil) ? rep_scm_f : rep_scm_t; SAFE_NEXT; END_INSN BEGIN_INSN (OP_TEST_SCM_F) if (TOP == Qnil) TOP = rep_scm_f; SAFE_NEXT; END_INSN BEGIN_INSN (OP__DEFINE) POP1 (tmp); TOP = Fstructure_define (rep_structure, TOP, tmp); NEXT; END_INSN BEGIN_INSN (OP_SET) CALL_2 (Freal_set); END_INSN BEGIN_INSN (OP_REQUIRED_ARG) if (argptr < argc) { PUSH (argv[argptr++]); SAFE_NEXT; } rep_signal_missing_arg (argptr + 1); HANDLE_ERROR; END_INSN BEGIN_INSN (OP_OPTIONAL_ARG) PUSH ((argptr < argc) ? argv[argptr++] : Qnil); SAFE_NEXT; END_INSN BEGIN_INSN (OP_REST_ARG) int i; tmp = Qnil; for (i = argc - 1; i >= argptr; i--) { if (argv[i] != rep_NULL) tmp = Fcons (argv[i], tmp); } argptr = argc; PUSH (tmp); SAFE_NEXT; END_INSN BEGIN_INSN (OP_KEYWORD_ARG) int i; POP1 (tmp); for (i = argptr; i < argc - 1; i++) { if (argv[i] == tmp) { PUSH (argv[i+1]); argv[i] = argv[i+1] = rep_NULL; SAFE_NEXT; } } PUSH (Qnil); SAFE_NEXT; END_INSN BEGIN_INSN (OP_OPTIONAL_ARG_) if (argptr < argc) { PUSH (argv[argptr++]); PUSH (Qt); } else { PUSH (Qnil); } SAFE_NEXT; END_INSN BEGIN_INSN (OP_KEYWORD_ARG_) int i; POP1 (tmp); for (i = argptr; i < argc - 1; i += 2) { if (argv[i]== tmp) { PUSH (argv[i+1]); PUSH (Qt); argv[i] = argv[i+1] = rep_NULL; SAFE_NEXT; } } PUSH (Qnil); SAFE_NEXT; END_INSN /* Jump instructions follow */ BEGIN_INSN (OP_EJMP) /* Pop the stack; if it's nil jmp pc[0,1], otherwise set rep_throw_value=ARG and goto the error handler. */ POP1 (tmp); if(rep_NILP(tmp)) goto do_jmp; rep_throw_value = tmp; HANDLE_ERROR; END_INSN BEGIN_INSN (OP_JN) POP1 (tmp); if(rep_NILP(tmp)) goto do_jmp; pc += 2; SAFE_NEXT; END_INSN BEGIN_INSN (OP_JT) POP1 (tmp); if(!rep_NILP(tmp)) goto do_jmp; pc += 2; SAFE_NEXT; END_INSN BEGIN_INSN (OP_JPN) if(rep_NILP(TOP)) { POP; goto do_jmp; } pc += 2; SAFE_NEXT; END_INSN BEGIN_INSN (OP_JPT) if(!rep_NILP(TOP)) { POP; goto do_jmp; } pc += 2; SAFE_NEXT; END_INSN BEGIN_INSN (OP_JNP) if(rep_NILP(TOP)) goto do_jmp; POP; pc += 2; SAFE_NEXT; END_INSN BEGIN_INSN (OP_JTP) if(!rep_NILP(TOP)) goto do_jmp; POP; pc += 2; SAFE_NEXT; END_INSN BEGIN_INSN (OP_JMP) do_jmp: pc = (unsigned char *) rep_STR(code) + ((pc[0] << ARG_SHIFT) | pc[1]); /* Test if an interrupt occurred... */ rep_TEST_INT; if(rep_INTERRUPTP) HANDLE_ERROR; SYNC_GC; /* ...or if it's time to gc... */ if(rep_data_after_gc >= rep_gc_threshold) Fgarbage_collect (Qnil); /* ...or time to switch threads */ rep_MAY_YIELD; SAFE_NEXT; END_INSN BEGIN_DEFAULT_INSN Fsignal(Qbytecode_error, rep_list_2(rep_VAL(&unknown_op), rep_MAKE_INT(pc[-1]))); HANDLE_ERROR; #ifdef EXTRA_VM_CODE EXTRA_VM_CODE #endif END_INSN END_DISPATCH /* Check if the instruction raised an exception. */ check_error: if (ERROR_OCCURRED_P) { /* Some form of error occurred. Unwind the binding stack. */ error: while(!BIND_TOP_P) { repv item = BIND_RET_POP; if(!rep_CONSP(item) || rep_CAR(item) != Qerror) { rep_GC_root gc_throwval; repv throwval = rep_throw_value; rep_throw_value = rep_NULL; rep_PUSHGC(gc_throwval, throwval); SYNC_GC; impurity -= unbind(item); rep_POPGC; rep_throw_value = throwval; } else if(rep_throw_value != rep_NULL) { item = rep_CDR(item); /* item is an exception-handler, (PC . SP) When the code at PC is called, it will have the current stack usage set to SP, and then the value of rep_throw_value pushed on top. The handler can then use the EJMP instruction to pass control back to the error: label, or simply continue execution as normal. */ stackp = stack + rep_INT(rep_CDR(item)); RELOAD; PUSH(rep_throw_value); rep_throw_value = rep_NULL; pc = (unsigned char *) rep_STR(code) + rep_INT(rep_CAR(item)); impurity--; SAFE_NEXT; } else { /* car is an exception handler, but rep_throw_value isn't set, so there's nothing to handle. Keep unwinding. */ impurity--; } } TOP = rep_NULL; RETURN; } #ifdef OPTIMIZE_FOR_SPACE safe_next: #endif SAFE_NEXT__; } quit: /* only use this var to save declaring another */ code = TOP; SYNC_GC; /* close the register scope */ } /* moved to after the execution, to avoid needing to gc protect argv */ if(rep_data_after_gc >= rep_gc_threshold) Fgarbage_collect (Qnil); rep_MAY_YIELD; rep_lisp_depth--; #ifdef SLOW_GC_PROTECT rep_POPGCN; rep_POPGCN; rep_POPGCN; rep_POPGCN; rep_POPGC; rep_POPGC; #else rep_gc_root_stack = gc_consts.next; rep_gc_n_roots_stack = gc_argv.next; #endif return code; } librep-0.90.2/src/lispmach.c0000644000175200017520000001320011245011153014605 0ustar chrischris/* lispmach.c -- Interpreter for compiled Lisp forms $Id$ Copyright (C) 1993, 1994, 2000 John Harper This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE /* Define this to check if the compiler gets things right */ #undef TRUST_NO_ONE /* Define this to bytecode use histograms */ #undef BYTECODE_PROFILE /* Define this to cache top-of-stack in a register (not usually worth it) */ #undef CACHE_TOS /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include DEFSYM(bytecode_error, "bytecode-error"); /* pull in the generic interpreter */ #ifdef BYTECODE_PROFILE static int bytecode_profile[256]; #endif #ifdef TRUST_NO_ONE # define ASSERT(x) assert(x) #else # define ASSERT(x) #endif #define BC_APPLY_SELF 0 #include "lispmach.h" /* interface */ repv rep_apply_bytecode (repv subr, int nargs, repv *args) { assert (rep_COMPILEDP (subr)); return inline_apply_bytecode (subr, nargs, args); } DEFUN("run-byte-code", Frun_byte_code, Srun_byte_code, (repv code, repv consts, repv stkreq), rep_Subr3) { int v_stkreq, b_stkreq, s_stkreq; if (rep_STRUCTUREP (code)) { /* install ourselves in this structure */ rep_STRUCTURE (code)->apply_bytecode = 0; return Qt; } rep_DECLARE1(code, rep_STRINGP); rep_DECLARE2(consts, rep_VECTORP); rep_DECLARE3(stkreq, rep_INTP); v_stkreq = rep_INT (stkreq) & 0x3ff; b_stkreq = (rep_INT (stkreq) >> 10) & 0x3ff; s_stkreq = rep_INT (stkreq) >> 20; return vm (code, consts, 0, 0, v_stkreq, b_stkreq, s_stkreq); } DEFUN("validate-byte-code", Fvalidate_byte_code, Svalidate_byte_code, (repv bc_major, repv bc_minor), rep_Subr2) /* ::doc:rep.vm.interpreter#validate-byte-code:: validate-byte-code BC-MAJOR BC-MINOR Check that byte codes from instruction set BC-MAJOR.BC-MINOR, may be executed. If not, an error will be signalled. ::end:: */ { if(!rep_INTP(bc_major) || !rep_INTP(bc_minor) || rep_INT(bc_major) != BYTECODE_MAJOR_VERSION || rep_INT(bc_minor) > BYTECODE_MINOR_VERSION) { DEFSTRING (err, "File needs recompiling for current virtual machine"); return Fsignal (Qbytecode_error, rep_LIST_2 (rep_VAL (&err), Fsymbol_value (Qload_filename, Qt))); } else return Qt; } DEFUN("make-byte-code-subr", Fmake_byte_code_subr, Smake_byte_code_subr, (repv args), rep_SubrN) /* ::doc:rep.vm.interpreter#make-byte-code-subr:: make-byte-code-subr CODE CONSTANTS STACK [DOC] [INTERACTIVE] Return an object that can be used as the function value of a symbol. ::end:: */ { int len = rep_list_length(args); repv obj[5], vec; int used; if(len < rep_COMPILED_MIN_SLOTS) return rep_signal_missing_arg(len + 1); if(!rep_STRINGP(rep_CAR(args))) return rep_signal_arg_error(rep_CAR(args), 2); obj[0] = rep_CAR(args); args = rep_CDR(args); if(!rep_VECTORP(rep_CAR(args))) return rep_signal_arg_error(rep_CAR(args), 3); obj[1] = rep_CAR(args); args = rep_CDR(args); if(!rep_INTP(rep_CAR(args))) return rep_signal_arg_error(rep_CAR(args), 4); obj[2] = rep_CAR(args); args = rep_CDR(args); used = 3; if(rep_CONSP(args)) { obj[used++] = rep_CAR(args); args = rep_CDR(args); if(rep_CONSP(args)) { obj[used++] = rep_CAR(args); args = rep_CDR(args); if(rep_NILP(obj[used - 1])) used--; } if(used == 4 && rep_NILP(obj[used - 1])) used--; } vec = Fmake_vector(rep_MAKE_INT(used), Qnil); if(vec != rep_NULL) { int i; rep_COMPILED(vec)->car = ((rep_COMPILED(vec)->car & ~rep_CELL8_TYPE_MASK) | rep_Compiled); for(i = 0; i < used; i++) rep_VECTI(vec, i) = obj[i]; } return vec; } DEFUN("bytecodep", Fbytecodep, Sbytecodep, (repv arg), rep_Subr1) /* ::doc:rep.vm.interpreter#bytecodep:: bytecodep ARG Returns t if ARG is a byte code subroutine (i.e. compiled Lisp code). ::end:: */ { return rep_COMPILEDP(arg) ? Qt : Qnil; } #ifdef BYTECODE_PROFILE static void print_bytecode_profile (void) { int i; for (i = 0; i < 256; i++) printf ("%8d %8d\n", i, bytecode_profile[i]); } DEFUN ("bytecode-profile", Fbytecode_profile, Sbytecode_profile, (repv reset), rep_Subr1) { if (reset != Qnil) memset (bytecode_profile, 0, sizeof (bytecode_profile)); else print_bytecode_profile (); return Qnil; } #endif void rep_lispmach_init(void) { repv tem = rep_push_structure ("rep.vm.interpreter"); rep_ADD_SUBR(Srun_byte_code); rep_ADD_SUBR(Svalidate_byte_code); rep_ADD_SUBR(Smake_byte_code_subr); rep_ADD_SUBR(Sbytecodep); #ifdef BYTECODE_PROFILE rep_ADD_SUBR(Sbytecode_profile); atexit (print_bytecode_profile); #endif rep_INTERN(bytecode_error); rep_ERROR(bytecode_error); rep_pop_structure (tem); } void rep_lispmach_kill(void) { } librep-0.90.2/src/lispcmds.c0000644000175200017520000014732211245011153014640 0ustar chrischris/* lispcmds.c -- Lots of standard Lisp functions Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #include "build.h" #include #include #include #include #ifdef NEED_MEMORY_H # include #endif DEFSTRING(default_rep_directory, REP_DIRECTORY); DEFSTRING(dot, "."); static repv default_suffixes; DEFSYM(or, "or"); DEFSYM(and, "and"); DEFSYM(load_path, "load-path"); DEFSYM(dl_load_path, "dl-load-path"); DEFSYM(after_load_alist, "after-load-alist"); DEFSYM(provide, "provide"); DEFSYM(rep_directory, "rep-directory"); DEFSYM(lisp_lib_directory, "lisp-lib-directory"); DEFSYM(site_lisp_directory, "site-lisp-directory"); DEFSYM(exec_directory, "exec-directory"); DEFSYM(documentation_file, "documentation-file"); DEFSYM(documentation_files, "documentation-files"); DEFSYM(_load_suffixes, "%load-suffixes"); DEFSYM(dl_load_reloc_now, "dl-load-reloc-now"); DEFSYM(load_filename, "load-filename"); /* ::doc:load-path:: A list of directory names. When `load' opens a lisp-file it searches each directory named in this list in turn until the file is found or the list is exhausted. ::end:: ::doc:dl-load-path:: List of directories searched for dynamically loaded object files. ::end:: ::doc:after-load-alist:: A list of (LIBRARY FORMS...). Whenever the `load' command reads a file of Lisp code LIBRARY, it executes each of FORMS. Note that LIBRARY must exactly match the FILE argument given to `load'. ::end:: ::doc:rep-directory:: The directory in which all installed data files live. ::end:: ::doc:lisp-lib-directory:: The name of the directory in which the standard lisp files live. ::end:: ::doc:site-lisp-directory:: The name of the directory in which site-specific Lisp files are stored. ::end:: ::doc:exec-directory:: The name of the directory containing architecture specific files. ::end:: ::doc:documentation-file:: The name of the database containing the lisp-library's documentation strings. ::end:: ::doc:documentation-files:: A list of database names containing all documentation strings. ::end:: ::doc:dl-load-reloc-now:: When non-nil, dynamically loaded libraries have all symbol relocations perfromed at load-time, not as required. ::end:: ::doc:load-filename:: While using the `load' function to load a Lisp library, this variable is set to the name of the file being loaded. ::end:: */ DEFUN("quote", Fquote, Squote, (repv args, repv tail_posn), rep_SF) /* ::doc:rep.lang.interpreter#quote:: quote ARG 'ARG Returns ARG. ::end:: */ { if(rep_CONSP(args)) return(rep_CAR(args)); return rep_signal_missing_arg(1); } DEFUN("lambda", Flambda, Slambda, (repv args, repv tail_posn), rep_SF) /* ::doc:rep.lang.interpreter#lambda:: lambda LAMBDA-LIST BODY... Evaluates to an anonymous function. ::end:: */ { if(rep_CONSP(args)) return Fmake_closure (Fcons (Qlambda, args), Qnil); else return rep_signal_missing_arg(1); } DEFUN("car", Fcar, Scar, (repv cons), rep_Subr1) /* ::doc:rep.data#car:: car CONS-CELL Returns the value stored in the car slot of CONS-CELL, or nil if CONS-CELL is nil. ::end:: */ { if(rep_CONSP(cons)) return(rep_CAR(cons)); return(Qnil); } DEFUN("cdr", Fcdr, Scdr, (repv cons), rep_Subr1) /* ::doc:rep.data#cdr:: cdr CONS-CELL Returns the value stored in the cdr slot of CONS-CELL, or nil if CONS-CELL is nil. ::end:: */ { if(rep_CONSP(cons)) return(rep_CDR(cons)); return(Qnil); } DEFUN("list", Flist, Slist, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#list:: list ARGS... Returns a new list with elements ARGS... ::end:: */ { repv lst = Qnil; int i; for (i = argc - 1; i >= 0; i--) { lst = Fcons (argv[i], lst); } return lst; } DEFUN("list*", Flist_star, Slist_star, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#list*:: list* ARG1 ARG2 ... ARGN Returns a new list (ARG1 ARG2 ... ARGN-1 . ARGN). That is, the same as from `list' but the last argument is dotted to the last but one argument. ::end:: */ { repv lst; int i; if (argc == 0) return Qnil; lst = argv[argc - 1]; for (i = argc - 2; i >= 0; i--) { lst = Fcons (argv[i], lst); } return lst; } DEFUN("make-list", Fmake_list, Smake_list, (repv len, repv init), rep_Subr2) /* ::doc:rep.data#make-list:: make-list LENGTH [INITIAL-repv] Returns a new list with LENGTH members, each of which is initialised to INITIAL-repv, or nil. ::end:: */ { int i; repv list = Qnil; rep_DECLARE1(len, rep_INTP); if(rep_INT(len) < 0) return rep_signal_arg_error(len, 1); for(i = 0; list != rep_NULL && i < rep_INT(len); i++) list = Fcons(init, list); return(list); } DEFUN("append", Fappend, Sappend, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#append:: append LISTS... Non-destructively concatenates each of it's argument LISTS... into one new list which is returned. ::end:: */ { int i; repv res = Qnil, *res_end = &res; for (i = 0; i < argc; i++) { if (i != argc - 1) { if (!rep_LISTP(argv[i])) return rep_signal_arg_error (argv[i], i + 1); /* Only make a new copy if there's another list after this one. */ *res_end = rep_copy_list (argv[i]); } else *res_end = argv[i]; while (rep_CONSP (*res_end)) { rep_TEST_INT; if (rep_INTERRUPTP) return rep_NULL; res_end = rep_CDRLOC (*res_end); } } return res; } DEFUN("nconc", Fnconc_, Snconc, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#nconc:: nconc LISTS... Destructively concatenates each of it's argument LISTS... into one new list. Every LIST but the last is modified so that it's last cdr points to the beginning of the next list. Returns the new list. ::end:: */ { int i; repv res = Qnil, *res_end = &res; for (i = 0; i < argc; i++) { if (i != argc - 1) { if (!rep_LISTP (argv[i])) return rep_signal_arg_error (argv[i], i + 1); if (!rep_CONS_WRITABLE_P (argv[i])) return Fsignal (Qsetting_constant, rep_LIST_1 (argv[i])); } *res_end = argv[i]; while (rep_CONSP (*res_end)) { rep_TEST_INT; if (rep_INTERRUPTP) return rep_NULL; res_end = rep_CDRLOC (*res_end); } } return res; } DEFUN("rplaca", Frplaca, Srplaca, (repv cons, repv car), rep_Subr2) /* ::doc:rep.data#rplaca:: rplaca CONS-CELL NEW-CAR Sets the value of the car slot in CONS-CELL to NEW-CAR. Returns the CONS-CELL. ::end:: */ { rep_DECLARE1(cons, rep_CONSP); if(!rep_CONS_WRITABLE_P(cons)) return Fsignal(Qsetting_constant, rep_LIST_1(cons)); rep_CAR(cons) = car; return(cons); } DEFUN("rplacd", Frplacd, Srplacd, (repv cons, repv cdr), rep_Subr2) /* ::doc:rep.data#rplacd:: rplacd CONS-CELL NEW-CDR Sets the value of the cdr slot in CONS-CELL to NEW-CDR. Returns the CONS-CELL. ::end:: */ { rep_DECLARE1(cons, rep_CONSP); if(!rep_CONS_WRITABLE_P(cons)) return Fsignal(Qsetting_constant, rep_LIST_1(cons)); rep_CDR(cons) = cdr; return(cons); } DEFUN("reverse", Freverse, Sreverse, (repv head), rep_Subr1) /* ::doc:rep.data#reverse:: reverse LIST Returns a new list which is a copy of LIST except that the members are in reverse order. ::end:: */ { repv res = Qnil; rep_DECLARE1(head, rep_LISTP); while(rep_CONSP(head)) { res = Fcons(rep_CAR(head), res); head = rep_CDR(head); rep_TEST_INT; if(res == rep_NULL || rep_INTERRUPTP) return(rep_NULL); } return(res); } DEFUN("nreverse", Fnreverse, Snreverse, (repv head), rep_Subr1) /* ::doc:rep.data#nreverse:: nreverse LIST Returns LIST altered so that it's members are in reverse order to what they were. This function is destructive towards it's argument. ::end:: */ { repv res = Qnil; repv nxt; rep_DECLARE1(head, rep_LISTP); if(rep_NILP(head)) return(head); if(!rep_CONS_WRITABLE_P(head)) return Fsignal(Qsetting_constant, rep_LIST_1(head)); do { if(rep_CONSP(rep_CDR(head))) nxt = rep_CDR(head); else nxt = rep_NULL; rep_CDR(head) = res; res = head; rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } while((head = nxt) != rep_NULL); return(res); } DEFUN("assoc", Fassoc, Sassoc, (repv elt, repv list), rep_Subr2) /* ::doc:rep.data#assoc:: assoc ELT ASSOC-LIST Searches ASSOC-LIST for a list whose first element is ELT. `assoc' uses `equal' to compare elements. Returns the sub-list starting from the first matching association. For example, (assoc 'three '((one . 1) (two . 2) (three . 3) (four . 4))) => (three . 3) ::end:: */ { rep_DECLARE2(list, rep_LISTP); while(rep_CONSP(list)) { register repv car = rep_CAR(list); if(rep_CONSP(car) && (!rep_value_cmp(elt, rep_CAR(car)))) return(car); list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(Qnil); } DEFUN("assq", Fassq, Sassq, (repv elt, repv list), rep_Subr2) /* ::doc:rep.data#assq:: assq ELT ASSOC-LIST Searches ASSOC-LIST for a list whose first element is ELT. `assq' uses `eq' to compare elements. Returns the sub-list starting from the first matching association. ::end:: */ { rep_DECLARE2(list, rep_LISTP); while(rep_CONSP(list)) { register repv car = rep_CAR(list); if(rep_CONSP(car) && (elt == rep_CAR(car))) return(car); list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(Qnil); } DEFUN("rassoc", Frassoc, Srassoc, (repv elt, repv list), rep_Subr2) /* ::doc:rep.data#rassoc:: rassoc ELT ASSOC-LIST Searches ASSOC-LIST for a cons-cell whose cdr element is `equal' to ELT. Returns the first cons-cell which matches, or nil. For example, (rassoc 3 '((one . 1) (two . 2) (three . 3) (four . 4))) => (three . 3) ::end:: */ { rep_DECLARE2(list, rep_LISTP); while(rep_CONSP(list)) { register repv car = rep_CAR(list); if(rep_CONSP(car) && (!rep_value_cmp(elt, rep_CDR(car)))) return(car); list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(Qnil); } DEFUN("rassq", Frassq, Srassq, (repv elt, repv list), rep_Subr2) /* ::doc:rep.data#rassq:: rassq ELT ASSOC-LIST Searches ASSOC-LIST for a cons-cell whose cdr is `eq' to ELT. Returns the first matching cons-cell, else nil. ::end:: */ { rep_DECLARE2(list, rep_LISTP); while(rep_CONSP(list)) { register repv car = rep_CAR(list); if(rep_CONSP(car) && (elt == rep_CDR(car))) return(car); list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(Qnil); } DEFUN("nth", Fnth, Snth, (repv index, repv list), rep_Subr2) /* ::doc:rep.data#nth:: nth INDEX LIST Returns the INDEXth element of LIST. The first element has an INDEX of zero. ::end:: */ { int i; rep_DECLARE1(index, rep_INTP); rep_DECLARE2(list, rep_LISTP); i = rep_INT(index); if(i < 0) return rep_signal_arg_error(index, 1); while((i-- > 0) && rep_CONSP(list)) { list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return rep_NULL; } return (i <= 0 && rep_CONSP(list)) ? rep_CAR(list) : Qnil; } DEFUN("nthcdr", Fnthcdr, Snthcdr, (repv index, repv list), rep_Subr2) /* ::doc:rep.data#nthcdr:: nthcdr INDEX LIST Returns the INDEXth cdr of LIST. The first is INDEX zero. ::end:: */ { int i; rep_DECLARE1(index, rep_INTP); rep_DECLARE2(list, rep_LISTP); i = rep_INT(index); if(i < 0) return rep_signal_arg_error(index, 1); while((i-- > 0) && rep_CONSP(list)) { list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return rep_NULL; } return list; } DEFUN("last", Flast, Slast, (repv list), rep_Subr1) /* ::doc:rep.data#last:: last LIST Returns the last element of LIST. ::end:: */ { rep_DECLARE1(list, rep_LISTP); if(rep_CONSP(list)) { while(rep_CONSP(rep_CDR(list))) { list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(rep_CAR(list)); } return(Qnil); } DEFUN("mapcar", Fmapcar, Smapcar, (repv fun, repv list), rep_Subr2) /* ::doc:rep.data#mapcar:: mapcar FUNCTION LIST Calls FUNCTION-NAME with each element of LIST as an argument in turn and returns a new list constructed from the results, ie, (mapcar (function (lambda (x) (1+ x))) '(1 2 3)) => (2 3 4) ::end:: */ { repv res = Qnil; repv *last = &res; rep_GC_root gc_list, gc_fun, gc_res; rep_DECLARE2(list, rep_LISTP); rep_PUSHGC(gc_res, res); rep_PUSHGC(gc_fun, fun); rep_PUSHGC(gc_list, list); while(res != rep_NULL && rep_CONSP(list)) { rep_TEST_INT; if(rep_INTERRUPTP || !(*last = Fcons(Qnil, Qnil)) || !(rep_CAR(*last) = rep_call_lisp1(fun, rep_CAR(list)))) res = rep_NULL; else { last = &rep_CDR(*last); list = rep_CDR(list); } } rep_POPGC; rep_POPGC; rep_POPGC; return res; } DEFUN("mapc", Fmapc, Smapc, (repv fun, repv list), rep_Subr2) /* ::doc:rep.data#mapc:: mapc FUNCTION LIST Applies FUNCTION to each element in LIST, discards the results. ::end:: */ { repv res = Qnil; rep_GC_root gc_fun, gc_list; rep_DECLARE2(list, rep_LISTP); rep_PUSHGC(gc_fun, fun); rep_PUSHGC(gc_list, list); while(res != rep_NULL && rep_CONSP(list)) { rep_TEST_INT; if(rep_INTERRUPTP || !rep_call_lisp1(fun, rep_CAR(list))) res = rep_NULL; list = rep_CDR(list); } rep_POPGC; rep_POPGC; return res; } DEFUN("filter", Ffilter, Sfilter, (repv pred, repv list), rep_Subr2) /* ::doc:rep.data#filter:: filter PREDICATE LIST Return a new list, consisting of the elements in LIST which the function PREDICATE returns t when applied to; i.e. something like (mapcar 'nconc (mapcar #'(lambda (x) (when (PREDICATE x) (list x))) LIST)) ::end:: */ { repv output = Qnil, *ptr = &output; rep_GC_root gc_pred, gc_list, gc_output; rep_DECLARE2(list, rep_LISTP); rep_PUSHGC(gc_pred, pred); rep_PUSHGC(gc_list, list); rep_PUSHGC(gc_output, output); while(rep_CONSP(list)) { repv tem = rep_call_lisp1(pred, rep_CAR(list)); rep_TEST_INT; if(tem == rep_NULL || rep_INTERRUPTP) { output = rep_NULL; break; } if(!rep_NILP(tem)) { *ptr = Fcons(rep_CAR(list), Qnil); ptr = &rep_CDR(*ptr); } list = rep_CDR(list); } rep_POPGC; rep_POPGC; rep_POPGC; return output; } DEFUN("member", Fmember, Smember, (repv elt, repv list), rep_Subr2) /* ::doc:rep.data#member:: member ELT LIST If ELT is a member of list LIST then return the tail of the list starting from the matched ELT, ie, (member 1 '(2 1 3)) => (1 3) `member' uses `equal' to compare atoms. ::end:: */ { rep_DECLARE2(list, rep_LISTP); while(rep_CONSP(list)) { if(!rep_value_cmp(elt, rep_CAR(list))) return(list); list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(Qnil); } DEFUN("memq", Fmemq, Smemq, (repv elt, repv list), rep_Subr2) /* ::doc:rep.data#memq:: memq ELT LIST If ELT is a member of list LIST then return the tail of the list starting from the matched ELT, ie, (memq 1 '(2 1 3)) => (1 3) `memq' uses `eq' to compare atoms. ::end:: */ { rep_DECLARE2(list, rep_LISTP); while(rep_CONSP(list)) { if(elt == rep_CAR(list)) return(list); list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(Qnil); } DEFUN("memql", Fmemql, Smemql, (repv elt, repv list), rep_Subr2) /* ::doc:rep.data#memql:: memql ELT LIST If ELT is a member of list LIST then return the tail of the list starting from the matched ELT. `memql' uses `eql' to compare list items. ::end:: */ { rep_DECLARE2 (list, rep_LISTP); while (rep_CONSP (list)) { if (elt == rep_CAR (list)) return list; else { repv tem = Feql (elt, rep_CAR (list)); if (tem && tem != Qnil) return list; } list = rep_CDR (list); rep_TEST_INT; if (rep_INTERRUPTP) return rep_NULL; } return Qnil; } DEFUN("delete", Fdelete, Sdelete, (repv elt, repv list), rep_Subr2) /* ::doc:rep.data#delete:: delete ELT LIST Returns LIST with any members `equal' to ELT destructively removed. ::end:: */ { repv *head = &list; rep_DECLARE2(list, rep_LISTP); while(rep_CONSP(*head)) { if(!rep_value_cmp(elt, rep_CAR(*head))) *head = rep_CDR(*head); else head = &rep_CDR(*head); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(list); } DEFUN("delq", Fdelq, Sdelq, (repv elt, repv list), rep_Subr2) /* ::doc:rep.data#delq:: delq ELT LIST Returns LIST with any members `eq' to ELT destructively removed. ::end:: */ { repv *head = &list; rep_DECLARE2(list, rep_LISTP); while(rep_CONSP(*head)) { if(elt == rep_CAR(*head)) *head = rep_CDR(*head); else head = &rep_CDR(*head); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(list); } DEFUN("delete-if", Fdelete_if, Sdelete_if, (repv pred, repv list), rep_Subr2) /* ::doc:rep.data#delete-if:: delete-if FUNCTION LIST Similar to `delete' except that a predicate function, FUNCTION-NAME, is used to decide which elements to delete (remove destructively). `delete-if' deletes an element if FUNCTION-NAME returns non-nil when applied to that element, ie, (delete-if '(lambda (x) (= x 1)) '(1 2 3 4 1 2)) => (2 3 4 2) ::end:: */ { repv *head = &list; rep_GC_root gc_list, gc_pred; rep_DECLARE2(list, rep_LISTP); rep_PUSHGC(gc_list, list); rep_PUSHGC(gc_pred, pred); while(rep_CONSP(*head)) { repv tmp = rep_call_lisp1(pred, rep_CAR(*head)); rep_TEST_INT; if(rep_INTERRUPTP || !tmp) { list = rep_NULL; break; } if(!rep_NILP(tmp)) *head = rep_CDR(*head); else head = &rep_CDR(*head); } rep_POPGC; rep_POPGC; return list; } DEFUN("delete-if-not", Fdelete_if_not, Sdelete_if_not, (repv pred, repv list), rep_Subr2) /* ::doc:rep.data#delete-if-not:: delete-if-not FUNCTION LIST Similar to `delete' except that a predicate function, FUNCTION-NAME, is used to decide which elements to delete (remove destructively). `delete-if-not' deletes an element if FUNCTION-NAME returns nil when applied to that element, ie, (delete-if-not '(lambda (x) (= x 1)) '(1 2 3 4 1 2)) => (1 1) ::end:: */ { repv *head = &list; rep_GC_root gc_list, gc_pred; rep_DECLARE2(list, rep_LISTP); rep_PUSHGC(gc_list, list); rep_PUSHGC(gc_pred, pred); while(rep_CONSP(*head)) { repv tmp = rep_call_lisp1(pred, rep_CAR(*head)); rep_TEST_INT; if(rep_INTERRUPTP || !tmp) { list = rep_NULL; break; } if(rep_NILP(tmp)) *head = rep_CDR(*head); else head = &rep_CDR(*head); } rep_POPGC; rep_POPGC; return list; } DEFUN("vector", Fvector, Svector, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#vector:: vector ARGS... Returns a new vector with ARGS... as its elements. ::end:: */ { repv vec = rep_make_vector (argc); if(vec != rep_NULL) { memcpy (rep_VECT (vec)->array, argv, argc * sizeof (repv)); } return vec; } DEFUN("make-vector", Fmake_vector, Smake_vector, (repv size, repv init), rep_Subr2) /* ::doc:rep.data#make-vector:: make-vector SIZE [INITIAL-repv] Creates a new vector of size SIZE. If INITIAL-repv is provided each element will be set to that value, else they will all be nil. ::end:: */ { int len; repv res; rep_DECLARE1(size, rep_INTP); if(rep_INT(size) < 0) return rep_signal_arg_error(size, 1); len = rep_INT(size); res = rep_make_vector(len); if(res) { int i; for(i = 0; i < len; i++) rep_VECTI(res, i) = init; } return(res); } DEFUN("arrayp", Farrayp, Sarrayp, (repv arg), rep_Subr1) /* ::doc:rep.data#arrayp:: arrayp ARG Returns t when ARG is an array. ::end:: */ { return((rep_VECTORP(arg) || rep_STRINGP(arg) || rep_COMPILEDP(arg)) ? Qt : Qnil); } DEFUN("aset", Faset, Saset, (repv array, repv index, repv new), rep_Subr3) /* ::doc:rep.data#aset:: aset ARRAY INDEX NEW-VALUE Sets element number INDEX (a positive integer) of ARRAY (can be a vector or a string) to NEW-VALUE, returning NEW-VALUE. Note that strings can only contain characters (ie, integers). ::end:: */ { rep_DECLARE2(index, rep_INTP); if(rep_INT(index) < 0) return rep_signal_arg_error(index, 2); if(rep_STRINGP(array)) { if(!rep_STRING_WRITABLE_P(array)) return Fsignal(Qsetting_constant, rep_LIST_1(array)); if(rep_INT(index) < rep_STRING_LEN(array)) { rep_DECLARE3(new, rep_INTP); ((unsigned char *)rep_STR(array))[rep_INT(index)] = (unsigned char)rep_INT(new); rep_string_modified (array); return(new); } } else if(rep_VECTORP(array) || rep_COMPILEDP(array)) { if(!rep_VECTOR_WRITABLE_P(array)) return Fsignal(Qsetting_constant, rep_LIST_1(array)); if(rep_INT(index) < rep_VECT_LEN(array)) { rep_VECTI(array, rep_INT(index)) = new; return(new); } } else return(rep_signal_arg_error(array, 1)); return(rep_signal_arg_error(index, 2)); } DEFUN("aref", Faref, Saref, (repv array, repv index), rep_Subr2) /* ::doc:rep.data#aref:: aref ARRAY INDEX Returns the INDEXth (a non-negative integer) element of ARRAY, which can be a vector or a string. INDEX starts at zero. ::end:: */ { rep_DECLARE2(index, rep_INTP); if(rep_INT(index) < 0) return rep_signal_arg_error(index, 2); if(rep_STRINGP(array)) { if(rep_INT(index) < rep_STRING_LEN(array)) return(rep_MAKE_INT(((unsigned char *)rep_STR(array))[rep_INT(index)])); } else if(rep_VECTORP(array) || rep_COMPILEDP(array)) { if(rep_INT(index) < rep_VECT_LEN(array)) return(rep_VECTI(array, rep_INT(index))); } else return rep_signal_arg_error (array, 1); return rep_signal_arg_error (index, 2); } DEFUN("make-string", Fmake_string, Smake_string, (repv len, repv init), rep_Subr2) /* ::doc:rep.data#make-string:: make-string LENGTH [INITIAL-VALUE] Returns a new string of length LENGTH, each character is initialised to INITIAL-repv, or to space if INITIAL-VALUE is not given. ::end:: */ { repv res; rep_DECLARE1(len, rep_INTP); if(rep_INT(len) < 0) return rep_signal_arg_error(len, 1); res = rep_make_string(rep_INT(len) + 1); if(res) { memset(rep_STR(res), rep_INTP(init) ? (char)rep_INT(init) : ' ', rep_INT(len)); rep_STR(res)[rep_INT(len)] = 0; } return(res); } DEFUN("substring", Fsubstring, Ssubstring, (repv string, repv start, repv end), rep_Subr3) /* ::doc:rep.data#substring:: substring STRING START [END] Returns the portion of STRING starting at character number START and ending at the character before END (or the end of the string if END is not given). All indices start at zero. ::end:: */ { int slen; rep_DECLARE1(string, rep_STRINGP); rep_DECLARE2(start, rep_INTP); rep_DECLARE3_OPT(end, rep_INTP); slen = rep_STRING_LEN(string); if(rep_INT(start) > slen || rep_INT(start) < 0) return(rep_signal_arg_error(start, 2)); if(rep_INTP(end)) { if((rep_INT(end) > slen) || (rep_INT(end) < rep_INT(start))) return(rep_signal_arg_error(end, 3)); return(rep_string_dupn(rep_STR(string) + rep_INT(start), rep_INT(end) - rep_INT(start))); } else return(rep_string_dupn(rep_STR(string) + rep_INT(start), slen - rep_INT(start))); } DEFUN("concat", Fconcat, Sconcat, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#concat:: concat ARGS... Concatenates all ARGS... into a single string, each argument can be a string, a character or a list or vector of characters. ::end:: */ { unsigned int length; repv elt, string; char *ptr; int i; /* Pass 1. calculate the length of the new string. */ length = 0; for (i = 0; i < argc; i++) { elt = argv[i]; if (rep_INTP (elt)) { length++; } else if (rep_CONSP (elt)) { length += rep_list_length (elt); } else { switch (rep_CELL8_TYPE (elt)) { case rep_String: length += rep_STRING_LEN (elt); break; case rep_Vector: length += rep_VECT_LEN (elt); break; } } } if (length == 0) return rep_null_string (); /* Allocate the string. */ string = rep_make_string (length + 1); ptr = rep_STR (string); /* Pass 2: copy in the data */ for (i = 0; i < argc; i++) { elt = argv[i]; if (rep_INTP (elt)) { *ptr++ = rep_INT (elt); } else if (rep_CONSP (elt)) { repv tem = elt, c; while (rep_CONSP (tem)) { c = rep_CAR (tem); if (rep_INTP (c)) *ptr++ = rep_INT (c); tem = rep_CDR (tem); } } else { switch (rep_CELL8_TYPE (elt)) { int i; repv c; case rep_String: memcpy (ptr, rep_STR (elt), rep_STRING_LEN (elt)); ptr += rep_STRING_LEN (elt); break; case rep_Vector: for (i = 0; i < rep_VECT_LEN (elt); i++) { c = rep_VECTI (elt, i); if (rep_INTP (c)) *ptr++ = rep_INT (c); } break; } } } if (rep_STRING_LEN (string) != (ptr - rep_STR (string))) rep_set_string_len (string, ptr - rep_STR (string)); *ptr++ = '\0'; return string; } DEFUN("length", Flength, Slength, (repv sequence), rep_Subr1) /* ::doc:rep.data#length:: length SEQUENCE Returns the number of elements in SEQUENCE (a string, list or vector). ::end:: */ { if (sequence == Qnil) return rep_MAKE_INT (0); switch(rep_TYPE(sequence)) { int i; case rep_String: return(rep_MAKE_INT(rep_STRING_LEN(sequence))); break; case rep_Vector: case rep_Compiled: return(rep_MAKE_INT(rep_VECT_LEN(sequence))); break; case rep_Cons: i = 0; while(rep_CONSP(sequence)) { sequence = rep_CDR(sequence); i++; rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } return(rep_MAKE_INT(i)); break; default: return rep_signal_arg_error (sequence, 1); } } DEFUN("copy-sequence", Fcopy_sequence, Scopy_sequence, (repv seq), rep_Subr1) /* ::doc:rep.data#copy-sequence:: copy-sequence SEQUENCE Returns a new sequence whose elements are eq to those in SEQUENCE. ::end:: */ { repv res = Qnil; if (seq == Qnil) return Qnil; switch(rep_TYPE(seq)) { case rep_Cons: { repv *last = &res; while(rep_CONSP(seq)) { rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); if(!(*last = Fcons(rep_CAR(seq), Qnil))) return(rep_NULL); last = &rep_CDR(*last); seq = rep_CDR(seq); } } break; case rep_Vector: case rep_Compiled: res = rep_make_vector(rep_VECT_LEN(seq)); if(res) { int i, len = rep_VECT_LEN(seq); rep_VECT(res)->car = rep_VECT(seq)->car; for(i = 0; i < len; i++) rep_VECTI(res, i) = rep_VECTI(seq, i); } break; case rep_String: res = rep_string_dupn(rep_STR(seq), rep_STRING_LEN(seq)); break; default: res = rep_signal_arg_error(seq, 1); } return(res); } DEFUN("elt", Felt, Selt, (repv seq, repv index), rep_Subr2) /* ::doc:rep.data#elt:: elt SEQUENCE INDEX Return the element of SEQUENCE at position INDEX (counting from zero). ::end:: */ { if(rep_NILP(Farrayp(seq))) return(Fnth(index, seq)); else return(Faref(seq, index)); } DEFUN("cond", Fcond, Scond, (repv args, repv tail_posn), rep_SF) /* ::doc:rep.lang.interpreter#cond:: cond (CONDITION FORMS... ) ... Find the first CONDITION which has a value of t when eval'ed, then perform a progn on its associated FORMS. If there are no FORMS with the CONDITION then the value of the CONDITION is returned. If no CONDITION is t then return nil. An example, (cond ((stringp foo) (title "foo is a string")) ((numberp foo) (setq bar foo) (title "foo is a number")) (t (title "foo is something else..."))) Note the use of plain `t' on it's own for the last CONDITION, this is like the last else in an else-if statement in C. ::end:: */ { repv res = Qnil; rep_GC_root gc_args; rep_PUSHGC(gc_args, args); while(rep_CONSP(args) && rep_CONSP(rep_CAR(args))) { repv cndlist = rep_CAR(args); if(!(res = rep_eval(rep_CAR(cndlist), Qnil))) break; if(!rep_NILP(res)) { if(rep_CONSP(rep_CDR(cndlist))) { if(!(res = Fprogn(rep_CDR(cndlist), tail_posn))) break; } break; } args = rep_CDR(args); } rep_POPGC; return(res); } static inline repv load_file_exists_p (repv name) { repv tem = Ffile_readable_p (name); if (tem && tem != Qnil) { tem = Ffile_directory_p (name); if (tem) return (tem == Qnil) ? Qt : Qnil; } return tem; } DEFUN ("load-file", Fload_file, Sload_file, (repv name, repv structure), rep_Subr2) /* ::doc:rep.io.files#load-file:: load-file FILENAME [STRUCTURE] Load the file of Lisp forms called FILENAME (no suffixes are added, or paths searched). The file is loaded in a null lexical environment, within STRUCTURE. The value of the last form evaluated is returned. ::end:: */ { repv stream, bindings = Qnil, result, tem; rep_GC_root gc_stream, gc_bindings; struct rep_Call lc; int c; if (structure == Qnil) structure = rep_structure; rep_DECLARE1 (name, rep_STRINGP); rep_DECLARE2 (structure, rep_STRUCTUREP); rep_PUSHGC (gc_stream, name); rep_PUSHGC (gc_bindings, structure); stream = Fopen_file (name, Qread); rep_POPGC; rep_POPGC; if (!stream || !rep_FILEP (stream)) return rep_NULL; bindings = rep_bind_symbol (bindings, Qload_filename, name); rep_PUSHGC (gc_stream, stream); rep_PUSHGC (gc_bindings, bindings); /* Create the lexical environment for the file. */ lc.fun = Qnil; lc.args = Qnil; rep_PUSH_CALL (lc); rep_env = Qnil; rep_structure = structure; result = Qnil; c = rep_stream_getc (stream); while ((c != EOF) && (tem = rep_readl (stream, &c))) { rep_TEST_INT; if (rep_INTERRUPTP || !(result = rep_eval (tem, Qnil))) { result = rep_NULL; goto out; } } if (rep_throw_value && rep_CAR (rep_throw_value) == Qerror && rep_CONSP (rep_CDR(rep_throw_value)) && rep_CAR (rep_CDR(rep_throw_value)) == Qend_of_stream) { /* lose the end-of-stream error. */ rep_throw_value = rep_NULL; } out: rep_POP_CALL (lc); rep_POPGC; rep_POPGC; rep_PUSHGC (gc_stream, result); rep_unbind_symbols (bindings); Fclose_file (stream); rep_POPGC; return result; } DEFUN ("load-dl-file", Fload_dl_file, Sload_dl_file, (repv name, repv structure), rep_Subr2) { struct rep_Call lc; repv result; if (structure == Qnil) structure = rep_structure; rep_DECLARE1 (name, rep_STRINGP); rep_DECLARE2 (structure, rep_STRUCTUREP); /* Create the lexical environment for the file. */ lc.fun = Qnil; lc.args = Qnil; rep_PUSH_CALL (lc); rep_env = Qnil; rep_structure = structure; #ifdef HAVE_DYNAMIC_LOADING result = rep_open_dl_library (name); #else result = Fsignal (Qerror, rep_LIST_1 (rep_string_dup ("No support for dynamic loading of shared libraries"))); #endif rep_POP_CALL (lc); return result; } DEFUN_INT("load", Fload, Sload, (repv file, repv noerr_p, repv nopath_p, repv nosuf_p, repv unused), rep_Subr5, "fLisp file to load:") /* ::doc:rep.io.files#load:: load FILE [NO-ERROR] [NO-PATH] [NO-SUFFIX] Attempt to open and then read-and-eval the file of Lisp code FILE. For each directory named in the variable `load-path' tries the value of FILE with `.jlc' (compiled-lisp) appended to it, then with `.jl' appended to it, finally tries FILE without modification. If NO-ERROR is non-nil no error is signalled if FILE can't be found. If NO-PATH is non-nil the `load-path' variable is not used, just the value of FILE. If NO-SUFFIX is non-nil no suffixes are appended to FILE. If the compiled version is older than it's source code, the source code is loaded and a warning is displayed. ::end:: */ { /* Avoid the need to protect these args from GC. */ rep_bool no_error_p = !rep_NILP(noerr_p); rep_bool no_suffix_p = !rep_NILP(nosuf_p); rep_bool interp_mode = Fsymbol_value (Qinterpreted_mode, Qt) != Qnil; repv name = Qnil, path; repv dir = rep_NULL, try = rep_NULL; repv result = rep_NULL; repv suffixes; rep_bool trying_dl = rep_FALSE; rep_GC_root gc_file, gc_name, gc_path, gc_dir, gc_try, gc_result, gc_suffixes; rep_DECLARE1(file, rep_STRINGP); if(rep_NILP(nopath_p)) { path = Fsymbol_value(Qload_path, Qnil); if(!path) return(rep_NULL); } else path = Fcons(rep_null_string(), Qnil); suffixes = F_structure_ref (rep_structure, Q_load_suffixes); if (!suffixes || !rep_CONSP (suffixes)) suffixes = default_suffixes; rep_PUSHGC(gc_name, name); rep_PUSHGC(gc_file, file); rep_PUSHGC(gc_path, path); rep_PUSHGC(gc_dir, dir); rep_PUSHGC(gc_try, try); rep_PUSHGC(gc_suffixes, suffixes); /* Scan the path for the file to load. */ research: while(rep_NILP(name) && rep_CONSP(path)) { if (rep_STRINGP (rep_CAR(path))) { dir = Fexpand_file_name (file, rep_CAR(path)); if(dir == rep_NULL || !rep_STRINGP(dir)) goto path_error; if(trying_dl || !no_suffix_p) { repv tem; int i = 1; if (!trying_dl && interp_mode) i = 0; for(; i >= 0; i--) { #ifdef HAVE_DYNAMIC_LOADING if (trying_dl) { if (i == 1) try = rep_concat2(rep_STR(dir), ".la"); else { try = (Fexpand_file_name (rep_concat3 ("lib", rep_STR(file), ".la"), rep_CAR(path))); } } else #endif { repv sfx = ((i == 0) ? rep_CAR(suffixes) : rep_CDR(suffixes)); if (rep_STRINGP (sfx)) try = rep_concat2(rep_STR(dir), rep_STR(sfx)); } if (try && rep_STRINGP (try)) { tem = load_file_exists_p (try); if(!tem) goto path_error; if(tem != Qnil) { if(name != Qnil) { if(rep_file_newer_than(try, name)) { if (rep_message_fun != 0) (*rep_message_fun)(rep_messagef, "Warning: %s newer than %s, using %s", rep_STR(try), rep_STR(name), rep_STR(try)); name = try; } } else name = try; } } } } if(!trying_dl && name == Qnil && no_suffix_p) { /* Try without a suffix */ repv tem = load_file_exists_p (dir); if(!tem) goto path_error; if(tem != Qnil) name = dir; } } path = rep_CDR(path); rep_TEST_INT; if(rep_INTERRUPTP) goto path_error; } #ifdef HAVE_DYNAMIC_LOADING if(rep_NILP(name) && !trying_dl) { if(rep_NILP(nopath_p)) { path = Fsymbol_value(Qdl_load_path, Qnil); if(!path) return rep_NULL; } else path = rep_LIST_1(rep_null_string()); trying_dl = rep_TRUE; goto research; } #endif path_error: rep_POPGC; rep_POPGC; rep_POPGC; rep_POPGC; rep_POPGC; rep_POPGC; if(rep_NILP(name)) { if(!no_error_p) return rep_signal_file_error(file); else return Qnil; } rep_PUSHGC (gc_file, file); #ifdef HAVE_DYNAMIC_LOADING if(trying_dl) result = Fload_dl_file (name, rep_structure); else #endif result = Fload_file (name, rep_structure); rep_POPGC; if (result == rep_NULL) return rep_NULL; /* Loading succeeded. Look for an applicable item in the after-load-alist. */ if (rep_STRUCTUREP (result) && rep_STRUCTURE (result)->name != Qnil) /* use the canonical name in case of aliasing.. */ file = rep_SYM (rep_STRUCTURE (result)->name)->name; rep_PUSHGC (gc_result, result); rep_PUSHGC (gc_file, file); { repv tem; again: tem = Fsymbol_value(Qafter_load_alist, Qt); if(tem != rep_NULL && rep_CONSP(tem)) { tem = Fassoc(file, tem); if(tem != rep_NULL && rep_CONSP(tem)) { /* Delete this entry */ Fset(Qafter_load_alist, Fdelq(tem, Fsymbol_value (Qafter_load_alist, Qt))); /* Then call it */ tem = rep_CDR (tem); while (rep_CONSP (tem) && !rep_INTERRUPTP) { rep_GC_root gc_tem; rep_PUSHGC (gc_tem, tem); rep_call_lisp0 (rep_CAR (tem)); rep_POPGC; tem = rep_CDR (tem); } /* Try for another entry */ goto again; } } } rep_POPGC; rep_POPGC; return result; } DEFUN("equal", Fequal, Sequal, (repv val1, repv val2), rep_Subr2) /* ::doc:rep.data#equal:: equal VALUE1 VALUE2 Compares VALUE1 and VALUE2, compares the actual structure of the objects not just whether the objects are one and the same. ie, will return t for two strings built from the same characters in the same order even if the strings' location in memory is different. ::end:: */ { return (rep_value_cmp(val1, val2) == 0) ? Qt : Qnil; } DEFUN("eq", Feq, Seq, (repv val1, repv val2), rep_Subr2) /* ::doc:rep.data#eq:: eq VALUE1 VALUE2 Returns t if VALUE1 and VALUE2 are one and the same object. Note that this may or may not be true for numbers of the same value (see `eql'). ::end:: */ { return (val1 == val2) ? Qt : Qnil; } DEFUN("not", Fnot, Snot, (repv arg), rep_Subr1) /* ::doc:rep.data#not:: not ARG If ARG is nil returns t, else returns nil. ::end:: */ { if(rep_NILP(arg)) return(Qt); return(Qnil); } DEFUN("string-head-eq", Fstring_head_eq, Sstring_head_eq, (repv str1, repv str2), rep_Subr2) /* ::doc:rep.data#string-head-eq:: string-head-eq STRING1 STRING2 Returns t if STRING2 matches the beginning of STRING1, ie, (string-head-eq "foobar" "foo") => t (string-head-eq "foo" "foobar") => nil ::end:: */ { char *s1, *s2; rep_DECLARE1(str1, rep_STRINGP); rep_DECLARE2(str2, rep_STRINGP); s1 = rep_STR(str1); s2 = rep_STR(str2); while(*s1 && *s2) { if(*s1++ != *s2++) return(Qnil); } if(*s1 || (*s1 == *s2)) return(Qt); return(Qnil); } DEFUN("string-equal", Fstring_equal, Sstring_equal, (repv str1, repv str2), rep_Subr2) /* ::doc:rep.data#string-equal:: string-equal STRING1 STRING2 Returns t if STRING1 and STRING2 are the same, ignoring case. ::end:: */ { char *s1, *s2; rep_DECLARE1(str1, rep_STRINGP); rep_DECLARE2(str2, rep_STRINGP); s1 = rep_STR(str1); s2 = rep_STR(str2); while(*s1 && *s2) { if (toupper (*s1) != toupper (*s2)) return Qnil; s1++; s2++; } return (*s1 || *s2) ? Qnil : Qt; } DEFUN("string-lessp", Fstring_lessp, Sstring_lessp, (repv str1, repv str2), rep_Subr2) /* ::doc:rep.data#string-lessp:: string-lessp STRING1 STRING2 Returns t if STRING1 is `less' than STRING2, ignoring case. ::end:: */ { char *s1, *s2; rep_DECLARE1(str1, rep_STRINGP); rep_DECLARE2(str2, rep_STRINGP); s1 = rep_STR(str1); s2 = rep_STR(str2); while(*s1 && *s2) { if (toupper (*s1) != toupper (*s2)) return (toupper (*s1) < toupper (*s2)) ? Qt : Qnil; s1++; s2++; } return *s2 ? Qt : Qnil; } #define APPLY_COMPARISON(op) \ int i, sign; \ if (argc < 2) \ return rep_signal_missing_arg (argc + 1); \ for (i = 1; i < argc; i++) \ { \ repv a = argv[i-1], b = argv[i]; \ if (rep_NUMBERP (a) || rep_NUMBERP (b)) \ sign = rep_compare_numbers (a, b); \ else \ sign = rep_value_cmp (a, b); \ if (!(sign op 0)) \ return Qnil; \ } \ return Qt; DEFUN("=", Fnum_eq, Snum_eq, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#=:: = ARG1 ARG2 [ARG3 ...] Returns t if each value is the same as every other value. (Using `equal' to compare values, except for numbers, where exactness is ignored.) ::end:: */ { APPLY_COMPARISON(==) } DEFUN("/=", Fnum_noteq, Snum_noteq, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#:/=:: /= ARG1 ARG2 ... Returns t if each value is different from every other value. (Using `equal' to compare values, except for numbers, where exactness is ignored.) ::end:: */ { repv ret = Fnum_eq (argc, argv); return !ret ? rep_NULL : ret == Qnil ? Qt : Qnil; } DEFUN(">", Fgtthan, Sgtthan, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#>:: > ARG1 ARG2 [ARG3 ...] Returns t if ARG1 is greater than ARG2, and if ARG2 is greater than ARG3, and so on. Note that this command isn't limited to numbers, it can do strings, positions, marks, etc as well. ::end:: */ { APPLY_COMPARISON(>) } DEFUN(">=", Fgethan, Sgethan, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#>=:: >= ARG1 ARG2 [ARG3 ...] Returns t if ARG1 is greater-or-equal than ARG2. Note that this command isn't limited to numbers, it can do strings, positions, marks, etc as well. ::end:: */ { APPLY_COMPARISON(>=) } DEFUN("<", Fltthan, Sltthan, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#<:: < ARG1 ARG2 [ARG3 ...] Returns t if ARG1 is less than ARG2. Note that this command isn't limited to numbers, it can do strings, positions, marks, etc as well. ::end:: */ { APPLY_COMPARISON(<) } DEFUN("<=", Flethan, Slethan, (int argc, repv *argv), rep_SubrV) /* ::doc:rep.data#<=:: <= ARG1 ARG2 [ARG3 ...] Returns t if ARG1 is less-or-equal than ARG2. Note that this command isn't limited to numbers, it can do strings, positions, marks, etc as well. ::end:: */ { APPLY_COMPARISON(<=) } DEFUN("null", Fnull, Snull, (repv arg), rep_Subr1) /* ::doc:rep.data#null:: null ARG Returns t if ARG is nil. ::end:: */ { return rep_NILP(arg) ? Qt : Qnil; } DEFUN("atom", Fatom, Satom, (repv arg), rep_Subr1) /* ::doc:rep.data#atom:: atom ARG Returns t if ARG is not a cons-cell. ::end:: */ { return rep_CONSP(arg) ? Qnil : Qt; } DEFUN("consp", Fconsp, Sconsp, (repv arg), rep_Subr1) /* ::doc:rep.data#consp:: consp ARG Returns t if ARG is a cons-cell. ::end:: */ { return rep_CONSP(arg) ? Qt : Qnil; } DEFUN("listp", Flistp, Slistp, (repv arg), rep_Subr1) /* ::doc:rep.data#listp:: listp ARG Returns t if ARG is a list, (either a cons-cell or nil). ::end:: */ { return rep_LISTP(arg) ? Qt : Qnil; } DEFUN("stringp", Fstringp, Sstringp, (repv arg), rep_Subr1) /* ::doc:rep.data#stringp:: stringp ARG Returns t is ARG is a string. ::end:: */ { return rep_STRINGP(arg) ? Qt : Qnil; } DEFUN("vectorp", Fvectorp, Svectorp, (repv arg), rep_Subr1) /* ::doc:rep.data#vectorp:: vectorp ARG Returns t if ARG is a vector. ::end:: */ { return rep_VECTORP(arg) ? Qt : Qnil; } DEFUN("functionp", Ffunctionp, Sfunctionp, (repv arg), rep_Subr1) /* ::doc:rep.lang.interpreter#functionp:: functionp ARG Returns t if ARG is a function. ::end:: */ { switch(rep_TYPE(arg)) { case rep_Subr0: case rep_Subr1: case rep_Subr2: case rep_Subr3: case rep_Subr4: case rep_Subr5: case rep_SubrN: case rep_Funarg: return Qt; case rep_Cons: arg = rep_CAR(arg); if(arg == Qautoload) return(Qt); /* FALL THROUGH */ default: return(Qnil); } } DEFUN("macrop", Fmacrop, Smacrop, (repv arg), rep_Subr1) /* ::doc:rep.lang.interpreter#macrop:: macrop ARG Returns t if ARG is a macro. ::end:: */ { if(rep_CONSP(arg) && rep_CAR(arg) == Qmacro) return Qt; else return Qnil; } DEFUN("special-form-p", Fspecial_form_p, Sspecial_form_p, (repv arg), rep_Subr1) /* ::doc:rep.lang.interpreter#special-form-p:: special-form-p ARG Returns t if ARG is a special-form. ::end:: */ { if(rep_TYPEP(arg, rep_SF)) return(Qt); return(Qnil); } DEFUN("subrp", Fsubrp, Ssubrp, (repv arg), rep_Subr1) /* ::doc:rep.lang.interpreter#subrp:: subrp ARG Returns t if arg is a primitive function. ::end:: */ { switch(rep_TYPE(arg)) { case rep_Subr0: case rep_Subr1: case rep_Subr2: case rep_Subr3: case rep_Subr4: case rep_Subr5: case rep_SubrN: case rep_SF: return(Qt); default: return(Qnil); } } DEFUN("sequencep", Fsequencep, Ssequencep, (repv arg), rep_Subr1) /* ::doc:rep.data#sequencep:: sequencep ARG Returns t is ARG is a sequence (a list, vector or string). ::end:: */ { if(rep_LISTP(arg) || rep_VECTORP(arg) || rep_STRINGP(arg) || rep_COMPILEDP(arg)) return Qt; else return Qnil; } DEFUN("subr-name", Fsubr_name, Ssubr_name, (repv subr, repv useVar), rep_Subr2) /* ::doc:rep.lang.interpreter#subr-name:: subr-name SUBR [USE-VAR] Returns the name (a string) associated with SUBR. ::end:: */ { switch(rep_TYPE(subr)) { case rep_Subr0: case rep_Subr1: case rep_Subr2: case rep_Subr3: case rep_Subr4: case rep_Subr5: case rep_SubrN: case rep_SF: return(rep_SUBR(subr)->name); default: return(Qnil); } } DEFUN("call-hook", Fcall_hook, Scall_hook, (repv hook, repv arg_list, repv type), rep_Subr3) /* ::doc:rep.system#call-hook:: call-hook HOOK ARG-LIST [TYPE] Call the hook named by the symbol HOOK, passing all functions the arguments in the list ARG-LIST. Note that HOOK may also be the actual list of functions to call. TYPE defines how the return values of each function in the hook are treated. If TYPE is nil they are ignored, if TYPE is the symbol `and' the hook aborts after a function returns nil, if TYPE is `or' the hook aborts when a function returns non-nil. In all cases the value returned by the last-evaluated function is returned. ::end:: */ { rep_GC_root gc_hook, gc_arg_list, gc_type; repv res = Qnil; rep_DECLARE2(arg_list, rep_LISTP); if(!rep_LISTP(hook)) { rep_DECLARE1(hook, rep_SYMBOLP); hook = Fsymbol_value(hook, Qt); if(rep_VOIDP(hook) || rep_NILP(hook)) return Qnil; } rep_PUSHGC(gc_hook, hook); rep_PUSHGC(gc_arg_list, arg_list); rep_PUSHGC(gc_type, type); while(rep_CONSP(hook)) { res = Ffuncall(Fcons(rep_CAR(hook), arg_list)); hook = rep_CDR(hook); rep_TEST_INT; if(rep_INTERRUPTP) res = rep_NULL; if(res == rep_NULL || (type == Qand && rep_NILP(res)) || (type == Qor && !rep_NILP(res))) break; } rep_POPGC; rep_POPGC; rep_POPGC; return res; } DEFUN("call-with-exception-handler", Fcall_with_exception_handler, Scall_with_exception_handler, (repv thunk, repv handler), rep_Subr2) /* ::doc:rep.lang.interpreter#call-with-exception-handler:: call-with-exception-handler THUNK HANDLER Call THUNK and return its value. However if an exception of any form occurs, call HANDLER with a single argument, the exception data, and return its value. ::end:: */ /* Non-local exits don't bother with jmp_buf's and the like, they just unwind normally through all levels of recursion with a rep_NULL result. This is slow but it's easy to work with. */ { rep_GC_root gc_handler; repv ret; rep_DECLARE (1, thunk, Ffunctionp (thunk) != Qnil); rep_DECLARE (2, handler, Ffunctionp (handler) != Qnil); rep_PUSHGC (gc_handler, handler); ret = rep_call_lisp0 (thunk); rep_POPGC; if (ret == rep_NULL) { repv data = rep_throw_value; rep_throw_value = rep_NULL; assert (data != rep_NULL); ret = rep_call_lisp1 (handler, data); } return ret; } DEFUN("raise-exception", Fraise_exception, Sraise_exception, (repv ex), rep_Subr1) /* ::doc:rep.lang.interpreter#raise-exception:: raise-exception DATA Raise the exception represented by the cons cell DATA. ::end:: */ { /* Only one thing can use `rep_throw_value' at once. */ rep_DECLARE1 (ex, rep_CONSP); if (rep_throw_value == rep_NULL) rep_throw_value = ex; return rep_NULL; } /* XXX compatibility */ repv Fthrow (repv tag, repv value) { return Fraise_exception (Fcons (tag, value)); } DEFSTRING(jl, ".jl"); DEFSTRING(jlc, ".jlc"); static void add_path (const char *env, repv var) { repv list = Qnil, vec[2]; char *ptr; ptr = getenv (env); while (ptr != 0 && *ptr != 0) { char *end = strchr (ptr, ':'); list = Fcons (end ? rep_string_dupn (ptr, end - ptr) : rep_string_dup (ptr), list); ptr = end ? end + 1 : 0; } vec[0] = Fnreverse (list); vec[1] = Fsymbol_value (var, Qt); Fset (var, Fnconc_ (2, vec)); } void rep_lispcmds_init(void) { DEFSTRING (common_exec, REP_COMMON_EXEC_DIRECTORY); repv tem; tem = rep_push_structure ("rep.lang.interpreter"); rep_ADD_SUBR(Squote); rep_ADD_SUBR(Slambda); rep_ADD_SUBR(Scond); rep_ADD_SUBR(Scall_with_exception_handler); rep_ADD_SUBR(Sraise_exception); rep_ADD_SUBR(Sfunctionp); rep_ADD_SUBR(Smacrop); rep_ADD_SUBR(Sspecial_form_p); rep_ADD_SUBR(Ssubrp); rep_ADD_SUBR(Ssubr_name); rep_pop_structure (tem); tem = rep_push_structure ("rep.data"); rep_ADD_SUBR(Scar); rep_ADD_SUBR(Scdr); rep_ADD_SUBR(Slist); rep_ADD_SUBR(Slist_star); rep_ADD_SUBR(Smake_list); rep_ADD_SUBR(Sappend); rep_ADD_SUBR(Snconc); rep_ADD_SUBR(Srplaca); rep_ADD_SUBR(Srplacd); rep_ADD_SUBR(Sreverse); rep_ADD_SUBR(Snreverse); rep_ADD_SUBR(Sassoc); rep_ADD_SUBR(Sassq); rep_ADD_SUBR(Srassoc); rep_ADD_SUBR(Srassq); rep_ADD_SUBR(Snth); rep_ADD_SUBR(Snthcdr); rep_ADD_SUBR(Slast); rep_ADD_SUBR(Smapcar); rep_ADD_SUBR(Smapc); rep_ADD_SUBR(Sfilter); rep_ADD_SUBR(Smember); rep_ADD_SUBR(Smemq); rep_ADD_SUBR(Smemql); rep_ADD_SUBR(Sdelete); rep_ADD_SUBR(Sdelq); rep_ADD_SUBR(Sdelete_if); rep_ADD_SUBR(Sdelete_if_not); rep_ADD_SUBR(Svector); rep_ADD_SUBR(Smake_vector); rep_ADD_SUBR(Sarrayp); rep_ADD_SUBR(Saset); rep_ADD_SUBR(Saref); rep_ADD_SUBR(Smake_string); rep_ADD_SUBR(Ssubstring); rep_ADD_SUBR(Sconcat); rep_ADD_SUBR(Slength); rep_ADD_SUBR(Scopy_sequence); rep_ADD_SUBR(Selt); rep_ADD_SUBR(Snot); rep_ADD_SUBR(Sequal); rep_ADD_SUBR(Seq); rep_ADD_SUBR(Sstring_head_eq); rep_ADD_SUBR(Sstring_equal); rep_ADD_SUBR(Sstring_lessp); rep_ADD_SUBR(Snum_eq); rep_ADD_SUBR(Snum_noteq); rep_ADD_SUBR(Sgtthan); rep_ADD_SUBR(Sgethan); rep_ADD_SUBR(Sltthan); rep_ADD_SUBR(Slethan); rep_ADD_SUBR(Snull); rep_ADD_SUBR(Satom); rep_ADD_SUBR(Sconsp); rep_ADD_SUBR(Slistp); rep_ADD_SUBR(Sstringp); rep_ADD_SUBR(Svectorp); rep_ADD_SUBR(Ssequencep); rep_pop_structure (tem); tem = rep_push_structure ("rep.io.files"); rep_ADD_SUBR (Sload_file); rep_ADD_SUBR (Sload_dl_file); rep_ADD_SUBR_INT(Sload); rep_pop_structure (tem); tem = rep_push_structure ("rep.system"); rep_ADD_SUBR(Scall_hook); rep_pop_structure (tem); rep_INTERN(provide); rep_INTERN_SPECIAL(rep_directory); if(getenv("REPDIR") != 0) Fset (Qrep_directory, rep_string_dup(getenv("REPDIR"))); else Fset (Qrep_directory, rep_VAL(&default_rep_directory)); rep_INTERN_SPECIAL(lisp_lib_directory); if(getenv("REPLISPDIR") != 0) Fset (Qlisp_lib_directory, rep_string_dup(getenv("REPLISPDIR"))); else Fset (Qlisp_lib_directory, rep_string_dup(REP_LISP_DIRECTORY)); rep_INTERN_SPECIAL(site_lisp_directory); if(getenv("REPSITELISPDIR") != 0) Fset(Qsite_lisp_directory, rep_string_dup(getenv("REPSITELISPDIR"))); else Fset (Qsite_lisp_directory, rep_concat2(rep_STR(Fsymbol_value (Qrep_directory, Qt)), "/site-lisp")); rep_INTERN_SPECIAL(exec_directory); if(getenv("REPEXECDIR") != 0) Fset (Qexec_directory, rep_string_dup(getenv("REPEXECDIR"))); else Fset (Qexec_directory, rep_string_dup(REP_EXEC_DIRECTORY)); rep_INTERN_SPECIAL(documentation_file); if(getenv("REPDOCFILE") != 0) Fset (Qdocumentation_file, rep_string_dup(getenv("REPDOCFILE"))); else { DEFSTRING (doc_file, REP_DOC_FILE); Fset (Qdocumentation_file, rep_VAL (&doc_file)); } rep_INTERN_SPECIAL(documentation_files); Fset (Qdocumentation_files, Fcons (Fsymbol_value (Qdocumentation_file, Qt), Qnil)); rep_INTERN_SPECIAL(load_path); Fset (Qload_path, Fcons (Fsymbol_value (Qlisp_lib_directory, Qt), Fcons (Fsymbol_value (Qsite_lisp_directory, Qt), Fcons (rep_VAL(&dot), Qnil)))); add_path ("REP_LOAD_PATH", Qload_path); rep_INTERN_SPECIAL(dl_load_path); Fset (Qdl_load_path, Fcons (Fsymbol_value (Qexec_directory, Qt), Fcons (rep_VAL (&common_exec), Qnil))); add_path ("REP_DL_LOAD_PATH", Qdl_load_path); rep_INTERN_SPECIAL(after_load_alist); Fset (Qafter_load_alist, Qnil); rep_INTERN(or); rep_INTERN(and); rep_INTERN_SPECIAL(dl_load_reloc_now); Fset (Qdl_load_reloc_now, Qnil); rep_INTERN_SPECIAL(load_filename); default_suffixes = Fcons (rep_VAL (&jl), rep_VAL (&jlc)); rep_mark_static (&default_suffixes); rep_INTERN (_load_suffixes); } librep-0.90.2/src/lisp.c0000644000175200017520000020277211245011153013772 0ustar chrischris/* lisp.c -- Core of the Lisp, reading and evaluating... Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include #include #include #include #ifdef NEED_MEMORY_H # include #endif DEFSYM(debug_entry, "debug-entry"); DEFSYM(debug_exit, "debug-exit"); DEFSYM(debug_error_entry, "debug-error-entry"); DEFSYM(quote, "quote"); DEFSYM(backquote, "backquote"); DEFSYM(backquote_unquote, "backquote-unquote"); DEFSYM(backquote_splice, "backquote-splice"); DEFSYM(lambda, "lambda"); DEFSYM(macro, "macro"); DEFSYM(autoload, "autoload"); DEFSYM(function, "function"); DEFSYM(structure_ref, "structure-ref"); DEFSYM(standard_input, "standard-input"); DEFSYM(standard_output, "standard-output"); DEFSYM(amp_optional, "&optional"); DEFSYM(amp_rest, "&rest"); static repv ex_optional, ex_rest, ex_key; /* When a `throw' happens a function stuffs a cons-cell in here with, (TAG . VALUE). An error is the above with TAG Qerror and VALUE a list of relevant data. */ volatile repv rep_throw_value; /* This cons cell is used for interrupts. We don't know if it's safe to call Fcons() (maybe in gc?) so this is always valid. */ repv rep_int_cell, rep_term_cell; /* Used to mark tail calling throws */ rep_ALIGN_CELL(static rep_cell tail_call_tag) = { rep_Void }; #define TAIL_CALL_TAG rep_VAL(&tail_call_tag) DEFSYM(error, "error"); DEFSTRING(err_error, "Error"); DEFSYM(error_message, "error-message"); DEFSYM(invalid_function, "invalid-function"); DEFSTRING(err_invalid_function, "Invalid function"); DEFSYM(void_value, "void-value"); DEFSTRING(err_void_value, "Unbound variable"); DEFSYM(bad_arg, "bad-arg"); DEFSTRING(err_bad_arg, "Bad argument"); DEFSYM(invalid_read_syntax, "invalid-read-syntax"); DEFSTRING(err_invalid_read_syntax, "Invalid read syntax"); DEFSYM(end_of_stream, "end-of-stream"); DEFSTRING(err_end_of_stream, "End of stream"); DEFSYM(premature_end_of_stream, "premature-end-of-stream"); DEFSTRING(err_premature_end_of_stream, "Premature end of stream"); DEFSYM(invalid_lambda_list, "invalid-lambda-list"); DEFSTRING(err_invalid_lambda_list, "Invalid lambda list"); DEFSYM(missing_arg, "missing-arg"); DEFSTRING(err_missing_arg, "Required argument missing"); DEFSYM(invalid_macro, "invalid-macro"); DEFSTRING(err_invalid_macro, "Invalid macro definition"); DEFSYM(invalid_autoload, "invalid-autoload"); DEFSTRING(err_invalid_autoload, "Invalid autoload definition"); DEFSYM(no_catcher, "no-catcher"); DEFSTRING(err_no_catcher, "No catcher for throw"); DEFSYM(file_error, "file-error"); DEFSTRING(err_file_error, "File error"); DEFSYM(invalid_stream, "invalid-stream"); DEFSTRING(err_invalid_stream, "Invalid stream"); DEFSYM(setting_constant, "setting-constant"); DEFSTRING(err_setting_constant, "Attempt to set value of constant"); DEFSYM(process_error, "process-error"); DEFSTRING(err_process_error, "Process error"); DEFSYM(no_memory, "no-memory"); DEFSTRING(err_no_memory, "No free memory"); DEFSYM(user_interrupt, "user-interrupt"); DEFSTRING(err_user_interrupt, "User interrupt!"); DEFSYM(arith_error, "arith-error"); DEFSTRING(err_arith_error, "Arithmetic error"); DEFSYM(term_interrupt, "term-interrupt"); DEFSYM(debug_on_error, "debug-on-error"); DEFSYM(backtrace_on_error, "backtrace-on-error"); DEFSYM(debug_macros, "debug-macros"); DEFSYM(error_handler_function, "error-handler-function"); /* ::doc:debug-on-error:: When an error is signalled this variable controls whether or not to enter the Lisp debugger immediately. If the variable's value is t or a list of symbols--one of which is the signalled error symbol--the debugger is entered. ::end:: ::doc:backtrace-on-error:: When an error is signalled this variable controls whether or not to print a backtrace immediately. If the variable's value is t or a list of symbols--one of which is the signalled error symbol--the debugger is entered. ::end:: ::doc:debug-macros:: When nil, the debugger isn't entered while expanding macro definitions. ::end:: ::doc:error-handler-function:: When set to a function value, called with two arguments (error type and data) when lisp errors occur. ::end:: */ DEFSYM(print_escape, "print-escape"); DEFSYM(print_length, "print-length"); DEFSYM(print_level, "print-level"); DEFSYM(newlines, "newlines"); /* ::doc:print-escape:: Defines which control characters `print' should quote. Acceptable values are: nil Only escape double-quote and backslash newlines Escape double-quote, backslash, newline, TAB, and formfeed. t Escape all control codes (characters with a value less than 32), and all characters with a value greater than 126. ::end:: ::doc:print-length:: The maximum number of list elements to print before abbreviating. ::end:: ::doc:print-level:: The number of list levels to descend when printing before abbreviating. ::end:: */ DEFSYM(load, "load"); DEFSYM(require, "require"); DEFSYM(ellipsis, "..."); /* When rep_TRUE Feval() calls the "debug-entry" function */ rep_bool rep_single_step_flag; /* Lexical environment. A list of (SYMBOL . VALUE). Any unbound variables are dereferenced in the current structure (global namespace) */ repv rep_env; /* Active special bindings, a list of (SYMBOL . VALUE) */ repv rep_special_bindings; /* The lisp-call backtrace; also used for saving and restoring the current environment */ struct rep_Call *rep_call_stack; /* Prevent infinite recursion */ int rep_lisp_depth, rep_max_lisp_depth = 1000; /* Used to avoid costly interrupt checking too often */ int rep_test_int_counter = 0; /* Limit before calling test_int_fun() */ int rep_test_int_period = 1000; /* Function to test asynchronously for interrupts. If it detects an interrupt, it should set `rep_throw_value' to `rep_int_cell' */ static void default_test_int (void) { } void (*rep_test_int_fun)(void) = default_test_int; static int current_frame_id (void); /* Reading */ /* The `c' variable which keeps coming up is the lookahead character, since each reader function normally has to look at the next character to see if it's what it wants. If not, the lookahead is given to someone else or unread before exiting... */ static repv readl (repv, register int *, repv); static rep_bool read_local_file; /* inline common case of reading from local files; this appears to decrease startup time by about 25% */ static inline int fast_getc (repv stream) { if (read_local_file) { int c = getc (rep_FILE (stream)->file.fh); if (c == '\n') rep_FILE (stream)->line_number++; return c; } else return rep_stream_getc (stream); } static repv signal_reader_error (repv type, repv stream, char *message) { repv error_data = Qnil; if (message != 0) error_data = Fcons (rep_string_dup (message), error_data); if (rep_FILEP (stream)) { if ((rep_FILE (stream)->car & rep_LFF_BOGUS_LINE_NUMBER) == 0) { error_data = Fcons (rep_MAKE_INT (rep_FILE (stream)->line_number), error_data); } error_data = Fcons (rep_FILE (stream)->name, error_data); } else error_data = Fcons (stream, error_data); return Fsignal (type, error_data); } static void read_comment (repv strm, int *c_p) { char terminator = *c_p; register int c; int depth = 1; while ((c = fast_getc (strm)) != EOF) { again: if (c == terminator) { c = rep_stream_getc (strm); if (c == EOF || (c == '#' && --depth == 0)) break; else goto again; } else if (c == '#') { c = rep_stream_getc (strm); if (c == EOF) break; else if (c == terminator) depth++; else goto again; } } if (c != EOF) c = rep_stream_getc (strm); else { signal_reader_error (Qpremature_end_of_stream, strm, "While reading a comment"); } *c_p = c; } static repv read_list(repv strm, register int *c_p) { repv result = Qnil; repv last = rep_NULL; long start_line = read_local_file ? rep_FILE (strm)->line_number : -1; rep_GC_root gc_result; *c_p = rep_stream_getc(strm); rep_PUSHGC(gc_result, result); while(result != rep_NULL) { switch(*c_p) { case EOF: result = signal_reader_error (Qpremature_end_of_stream, strm, "While reading a list"); break; case ' ': case '\t': case '\n': case '\r': case '\f': *c_p = fast_getc(strm); continue; case ';': { register int c; while((c = fast_getc(strm)) != EOF && c != '\n' && c != '\f' && c != '\r') ; *c_p = fast_getc(strm); continue; } case ')': case ']': *c_p = rep_stream_getc(strm); goto end; case '.': *c_p = rep_stream_getc(strm); switch (*c_p) { case EOF: result = signal_reader_error (Qpremature_end_of_stream, strm, "After `.' in list"); goto end; case ' ': case '\t': case '\n': case '\f': case '\r': if(last) { repv this = readl(strm, c_p, Qpremature_end_of_stream); if (this != rep_NULL) rep_CDR (last) = this; else { result = rep_NULL; goto end; } } else { result = signal_reader_error (Qinvalid_read_syntax, strm, "Nothing to dot second element of cons to"); goto end; } continue; default: rep_stream_ungetc (strm, *c_p); *c_p = '.'; } goto do_default; case '#': { int c = rep_stream_getc (strm); if (c == EOF) goto end; else if (c == '|') { *c_p = c; read_comment (strm, c_p); if (rep_INTERRUPTP) return rep_NULL; continue; } rep_stream_ungetc (strm, c); } goto do_default; default: do_default: { register repv this = Fcons(Qnil, Qnil); if(last) rep_CDR(last) = this; else result = this; rep_CAR(this) = readl(strm, c_p, Qpremature_end_of_stream); if(rep_CAR (this) == rep_NULL) result = rep_NULL; last = this; } } } end: rep_POPGC; if (result != rep_NULL) rep_record_origin (result, strm, start_line); return result; } /* Could be a symbol or a number */ static repv read_symbol(repv strm, int *c_p, repv obarray) { static repv buffer = rep_NULL; static size_t buflen = 240; repv result; char *buf; int c = *c_p; int i = 0; /* For parsing numbers, while radix != zero, it might still be an integer that we're reading. */ int radix = -1, sign = 1, nfirst = 0; rep_bool exact = rep_TRUE, rational = rep_FALSE; rep_bool exponent = rep_FALSE, had_sign = rep_FALSE; rep_bool expecting_prefix = rep_FALSE; int force_exactness = 0; if (buffer == rep_NULL) { buffer = rep_make_string (buflen + 2); rep_mark_static (&buffer); } buf = rep_STR(buffer); while (c != EOF) { if (i == buflen) { repv new; buflen = buflen * 2; new = rep_make_string (buflen + 2); memcpy (rep_STR (new), buf, buflen / 2); buf = rep_STR (new); } switch(c) { case ' ': case '\t': case '\n': case '\f': case '\r': case '(': case ')': case '[': case ']': case '\'': case '"': case ';': case ',': case '`': goto done; case '#': if (radix == 0) goto done; else goto number; case '\\': radix = 0; c = rep_stream_getc(strm); if(c == EOF) return signal_reader_error (Qpremature_end_of_stream, strm, "After `\\' in identifer"); buf[i++] = c; break; case '|': radix = 0; c = rep_stream_getc(strm); while((c != EOF) && (c != '|') && (i < buflen)) /* XXX */ { buf[i++] = c; c = rep_stream_getc(strm); } if(c == EOF) return signal_reader_error (Qpremature_end_of_stream, strm, "After `|' in identifier"); break; default: if(radix != 0) { number: if (expecting_prefix) { switch (c) { case 'b': case 'B': radix = 2; break; case 'o': case 'O': radix = 8; break; case 'd': case 'D': radix = 10; break; case 'x': case 'X': radix = 16; break; case 'e': case 'E': force_exactness = +1; break; case 'i': case 'I': force_exactness = -1; break; default: radix = 0; } expecting_prefix = rep_FALSE; nfirst = i + 1; } /* It still may be a number that we're parsing */ else if (i == nfirst && (c == '-' || c == '+' || c == '#')) { if (c == '#') { if (had_sign) radix = 0; /* not a number? */ else expecting_prefix = rep_TRUE; } else { /* A leading sign */ sign = (c == '-') ? -1 : 1; had_sign = rep_TRUE; } nfirst = i + 1; } else { switch (radix) { case -1: /* Deduce the base next (or that we're not looking at a number) */ if (c == '.') { radix = 10; exact = rep_FALSE; } else if(!(c >= '0' && c <= '9')) radix = 0; else if(c == '0') radix = 1; /* octal or hex */ else radix = 10; break; case 1: /* We had a leading zero last character. If this char's an 'x' it's hexadecimal. */ switch (c) { static rep_bool dep_hex, dep_octal; case 'x': case 'X': rep_deprecated (&dep_hex, "`0xNN' hexadecimal read syntax"); radix = 16; nfirst = i + 1; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': rep_deprecated (&dep_octal, "`0NN' octal read syntax"); radix = 8; nfirst = i; break; case '.': case 'e': case 'E': radix = 10; exact = rep_FALSE; break; case '/': radix = 10; rational = rep_TRUE; break; default: radix = 0; } break; default: /* Now we're speculatively reading a number of base radix. */ switch (c) { case '.': if (exact && radix == 10 && !rational) exact = rep_FALSE; else radix = 0; break; case '/': if (exact && !rational) rational = rep_TRUE; else radix = 0; break; case '-': case '+': if (!exponent) goto do_default; break; case 'e': case 'E': /* XXX all scheme exp chars */ if (radix == 10) { if (!rational && !exponent) { exponent = rep_TRUE; exact = rep_FALSE; } else radix = 0; break; } /* fall through */ default: do_default: if(radix <= 10 && !(c >= '0' && c <= ('0' + radix - 1))) { radix = 0; } else if(radix == 16 && !isxdigit(c)) radix = 0; } } } } buf[i++] = c; } c = fast_getc(strm); } done: buf[i] = 0; if (i == 0) { result = signal_reader_error (Qinvalid_read_syntax, strm, "Zero length identifier"); } else if (radix > 0 && nfirst < i) { /* It was a number of some sort */ if (radix == 1) result = rep_MAKE_INT (0); else result = rep_parse_number (buf + nfirst, i - nfirst, radix, sign, !exact ? rep_NUMBER_FLOAT : rational ? rep_NUMBER_RATIONAL : 0); if (result == rep_NULL) goto intern; if (force_exactness > 0) result = Finexact_to_exact (result); else if (force_exactness < 0) result = Fexact_to_inexact (result); } else { intern: rep_set_string_len(buffer, i); result = Ffind_symbol (rep_VAL(buffer), obarray); if (result != rep_NULL && result == Qnil) { result = Fmake_symbol (rep_string_dupn (buf, i)); if (result != rep_NULL) result = Fintern_symbol (result, obarray); } } *c_p = c; return result; } static repv read_vector(repv strm, int *c_p) { repv result; repv list = read_list(strm, c_p); if(list) { repv cur = list; int len; for(len = 0; rep_CONSP(cur); len++) cur = rep_CDR(cur); result = rep_make_vector(len); if(result) { int i; cur = list; for(i = 0; i < len; i++) { repv nxt = rep_CDR(cur); rep_VECT(result)->array[i] = rep_CAR(cur); #if 1 /* I think it's okay to put the cons cells back onto their freelist. There can't be any references to them?? */ rep_cons_free(cur); #endif cur = nxt; } } else result = rep_NULL; } else result = rep_NULL; return result; } static repv read_str(repv strm, int *c_p) { repv result; int buflen = 128; int c = rep_stream_getc(strm); char *buf = rep_alloc(buflen); register char *cur = buf; char *bufend = buf + buflen; if(buf) { while((c != EOF) && (c != '"')) { if(cur == bufend) { register int newbuflen = buflen * 2; register char *newbuf = rep_alloc(newbuflen); if(newbuf) { memcpy(newbuf, buf, cur - buf); rep_free(buf); buf = newbuf; cur = buf + buflen; buflen = newbuflen; bufend = buf + buflen; } else return rep_mem_error(); } if(c == '\\') { c = rep_stream_getc(strm); if(c == '\n') /* escaped newline is ignored */ c = rep_stream_getc(strm); else *cur++ = (char)rep_stream_read_esc(strm, &c); } else { *cur++ = c; c = fast_getc(strm); } } if(c == EOF) result = signal_reader_error (Qpremature_end_of_stream, strm, "While reading a string"); else { *c_p = rep_stream_getc(strm); result = rep_string_dupn(buf, cur - buf); } rep_free(buf); return result; } return rep_mem_error(); } static repv skip_chars (repv stream, const char *str, repv ret, int *ptr) { int c; while (*str != 0) { c = rep_stream_getc (stream); if (c != *str++) { char buf[256]; #ifdef HAVE_SNPRINTF snprintf (buf, sizeof (buf), "Expecting `%s'", str - 1); #else sprintf (buf, "Expecting `%s'", str - 1); #endif return signal_reader_error (Qinvalid_read_syntax, stream, buf); } } c = rep_stream_getc (stream); switch (c) { case EOF: case ' ': case '\t': case '\n': case '\f': case '\r': case '(': case ')': case '[': case ']': case '\'': case '"': case ';': case ',': case '`': *ptr = c; return ret; default: return signal_reader_error (Qinvalid_read_syntax, stream, "expected end of token"); } } /* Using the above readlisp*() functions this classifies each type of expression and translates it into a lisp object (repv). Returns NULL in case of error. */ static repv readl(repv strm, register int *c_p, repv end_of_stream_error) { while(1) { switch(*c_p) { repv form; rep_GC_root gc_form; case EOF: goto eof; case ' ': case '\t': case '\n': case '\f': case '\r': *c_p = fast_getc(strm); continue; case ';': { register int c; while((c = fast_getc(strm)) != EOF && c != '\n' && c != '\f' && c != '\r') ; *c_p = rep_stream_getc(strm); continue; } case '(': return read_list(strm, c_p); case '\'': case '`': /* 'X => (quote X) `X => (backquote X) */ form = Fcons(*c_p == '\'' ? Qquote : Qbackquote, Fcons(Qnil, Qnil)); rep_PUSHGC(gc_form, form); if((*c_p = rep_stream_getc(strm)) == EOF) { rep_POPGC; return signal_reader_error (Qpremature_end_of_stream, strm, "During ` or ' syntax"); } rep_CADR(form) = readl(strm, c_p, Qpremature_end_of_stream); rep_POPGC; if(rep_CADR(form) != rep_NULL) return form; else return rep_NULL; case ',': /* ,@X => (backquote-splice X) ,X => (backquote-unquote X) */ form = Fcons(Qbackquote_unquote, Fcons(Qnil, Qnil)); rep_PUSHGC(gc_form, form); switch((*c_p = rep_stream_getc(strm))) { case EOF: rep_POPGC; return signal_reader_error (Qpremature_end_of_stream, strm, "During , syntax"); case '@': rep_CAR(form) = Qbackquote_splice; if((*c_p = rep_stream_getc(strm)) == EOF) { rep_POPGC; return signal_reader_error (Qpremature_end_of_stream, strm, "During ,@ syntax"); } } rep_CADR(form) = readl(strm, c_p, Qpremature_end_of_stream); rep_POPGC; if(rep_CADR(form) != rep_NULL) return form; else return rep_NULL; case '[': return read_vector(strm, c_p); case '"': return read_str(strm, c_p); case '?': { register int c; switch(c = rep_stream_getc(strm)) { case EOF: return signal_reader_error (Qpremature_end_of_stream, strm, "During ? syntax"); case '\\': if((*c_p = rep_stream_getc(strm)) == EOF) return signal_reader_error (Qpremature_end_of_stream, strm, "During ? syntax"); else return rep_MAKE_INT(rep_stream_read_esc(strm, c_p)); break; default: *c_p = rep_stream_getc(strm); return rep_MAKE_INT(c); } } case '#': switch(*c_p = rep_stream_getc(strm)) { int c; case EOF: return signal_reader_error (Qpremature_end_of_stream, strm, "During # syntax"); case '\'': form = Fcons(Qfunction, Fcons(Qnil, Qnil)); rep_PUSHGC(gc_form, form); if((*c_p = rep_stream_getc(strm)) == EOF) { rep_POPGC; return signal_reader_error (Qpremature_end_of_stream, strm, "During #' syntax"); } rep_CADR(form) = readl(strm, c_p, Qpremature_end_of_stream); rep_POPGC; if(rep_CADR(form) == rep_NULL) return rep_NULL; else return form; case '[': { repv vec = read_vector(strm, c_p); if(vec != rep_NULL) { if(rep_VECT_LEN(vec) >= rep_COMPILED_MIN_SLOTS && rep_STRINGP (rep_COMPILED_CODE (vec)) && rep_VECTORP (rep_COMPILED_CONSTANTS (vec)) && rep_INTP (rep_COMPILED_STACK (vec))) { rep_COMPILED(vec)->car = (rep_COMPILED(vec)->car & ~rep_CELL8_TYPE_MASK) | rep_Compiled; return vec; } return signal_reader_error (Qinvalid_read_syntax, strm, "Invalid bytecode object"); } break; } case '(': return read_vector (strm, c_p); case '|': /* comment delimited by `#| ... |#' */ read_comment (strm, c_p); if (rep_INTERRUPTP) return rep_NULL; continue; case '\\': { static const struct { char *name; int value; } char_names[] = { { "space", ' ' }, { "newline", '\n' }, { "backspace", '\010' }, { "tab", '\t' }, { "linefeed", '\n' }, { "return", '\r' }, { "page", '\f' }, { "rubout", '\177' }, { 0, 0 } }; int c2, i; c = rep_stream_getc (strm); if (c == EOF) return signal_reader_error (Qpremature_end_of_stream, strm, "During #\\ syntax"); if (!isalpha (c)) { *c_p = rep_stream_getc (strm); return rep_MAKE_INT (c); } c2 = rep_stream_getc (strm); if (!isalpha (c2) || c2 == EOF) { *c_p = c2; return rep_MAKE_INT (c); } c = tolower (c); c2 = tolower (c2); for (i = 0; char_names[i].name != 0; i++) { if (char_names[i].name[0] == c && char_names[i].name[1] == c2) { char *ptr = char_names[i].name + 2; while (1) { c = fast_getc (strm); if (*ptr == 0) { *c_p = c; return rep_MAKE_INT (char_names[i].value); } if (c == EOF || tolower (c) != *ptr++) return signal_reader_error (Qinvalid_read_syntax, strm, "Unknown character name"); } } } return signal_reader_error (Qinvalid_read_syntax, strm, "Unknown character name"); } case '!': if (rep_FILEP(strm)) { repv pos = Fseek_file (strm, Qnil, Qnil); if (pos && rep_INTP(pos) && rep_INT(pos) == 2) { /* #! at the start of the file. Skip until !# */ read_comment (strm, c_p); if (rep_INTERRUPTP) return rep_NULL; continue; } } c = rep_stream_getc (strm); switch (c) { case 'o': return skip_chars (strm, "ptional", ex_optional, c_p); case 'r': return skip_chars (strm, "est", ex_rest, c_p); case 'k': return skip_chars (strm, "ey", ex_key, c_p); default: return signal_reader_error (Qinvalid_read_syntax, strm, "Unknown #! prefixed identifier"); } case ':': rep_stream_ungetc (strm, *c_p); *c_p = '#'; form = read_symbol (strm, c_p, rep_keyword_obarray); if (form && rep_SYMBOLP (form)) rep_SYM (form)->car |= rep_SF_KEYWORD; return form; case 't': case 'T': case 'f': case 'F': form = (tolower (*c_p) == 't') ? rep_scm_t : rep_scm_f; *c_p = rep_stream_getc (strm); return form; case 'b': case 'B': case 'o': case 'O': case 'd': case 'D': case 'x': case 'X': case 'e': case 'E': case 'i': case 'I': rep_stream_ungetc (strm, *c_p); *c_p = '#'; goto identifier; case 'u': return skip_chars (strm, "ndefined", rep_undefined_value, c_p); default: return signal_reader_error (Qinvalid_read_syntax, strm, "Invalid token"); } default: identifier: form = read_symbol(strm, c_p, rep_obarray); if (form && *c_p == '#' && rep_SYMBOLP (form)) { /* foo#bar expands to (structure-ref foo bar) (this syntax is from Xerox scheme's module system) */ repv var; *c_p = rep_stream_getc (strm); var = read_symbol (strm, c_p, rep_obarray); if (var != 0) return rep_list_3 (Qstructure_ref, form, var); else return var; } return form; } } /* not reached */ eof: return signal_reader_error (end_of_stream_error, rep_LIST_1(strm), 0); } repv rep_readl (repv stream, int *c_p) { repv form; rep_bool old = read_local_file; read_local_file = rep_FILEP (stream) && rep_LOCAL_FILE_P (stream); form = readl (stream, c_p, Qend_of_stream); read_local_file = old; return form; } /* Evaluating */ /* Evaluates each element of `list' and builds them into a new list. */ static repv eval_list(repv list) { repv result = Qnil; repv *last = &result; rep_GC_root gc_result, gc_list; rep_PUSHGC(gc_result, result); rep_PUSHGC(gc_list, list); while(rep_CONSP(list)) { repv tmp; if(!(tmp = rep_eval(rep_CAR(list), Qnil))) { result = rep_NULL; break; } if(!(*last = Fcons(tmp, Qnil))) { result = rep_NULL; break; } list = rep_CDR(list); last = &rep_CDR(*last); rep_TEST_INT; if(rep_INTERRUPTP) { result = rep_NULL; break; } } if(result && last && !rep_NILP(list)) *last = rep_eval(list, Qnil); rep_POPGC; rep_POPGC; return result; } static inline void copy_to_vector (repv argList, int nargs, repv *args) { int i; for (i = 0; i < nargs; i++) { args[i] = rep_CAR (argList); argList = rep_CDR (argList); } } static repv bind_lambda_list_1 (repv lambdaList, repv *args, int nargs) { #define VAR_SYM 0 #define VAR_VALUE 1 #define VAR_EVALP 2 #define VAR_SIZE 3 #define VAR(i,j) vars[(i) * VAR_SIZE + (j)] repv *vars = alloca ((rep_list_length (lambdaList) + 1) * VAR_SIZE * sizeof (repv)); int nvars = 0; enum arg_state { STATE_REQUIRED = 1, STATE_OPTIONAL, STATE_KEY, STATE_REST }; enum arg_state state; /* Pass 1: traverse the lambda list, recording var-value pairs and whether each value needs to be evaluated or not.. */ state = STATE_REQUIRED; while (1) { repv argspec, def; if (rep_CONSP (lambdaList)) { argspec = rep_CAR (lambdaList); lambdaList = rep_CDR (lambdaList); if (argspec == ex_optional || argspec == Qamp_optional) { static int dep; if (argspec == Qamp_optional) rep_deprecated (&dep, "&optional in lambda list"); if (state >= STATE_OPTIONAL) { invalid: return Fsignal (Qinvalid_lambda_list, rep_LIST_1 (lambdaList)); } state = STATE_OPTIONAL; continue; } else if (argspec == ex_key) { if (state >= STATE_KEY) goto invalid; state = STATE_KEY; continue; } else if (argspec == ex_rest || argspec == Qamp_rest) { static int dep; if (argspec == Qamp_rest) rep_deprecated (&dep, "&rest in lambda list"); if (state >= STATE_REST) goto invalid; state = STATE_REST; continue; } } else if (lambdaList != Qnil && rep_SYMBOLP (lambdaList)) { state = STATE_REST; argspec = lambdaList; lambdaList = Qnil; } else break; if (rep_SYMBOLP (argspec)) { VAR (nvars, VAR_SYM) = argspec; def = Qnil; } else if (rep_CONSP (argspec) && rep_SYMBOLP (rep_CAR (argspec))) { VAR (nvars, VAR_SYM) = rep_CAR (argspec); if (rep_CONSP (rep_CDR (argspec))) def = rep_CADR (argspec); else def = Qnil; } else goto invalid; VAR (nvars, VAR_EVALP) = Qnil; switch (state) { repv key; int i; case STATE_REQUIRED: case STATE_OPTIONAL: if (nargs > 0) { VAR (nvars, VAR_VALUE) = *args++; nargs--; } else if (state == STATE_OPTIONAL) { VAR (nvars, VAR_VALUE) = def; VAR (nvars, VAR_EVALP) = Qt; } else { repv fun = rep_call_stack != 0 ? rep_call_stack->fun : Qnil; return Fsignal (Qmissing_arg, rep_list_2 (fun, argspec)); } break; case STATE_KEY: key = Fmake_keyword (VAR (nvars, VAR_SYM)); VAR (nvars, VAR_VALUE) = def; VAR (nvars, VAR_EVALP) = Qt; for (i = 0; i < nargs - 1; i++) { if (args[i] == key && args[i+1] != rep_NULL) { VAR (nvars, VAR_VALUE) = args[i+1]; VAR (nvars, VAR_EVALP) = Qnil; args[i] = args[i+1] = rep_NULL; break; } } break; case STATE_REST: { repv list = Qnil; repv *ptr = &list; while (nargs > 0) { if (*args != rep_NULL) { *ptr = Fcons (*args, Qnil); ptr = rep_CDRLOC (*ptr); } args++; nargs--; } VAR (nvars, VAR_VALUE) = list; } nvars++; goto out; break; } nvars++; rep_TEST_INT; if (rep_INTERRUPTP) return rep_NULL; } out: /* Pass 2: evaluate any values that need it.. */ { int i; rep_GC_n_roots gc_vars; rep_PUSHGCN (gc_vars, vars, nvars * VAR_SIZE); for (i = 0; i < nvars; i++) { if (VAR (i, VAR_EVALP) != Qnil) { repv tem = Feval (VAR (i, VAR_VALUE)); if (tem == rep_NULL) { rep_POPGCN; return rep_NULL; } VAR (i, VAR_VALUE) = tem; } } rep_POPGCN; } /* Pass 3: instantiate the bindings */ { int i; repv boundlist = rep_NEW_FRAME; for (i = 0; i < nvars; i++) { boundlist = rep_bind_symbol (boundlist, VAR (i, VAR_SYM), VAR (i, VAR_VALUE)); } return boundlist; } } /* format of lambda-lists is something like, [*] [#!optional *] [#!key *] [#!rest ] A keyword parameter X is associated with an argument by a keyword symbol #:X. If no such symbol exists, it's bound to false and is either or ( ) where is a constant Note that the lambdaList arg isn't protected from gc by this function; it's assumed that this is done by the caller. IMPORTANT: this expects the top of the call stack to have the saved environments in which arguments need to be evaluated */ static repv bind_lambda_list(repv lambdaList, repv argList) { repv *argv; int argc; argc = rep_list_length (argList); argv = alloca (sizeof (repv) * argc); /* Evaluate arguments, and stick them in the evalled_args array */ copy_to_vector (argList, argc, argv); return bind_lambda_list_1 (lambdaList, argv, argc); } static repv eval_lambda(repv lambdaExp, repv argList, repv tail_posn) { repv result; again: result = rep_NULL; lambdaExp = rep_CDR(lambdaExp); if(rep_CONSP(lambdaExp)) { repv boundlist; rep_GC_root gc_lambdaExp, gc_argList; rep_PUSHGC(gc_lambdaExp, lambdaExp); rep_PUSHGC(gc_argList, argList); boundlist = bind_lambda_list(rep_CAR(lambdaExp), argList); rep_POPGC; rep_POPGC; if(boundlist) { /* The body of the function is only in the tail position if the parameter list only creates lexical bindings */ repv new_tail_posn = !rep_SPEC_BINDINGS (boundlist) ? Qt : Qnil; rep_GC_root gc_boundlist; rep_PUSHGC(gc_boundlist, boundlist); result = Fprogn(rep_CDR(lambdaExp), new_tail_posn); rep_POPGC; rep_unbind_symbols(boundlist); if (tail_posn == Qnil && result == rep_NULL && rep_throw_value && rep_CAR (rep_throw_value) == TAIL_CALL_TAG && rep_CONSP (rep_CDR (rep_throw_value))) { /* tail position ends here, so unwrap the saved call */ repv func = rep_CADR (rep_throw_value); repv args = rep_CDDR (rep_throw_value); rep_throw_value = rep_NULL; if (rep_FUNARGP (func) && rep_CONSP (rep_FUNARG (func)->fun) && rep_CAR (rep_FUNARG (func)->fun) == Qlambda) { rep_USE_FUNARG (func); lambdaExp = rep_FUNARG (func)->fun; argList = args; goto again; } else result = rep_apply (func, args); } } else result = rep_NULL; } return result; } DEFSTRING(invl_autoload, "Can only autoload from symbols"); /* Autoloads a value; FUNARG is a closure enclosing the autoload definition. The definition is a list `(autoload SYMBOL FILE ...)' This function tries to load FILE, then returns the value of SYMBOL if successful, or rep_NULL for some kind of error. IMPORTANT: to ensure security, closure FUNARG must be active when this function is called. */ repv rep_load_autoload(repv funarg) { repv aload_def, fun, file, load; if (!rep_FUNARGP(funarg)) { return Fsignal(Qinvalid_autoload, rep_list_2(funarg, rep_VAL(&invl_autoload))); } aload_def = rep_FUNARG(funarg)->fun; if (rep_CONSP(aload_def)) aload_def = rep_CDR(aload_def); if (!rep_CONSP(aload_def) || !rep_SYMBOLP(rep_CAR(aload_def)) || !rep_CONSP(rep_CDR(aload_def)) || !rep_STRINGP(rep_CAR(rep_CDR(aload_def)))) { return Fsignal(Qinvalid_autoload, rep_list_2(aload_def, rep_VAL(&invl_autoload))); } fun = rep_CAR(aload_def); file = rep_CAR(rep_CDR(aload_def)); /* loading a file */ /* Check if the current environment is allowed to load */ load = Fsymbol_value (Qload, Qnil); if (load != rep_NULL) { rep_GC_root gc_fun, gc_funarg; repv tmp; /* trash the autoload defn, so we don't keep trying to autoload indefinitely. */ rep_CDR(aload_def) = Qnil; rep_PUSHGC(gc_funarg, funarg); rep_PUSHGC(gc_fun, fun); /* call through the value instead of just Fload'ing */ tmp = rep_call_lisp2 (load, file, Qt); rep_POPGC; rep_POPGC; if (!tmp) return rep_NULL; fun = Fsymbol_value (fun, Qnil); } else fun = rep_NULL; if (fun != rep_NULL) { /* Magically replace one closure by another without losing eq-ness */ repv tmp = fun; if (rep_CONSP(tmp) && rep_CAR(tmp) == Qmacro) tmp = rep_CDR(tmp); if (rep_FUNARGP(tmp)) { rep_FUNARG(funarg)->fun = rep_FUNARG(tmp)->fun; rep_FUNARG(funarg)->name = rep_FUNARG(tmp)->name; rep_FUNARG(funarg)->env = rep_FUNARG(tmp)->env; rep_FUNARG(funarg)->structure = rep_FUNARG(tmp)->structure; } else rep_FUNARG(funarg)->fun = Qnil; } return fun; } DEFUN ("load-autoload", Fload_autoload, Sload_autoload, (repv def), rep_Subr1) { rep_DECLARE1 (def, rep_FUNARGP); rep_USE_FUNARG(def); return rep_load_autoload (def); } DEFSTRING(max_depth, "max-lisp-depth exceeded, possible infinite recursion?"); static repv apply (repv fun, repv arglist, repv tail_posn) { int type; repv result = rep_NULL; struct rep_Call lc; repv closure = rep_NULL; rep_GC_root gc_fun, gc_args, gc_closure; rep_TEST_INT; if(rep_INTERRUPTP) return rep_NULL; if(++rep_lisp_depth > rep_max_lisp_depth) { rep_lisp_depth--; return Fsignal(Qerror, rep_LIST_1(rep_VAL(&max_depth))); } rep_PUSHGC (gc_fun, fun); rep_PUSHGC (gc_args, arglist); rep_PUSHGC (gc_closure, closure); rep_MAY_YIELD; lc.fun = fun; lc.args = arglist; rep_PUSH_CALL (lc); if(rep_data_after_gc >= rep_gc_threshold) Fgarbage_collect (Qnil); again: if (rep_FUNARGP(fun)) { closure = fun; fun = rep_FUNARG(fun)->fun; } switch(type = rep_TYPE(fun)) { int i, nargs; repv car, argv[5]; case rep_SubrN: if (closure) rep_USE_FUNARG(closure); if (!rep_SUBR_VEC_P (fun)) result = rep_SUBRNFUN(fun)(arglist); else { int length; repv *vec; length = rep_list_length (arglist); vec = alloca (length * sizeof (repv)); copy_to_vector (arglist, length, vec); result = rep_SUBRVFUN (fun) (length, vec); } break; case rep_Subr0: if (closure) rep_USE_FUNARG(closure); result = rep_SUBR0FUN(fun)(); break; case rep_Subr1: nargs = 1; argv[0] = Qnil; goto do_subr; case rep_Subr2: nargs = 2; argv[0] = argv[1] = Qnil; goto do_subr; case rep_Subr3: nargs = 3; argv[0] = argv[1] = argv[2] = Qnil; goto do_subr; case rep_Subr4: nargs = 4; argv[0] = argv[1] = argv[2] = argv[3] = Qnil; goto do_subr; case rep_Subr5: nargs = 5; argv[0] = argv[1] = argv[2] = argv[3] = argv[4] = Qnil; /* FALL THROUGH */ do_subr: for(i = 0; i < nargs; i++) { if(rep_CONSP(arglist)) { argv[i] = rep_CAR(arglist); arglist = rep_CDR(arglist); } else break; } if (closure) rep_USE_FUNARG(closure); switch(type) { case rep_Subr1: result = rep_SUBR1FUN(fun)(argv[0]); break; case rep_Subr2: result = rep_SUBR2FUN(fun)(argv[0], argv[1]); break; case rep_Subr3: result = rep_SUBR3FUN(fun)(argv[0], argv[1], argv[2]); break; case rep_Subr4: result = rep_SUBR4FUN(fun)(argv[0], argv[1], argv[2], argv[3]); break; case rep_Subr5: result = rep_SUBR5FUN(fun)(argv[0], argv[1], argv[2], argv[3], argv[4]); break; } break; case rep_Cons: car = rep_CAR(fun); /* don't allow unclosed lambdas for security reasons */ if(closure && car == Qlambda) { rep_USE_FUNARG (closure); result = eval_lambda (fun, arglist, tail_posn); } else if(closure && car == Qautoload) { rep_USE_FUNARG(closure); fun = rep_load_autoload(closure); if(fun) { lc.fun = fun; goto again; } } else goto invalid; break; case rep_Compiled: /* don't allow unclosed bytecode for security reasons */ if (closure) { int nargs; repv *args; repv (*bc_apply) (repv, int, repv *); rep_USE_FUNARG(closure); bc_apply = rep_STRUCTURE (rep_structure)->apply_bytecode; nargs = rep_list_length (arglist); args = alloca (sizeof (repv) * nargs); copy_to_vector (arglist, nargs, args); if (bc_apply == 0) result = rep_apply_bytecode (fun, nargs, args); else result = bc_apply (fun, nargs, args); break; } /* FALL THROUGH */ default: invalid: Fsignal(Qinvalid_function, rep_LIST_1(lc.fun)); } /* In case I missed a non-local exit somewhere. */ if(rep_throw_value != rep_NULL) result = rep_NULL; if ((result == rep_NULL && rep_throw_value == rep_NULL) || (result != rep_NULL && rep_throw_value != rep_NULL)) { fprintf (stderr, "rep: function returned both exception and value, or neither!\n"); if (lc.fun && Fsubrp (lc.fun) != Qnil && rep_STRINGP (rep_XSUBR (lc.fun)->name)) { fprintf (stderr, "rep: culprit is subr %s\n", rep_STR (rep_XSUBR (lc.fun)->name)); } } rep_POP_CALL(lc); rep_POPGC; rep_POPGC; rep_POPGC; rep_lisp_depth--; return result; } /* Applies ARGLIST to FUN. If EVAL-ARGS is true, all arguments will be evaluated first. Note that both FUN and ARGLIST are gc-protected for the duration of this function. */ repv rep_funcall(repv fun, repv arglist, rep_bool eval_args) { if (eval_args) { rep_GC_root gc_fun; rep_PUSHGC (gc_fun, fun); arglist = eval_list (arglist); rep_POPGC; } return apply (fun, arglist, Qnil); } repv rep_apply (repv fun, repv args) { return apply (fun, args, Qnil); } DEFUN("funcall", Ffuncall, Sfuncall, (repv args), rep_SubrN) /* ::doc:rep.lang.interpreter#funcall:: funcall FUNCTION ARGS... Calls FUNCTION with arguments ARGS... and returns the result. ::end:: */ { if(!rep_CONSP(args)) return rep_signal_missing_arg(1); else return apply(rep_CAR(args), rep_CDR(args), Qnil); } DEFUN("apply", Fapply, Sapply, (repv args), rep_SubrN) /* ::doc:rep.lang.interpreter#apply:: apply FUNCTION ARGS... ARG-LIST Calls FUNCTION passing all of ARGS to it as well as all elements in ARG-LIST. ie, (apply + 1 2 3 '(4 5 6)) => 21 ::end:: */ { repv list = Qnil, *last; last = &list; if(rep_CONSP(args)) { while(rep_CONSP(rep_CDR(args))) { if(!(*last = Fcons(rep_CAR(args), Qnil))) return(rep_NULL); last = &rep_CDR(*last); args = rep_CDR(args); rep_TEST_INT; if(rep_INTERRUPTP) return(rep_NULL); } if(!rep_NILP(Flistp(rep_CAR(args)))) *last = rep_CAR(args); else return rep_signal_arg_error (rep_CAR (args), -1); return(Ffuncall(list)); } return rep_signal_missing_arg(1); } static repv eval(repv obj, repv tail_posn) { switch(rep_TYPE(obj)) { repv ret; case rep_Symbol: if (!rep_KEYWORDP (obj)) return Fsymbol_value(obj, Qnil); else return obj; case rep_Cons: if (++rep_lisp_depth > rep_max_lisp_depth) { rep_lisp_depth--; return Fsignal(Qerror, rep_LIST_1(rep_VAL(&max_depth))); } if (rep_CONSP (rep_CAR (obj)) && rep_CAAR (obj) == Qlambda && Fsymbol_value (Qlambda, Qt) == rep_VAL (&Slambda)) { /* inline lambda; don't need to enclose it.. */ rep_GC_root gc_obj; struct rep_Call lc; rep_PUSHGC (gc_obj, obj); ret = eval_list (rep_CDR (obj)); rep_POPGC; if (ret != rep_NULL) { lc.fun = rep_CAR (obj); lc.args = ret; rep_PUSH_CALL (lc); ret = eval_lambda (rep_CAR (obj), ret, tail_posn); rep_POP_CALL (lc); } } else { repv funcobj; rep_GC_root gc_obj; rep_PUSHGC (gc_obj, obj); funcobj = rep_eval (rep_CAR(obj), Qnil); rep_POPGC; if(funcobj == rep_NULL) ret = rep_NULL; else if(rep_CELL8_TYPEP(funcobj, rep_SF)) ret = rep_SFFUN(funcobj)(rep_CDR(obj), tail_posn); else if(rep_CONSP(funcobj) && rep_CAR(funcobj) == Qmacro) { /* A macro */ repv form; if(rep_single_step_flag && (form = Fsymbol_value(Qdebug_macros, Qt)) && rep_NILP(form)) { /* Debugging macros gets tedious; don't bother when debug-macros is nil. */ rep_single_step_flag = rep_FALSE; form = Fmacroexpand(obj, Qnil); rep_single_step_flag = rep_TRUE; } else form = Fmacroexpand(obj, Qnil); ret = form ? rep_eval (form, tail_posn) : rep_NULL; } else if (tail_posn != Qnil && (rep_FUNARGP (funcobj) || funcobj == rep_VAL (&Sapply))) { /* This call can be performed later without losing any state, so package it up, then throw back to the innermost non-tail-position, where the function call will be evaluated.. */ repv args; rep_PUSHGC (gc_obj, funcobj); args = eval_list (rep_CDR (obj)); rep_POPGC; if (args != rep_NULL) { if (funcobj == rep_VAL (&Sapply)) { if (!rep_CONSP (args)) ret = rep_signal_missing_arg (1); else { int len = rep_list_length (rep_CDR (args)); repv *vec = alloca (len * sizeof (repv)); copy_to_vector (rep_CDR (args), len, vec); rep_CDR (args) = Flist_star (len, vec); } } else args = Fcons (funcobj, args); rep_throw_value = Fcons (TAIL_CALL_TAG, args); } ret = rep_NULL; } else { rep_lisp_depth--; rep_PUSHGC (gc_obj, funcobj); ret = eval_list (rep_CDR (obj)); rep_POPGC; if (ret != rep_NULL) ret = apply (funcobj, ret, tail_posn); return ret; } } rep_lisp_depth--; return ret; default: return obj; } /* not reached */ } repv rep_eval (repv obj, repv tail_posn) { static int DbDepth; rep_bool newssflag = rep_TRUE; repv result; rep_TEST_INT; if(rep_INTERRUPTP) return rep_NULL; if(rep_data_after_gc >= rep_gc_threshold) { rep_GC_root gc_obj; rep_PUSHGC(gc_obj, obj); Fgarbage_collect (Qnil); rep_POPGC; } if(!rep_single_step_flag) return eval(obj, tail_posn); DbDepth++; result = rep_NULL; { repv dbres; repv dbargs = rep_list_3(obj, rep_MAKE_INT(DbDepth), rep_MAKE_INT (current_frame_id ())); if(dbargs) { rep_GC_root gc_dbargs; struct rep_saved_regexp_data re_data; rep_PUSHGC(gc_dbargs, dbargs); rep_push_regexp_data(&re_data); rep_single_step_flag = rep_FALSE; dbres = (rep_call_with_barrier (Ffuncall, Fcons (Fsymbol_value (Qdebug_entry, Qt), dbargs), rep_TRUE, 0, 0, 0)); rep_pop_regexp_data(); if (dbres != rep_NULL && rep_CONSP(dbres)) { switch(rep_INT(rep_CAR(dbres))) { case 1: /* single step cdr and following stuff */ rep_single_step_flag = rep_TRUE; result = eval(rep_CDR(dbres), Qnil); rep_single_step_flag = rep_FALSE; break; case 2: /* run through cdr and step following */ result = eval(rep_CDR(dbres), Qnil); break; case 3: /* run cdr and following */ result = eval(rep_CDR(dbres), Qnil); newssflag = rep_FALSE; break; case 4: /* result = cdr */ rep_single_step_flag = rep_TRUE; result = rep_CDR(dbres); rep_single_step_flag = rep_FALSE; break; } if(result) { rep_push_regexp_data(&re_data); rep_CAR(dbargs) = result; dbres = (rep_call_with_barrier (Ffuncall, Fcons (Fsymbol_value (Qdebug_exit, Qt), dbargs), rep_TRUE, 0, 0, 0)); if(!dbres) result = rep_NULL; rep_pop_regexp_data(); } } rep_POPGC; } } DbDepth--; rep_single_step_flag = newssflag; return result; } repv Feval (repv form) { return rep_eval (form, Qnil); } DEFUN("progn", Fprogn, Sprogn, (repv args, repv tail_posn), rep_SF) /* ::doc:rep.lang.interpreter#progn:: progn FORMS... Eval's each of the FORMS in order returning the value of the last one. ::end:: */ { repv result = Qnil; repv old_current = rep_call_stack != 0 ? rep_call_stack->current_form : 0; rep_GC_root gc_args, gc_old_current; rep_PUSHGC (gc_args, args); rep_PUSHGC (gc_old_current, old_current); while (rep_CONSP (args)) { if (rep_call_stack != 0) rep_call_stack->current_form = rep_CAR (args); result = rep_eval(rep_CAR(args), rep_CDR (args) == Qnil ? tail_posn : Qnil); args = rep_CDR(args); rep_TEST_INT; if(!result || rep_INTERRUPTP) break; } if (rep_call_stack != 0) rep_call_stack->current_form = old_current; rep_POPGC; rep_POPGC; return result; } repv rep_call_lispn (repv fun, int argc, repv *argv) { if (rep_FUNARGP (fun) && rep_COMPILEDP (rep_FUNARG (fun)->fun)) { /* Call to bytecode, avoid consing argument list */ struct rep_Call lc; repv ret; repv (*bc_apply) (repv, int, repv *); lc.fun = fun; lc.args = rep_void_value; rep_PUSH_CALL (lc); rep_USE_FUNARG (fun); bc_apply = rep_STRUCTURE (rep_structure)->apply_bytecode; /* if (bc_apply == 0) */ ret = rep_apply_bytecode (rep_FUNARG (fun)->fun, argc, argv); /* else ret = bc_apply (rep_FUNARG (fun)->fun, argc, argv); */ rep_POP_CALL (lc); return ret; } else { repv args = Qnil; argv += argc; while (argc-- > 0) args = Fcons (*(--argv), args); return rep_funcall (fun, args, rep_FALSE); } } repv rep_call_lisp0(repv function) { return rep_call_lispn (function, 0, 0); } repv rep_call_lisp1(repv function, repv arg1) { return rep_call_lispn (function, 1, &arg1); } repv rep_call_lisp2(repv function, repv arg1, repv arg2) { repv vec[2]; vec[0] = arg1; vec[1] = arg2; return rep_call_lispn (function, 2, vec); } repv rep_call_lisp3(repv function, repv arg1, repv arg2, repv arg3) { repv vec[3]; vec[0] = arg1; vec[1] = arg2; vec[2] = arg3; return rep_call_lispn (function, 3, vec); } repv rep_call_lisp4(repv function, repv arg1, repv arg2, repv arg3, repv arg4) { repv vec[4]; vec[0] = arg1; vec[1] = arg2; vec[2] = arg3; vec[3] = arg4; return rep_call_lispn (function, 4, vec); } void rep_lisp_prin(repv strm, repv obj) { static int print_level = 0; switch(rep_TYPE(obj)) { char tbuf[40]; int j; int print_length; repv tem; case rep_Cons: tem = Fsymbol_value(Qprint_level, Qt); if(tem && rep_INTP(tem) && print_level >= rep_INT(tem)) { rep_stream_puts(strm, "...", 3, rep_FALSE); return; } print_level++; rep_stream_putc(strm, '('); tem = Fsymbol_value(Qprint_length, Qt); print_length = 0; while(rep_CONSP(rep_CDR(obj))) { if(tem && rep_INTP(tem) && print_length >= rep_INT(tem)) { rep_stream_puts(strm, "...", 3, rep_FALSE); goto cons_out; } rep_print_val(strm, rep_CAR(obj)); obj = rep_CDR(obj); rep_stream_putc(strm, ' '); rep_TEST_INT; if(rep_INTERRUPTP) goto cons_out; print_length++; } if(tem && rep_INTP(tem) && print_length >= rep_INT(tem)) rep_stream_puts(strm, "...", 3, rep_FALSE); else { rep_print_val(strm, rep_CAR(obj)); if(!rep_NILP(rep_CDR(obj))) { rep_stream_puts(strm, " . ", -1, rep_FALSE); rep_print_val(strm, rep_CDR(obj)); } } cons_out: rep_stream_putc(strm, ')'); print_level--; break; case rep_Compiled: rep_stream_putc(strm, '#'); /* FALL THROUGH */ case rep_Vector: { int len = rep_VECT_LEN(obj); rep_stream_putc(strm, '['); for(j = 0; j < len; j++) { if(rep_VECT(obj)->array[j]) rep_print_val(strm, rep_VECT(obj)->array[j]); else rep_stream_puts(strm, "#", -1, rep_FALSE); if(j != (len - 1)) rep_stream_putc(strm, ' '); } rep_stream_putc(strm, ']'); break; } case rep_Subr0: case rep_Subr1: case rep_Subr2: case rep_Subr3: case rep_Subr4: case rep_Subr5: case rep_SubrN: #ifdef HAVE_SNPRINTF snprintf(tbuf, sizeof(tbuf), "#", rep_STR(rep_XSUBR(obj)->name)); #else sprintf(tbuf, "#", rep_STR(rep_XSUBR(obj)->name)); #endif rep_stream_puts(strm, tbuf, -1, rep_FALSE); break; case rep_SF: #ifdef HAVE_SNPRINTF snprintf(tbuf, sizeof(tbuf), "#", rep_STR(rep_XSUBR(obj)->name)); #else sprintf(tbuf, "#", rep_STR(rep_XSUBR(obj)->name)); #endif rep_stream_puts(strm, tbuf, -1, rep_FALSE); break; case rep_Funarg: rep_stream_puts (strm, "#name)) { rep_stream_puts (strm, rep_STR(rep_FUNARG(obj)->name), -1, rep_FALSE); } else { #ifdef HAVE_SNPRINTF snprintf (tbuf, sizeof(tbuf), "%" rep_PTR_SIZED_INT_CONV "x", obj); #else sprintf (tbuf, "%" rep_PTR_SIZED_INT_CONV "x", obj); #endif rep_stream_puts (strm, tbuf, -1, rep_FALSE); } rep_stream_putc (strm, '>'); break; case rep_Void: rep_stream_puts(strm, "#", -1, rep_FALSE); break; default: rep_stream_puts(strm, "#", -1, rep_FALSE); } } void rep_string_princ(repv strm, repv obj) { rep_stream_puts(strm, rep_PTR(obj), -1, rep_TRUE); } void rep_string_print(repv strm, repv obj) { int len = rep_STRING_LEN(obj); char *s = rep_STR(obj); char buf[BUFSIZ]; int bufptr = 0; unsigned char c; #define OUT(c) \ do { \ if (bufptr == BUFSIZ) { \ rep_stream_puts (strm, buf, BUFSIZ, rep_FALSE); \ bufptr = 0; \ } \ buf[bufptr++] = (c); \ } while (0) rep_bool escape_all, escape_newlines; repv tem = Fsymbol_value(Qprint_escape, Qt); if(tem == Qnewlines) escape_all = rep_FALSE, escape_newlines = rep_TRUE; else if(tem == Qt) escape_all = rep_TRUE, escape_newlines = rep_TRUE; else escape_all = rep_FALSE, escape_newlines = rep_FALSE; OUT ('"'); while(len-- > 0) { c = *s++; if(escape_all && (c < 32 || c > 126)) { OUT ('\\'); OUT ('0' + c / 64); OUT ('0' + (c % 64) / 8); OUT ('0' + c % 8); } else { switch(c) { case '\t': case '\n': case '\r': case '\f': if(!escape_newlines) OUT (c); else { OUT ('\\'); c = (c == '\t' ? 't' : c == '\n' ? 'n' : c == '\r' ? 'r' : 'f'); OUT (c); } break; case '\\': OUT ('\\'); OUT ('\\'); break; case '"': OUT ('\\'); OUT ('"'); break; default: OUT (c); } } } OUT ('"'); if (bufptr > 0) rep_stream_puts (strm, buf, bufptr, rep_FALSE); } #undef OUT int rep_list_length(repv list) { int i = 0; while(rep_CONSP(list)) { i++; list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) return i; } return i; } repv rep_copy_list(repv list) { repv result; repv *last = &result; while(rep_CONSP(list)) { if(!(*last = Fcons(rep_CAR(list), Qnil))) return rep_NULL; list = rep_CDR(list); last = &rep_CDR(*last); rep_TEST_INT; if(rep_INTERRUPTP) return rep_NULL; } *last = list; return result; } /* FIXME: required by sawfish; remove at some point */ repv Fnconc (repv args) { int len; repv *vec; len = rep_list_length (args); vec = alloca (len * sizeof (repv)); copy_to_vector (args, len, vec); return Fnconc_ (len, vec); } /* Used to assign a list of argument values into separate variables. Note that optional args without values _are not_ initialized to nil, the caller of this function should do that.. */ rep_bool rep_assign_args (repv list, int required, int total, ...) { int i; va_list vars; va_start (vars, total); for (i = 0; i < total; i++) { repv *varp = va_arg (vars, repv *); if (!rep_CONSP (list)) { if (i >= required) return rep_TRUE; else { rep_signal_missing_arg (i); return rep_FALSE; } } *varp = rep_CAR (list); list = rep_CDR (list); rep_TEST_INT; if (rep_INTERRUPTP) return rep_FALSE; } return rep_TRUE; } /* Used for easy handling of `var' objects */ repv rep_handle_var_int(repv val, int *data) { int old = *data; if(rep_INTP(val)) *data = rep_INT(val); return rep_MAKE_INT (old); } /* Similar, but for variables containing greater than 24 bits of data, passed around as a cons cell containing two integers */ repv rep_handle_var_long_int(repv val, long *data) { long old = *data; if(rep_LONG_INTP(val)) *data = rep_LONG_INT(val); return rep_MAKE_LONG_INT(old); } DEFUN("break", Fbreak, Sbreak, (void), rep_Subr0) /* ::doc:rep.lang.debug#break:: break The next form to be evaluated will be done so through the Lisp debugger. ::end:: */ { rep_single_step_flag = rep_TRUE; return Qt; } DEFUN_INT("step", Fstep, Sstep, (repv form), rep_Subr1, "xForm to step through") /* ::doc:rep.lang.debug#step:: step FORM Use the Lisp debugger to evaluate FORM. ::end:: */ { repv res; rep_bool oldssf = rep_single_step_flag; rep_single_step_flag = rep_TRUE; res = rep_eval(form, Qnil); rep_single_step_flag = oldssf; return res; } DEFUN("signal", Fsignal, Ssignal, (repv error, repv data), rep_Subr2) /* ::doc:rep.lang.interpreter#signal:: signal ERROR-SYMBOL DATA Signal that an error has happened. ERROR-SYMBOL is the name of a symbol classifying the type of error, it should have a property `error-message' (a string) with a short description of the error message. DATA is a list of objects which are relevant to the error -- they will be made available to any error-handler or printed by the default error handler. ::end:: */ { repv tmp, errlist, on_error; /* Can only have one error at once. */ if(rep_throw_value) return rep_NULL; rep_DECLARE1(error, rep_SYMBOLP); on_error = Fsymbol_value (Qbacktrace_on_error, Qt); if ((on_error == Qt && error != Qend_of_stream) || (rep_CONSP(on_error) && (tmp = Fmemq (error, on_error)) && tmp != Qnil)) { fprintf (stderr, "\nLisp backtrace:\n"); Fbacktrace (Fstderr_file()); fputs ("\n", stderr); } errlist = Fcons(error, data); on_error = Fsymbol_value(Qdebug_on_error, Qt); if(((on_error != rep_NULL && on_error == Qt && error != Qend_of_stream) || (rep_CONSP(on_error) && (tmp = Fmemq(error, on_error)) && !rep_NILP(tmp)))) { /* Enter debugger. */ rep_GC_root gc_on_error; rep_bool oldssflag = rep_single_step_flag; Fset(Qdebug_on_error, Qnil); rep_single_step_flag = rep_FALSE; rep_PUSHGC(gc_on_error, on_error); tmp = (rep_call_with_barrier (Ffuncall, Fcons (Fsymbol_value (Qdebug_error_entry, Qt), rep_list_2(errlist, rep_MAKE_INT (current_frame_id ()))), rep_TRUE, 0, 0, 0)); rep_POPGC; Fset(Qdebug_on_error, on_error); if(tmp && (tmp == Qt)) rep_single_step_flag = rep_TRUE; else rep_single_step_flag = oldssflag; } rep_throw_value = Fcons(Qerror, errlist); return rep_NULL; } /* For an error rep_ERROR (the cdr of rep_throw_value), if it matches the error handler HANDLER (the car of the handler list), return rep_TRUE. */ rep_bool rep_compare_error(repv error, repv handler) { if(rep_CONSP(error)) { repv error_sym = rep_CAR(error); if(rep_SYMBOLP(handler) && (error_sym == handler || handler == Qerror)) return rep_TRUE; else if(rep_CONSP(handler)) { handler = Fmemq(error_sym, handler); return handler != rep_NULL && !rep_NILP(handler); } } return rep_FALSE; } void rep_handle_error(repv error, repv data) { DEFSTRING (some_error, "some kind of error occurred"); static int mutex; if (mutex++ == 0) { repv fun = Fsymbol_value (Qerror_handler_function, Qt); if (Ffunctionp (fun) != Qnil) { rep_call_lisp2 (fun, error, data); goto out; } } Fbeep(); Fwrite (Qt, rep_VAL (&some_error), Qnil); out: mutex--; } repv rep_signal_arg_error(repv obj, int argNum) { repv fun = rep_call_stack != 0 ? rep_call_stack->fun : Qnil; return Fsignal (Qbad_arg, rep_list_3 (fun, obj, rep_MAKE_INT (argNum))); } repv rep_signal_missing_arg(int argnum) { repv fun = rep_call_stack != 0 ? rep_call_stack->fun : Qnil; return Fsignal (Qmissing_arg, rep_list_2 (fun, rep_MAKE_INT (argnum))); } repv rep_mem_error(void) { #if 0 /* Nothing really checks for this error.. it will just cause crashes.. */ return Fsignal(Qno_memory, Qnil); #else fprintf (stderr, "rep: virtual memory exhausted\n"); abort (); #endif } static int current_frame_id (void) { int i; struct rep_Call *lc; i = 0; for (lc = rep_call_stack; lc != 0; lc = lc->next) i++; return i - 1; } static struct rep_Call * stack_frame_ref (int idx) { struct rep_Call *lc; int total, wanted; total = 0; for (lc = rep_call_stack; lc != 0; lc = lc->next) total++; wanted = (total - 1) - idx; if (wanted < 0) return 0; for (lc = rep_call_stack; lc != 0; lc = lc->next) { if (wanted-- == 0) return lc; } return 0; } DEFUN("backtrace", Fbacktrace, Sbacktrace, (repv strm), rep_Subr1) /* ::doc:rep.lang.debug#backtrace:: backtrace [STREAM] Prints a backtrace of the current Lisp call stack to STREAM (or to `standard-output'). The format is something like: FUNCTION (ARGLIST) ARGS-EVALLED-P where ARGS-EVALLED-P is either `t' or `nil', depending on whether or not ARGLIST had been evaluated or not before being put into the stack. ::end:: */ { repv old_print_escape = Fsymbol_value (Qprint_escape, Qt); int total_frames, i; if(rep_NILP(strm) && !(strm = Fsymbol_value(Qstandard_output, Qnil))) return rep_signal_arg_error (strm, 1); Fset (Qprint_escape, Qt); total_frames = current_frame_id () + 1; i = 0; for (i = total_frames - 1; i >= 0; i--) { struct rep_Call *lc = stack_frame_ref (i); repv function_name = Qnil; if (lc == 0) continue; if (rep_FUNARGP (lc->fun)) { if (rep_STRINGP (rep_FUNARG (lc->fun)->name)) function_name = rep_FUNARG (lc->fun)->name; } else if (Fsubrp (lc->fun) != Qnil) { if (rep_STRINGP (rep_XSUBR (lc->fun)->name)) function_name = rep_XSUBR (lc->fun)->name; } else if (rep_CONSP (lc->fun) && rep_CAR (lc->fun) == Qlambda && rep_CONSP (rep_CDR (lc->fun))) { function_name = rep_list_3 (Qlambda, rep_CADR (lc->fun), Qellipsis); } if (function_name != Qnil) { char buf[16]; sprintf (buf, "#%-3d ", i); rep_stream_puts (strm, buf, -1, rep_FALSE); rep_princ_val (strm, function_name); if (rep_VOIDP (lc->args) || (rep_STRINGP (function_name) && strcmp (rep_STR (function_name), "run-byte-code") == 0)) rep_stream_puts (strm, " ...", -1, rep_FALSE); else { rep_stream_putc (strm, ' '); rep_print_val (strm, lc->args); } if (lc->current_form != rep_NULL) { repv origin = Flexical_origin (lc->current_form); if (origin && origin != Qnil) { char buf[256]; #ifdef HAVE_SNPRINTF snprintf (buf, sizeof (buf), " at %s:%ld", rep_STR (rep_CAR (origin)), (long) rep_INT (rep_CDR (origin))); #else sprintf (buf, " at %s:%ld", rep_STR (rep_CAR (origin)), (long) rep_INT (rep_CDR (origin))); #endif rep_stream_puts (strm, buf, -1, rep_FALSE); } } rep_stream_putc (strm, '\n'); } } Fset (Qprint_escape, old_print_escape); return Qt; } DEFUN ("stack-frame-ref", Fstack_frame_ref, Sstack_frame_ref, (repv idx), rep_Subr1) { struct rep_Call *lc; rep_DECLARE1 (idx, rep_INTP); lc = stack_frame_ref (rep_INT (idx)); if (lc != 0) { return rep_list_5 (lc->fun, rep_VOIDP (lc->args) ? rep_undefined_value : lc->args, lc->current_form ? lc->current_form : Qnil, lc->saved_env, lc->saved_structure); } else return Qnil; } DEFUN("max-lisp-depth", Fmax_lisp_depth, Smax_lisp_depth, (repv val), rep_Subr1) /* ::doc:rep.lang.interpreter#max-lisp-depth:: max-lisp-depth [NEW-VALUE] The maximum number of times that rep_funcall can be called recursively. This is intended to stop infinite recursion, if the default value of 250 is too small (you get errors in normal use) set it to something larger. ::end:: */ { return rep_handle_var_int(val, &rep_max_lisp_depth); } void rep_lisp_init(void) { DEFSTRING (optional, "#!optional"); DEFSTRING (rest, "#!rest"); DEFSTRING (key, "#!key"); repv tem; rep_INTERN(quote); rep_INTERN(lambda); rep_INTERN(macro); rep_INTERN(backquote); rep_INTERN(backquote_unquote); rep_INTERN(backquote_splice); rep_INTERN(autoload); rep_INTERN(function); rep_INTERN(structure_ref); rep_INTERN_SPECIAL(standard_input); rep_INTERN_SPECIAL(standard_output); rep_INTERN_SPECIAL(debug_entry); rep_INTERN_SPECIAL(debug_exit); rep_INTERN_SPECIAL(debug_error_entry); rep_INTERN(amp_optional); rep_INTERN(amp_rest); ex_optional = Fmake_symbol (rep_VAL (&optional)); ex_rest = Fmake_symbol (rep_VAL (&rest)); ex_key = Fmake_symbol (rep_VAL (&key)); rep_SYM(ex_optional)->car |= rep_SF_LITERAL; rep_SYM(ex_rest)->car |= rep_SF_LITERAL; rep_SYM(ex_key)->car |= rep_SF_LITERAL; rep_mark_static (&ex_optional); rep_mark_static (&ex_rest); rep_mark_static (&ex_key); rep_mark_static((repv *)&rep_throw_value); tem = rep_push_structure ("rep.lang.interpreter"); rep_ADD_SUBR(Sload_autoload); rep_ADD_SUBR(Sfuncall); rep_ADD_SUBR(Sapply); rep_ADD_SUBR(Sprogn); rep_ADD_SUBR(Ssignal); rep_ADD_SUBR(Smax_lisp_depth); rep_pop_structure (tem); tem = rep_push_structure ("rep.lang.debug"); rep_ADD_SUBR(Sbreak); rep_ADD_SUBR_INT(Sstep); rep_ADD_SUBR(Sbacktrace); rep_ADD_SUBR(Sstack_frame_ref); rep_pop_structure (tem); /* Stuff for error-handling */ rep_INTERN(error_message); rep_INTERN(error); rep_ERROR(error); rep_INTERN(invalid_function); rep_ERROR(invalid_function); rep_INTERN(void_value); rep_ERROR(void_value); rep_INTERN(bad_arg); rep_ERROR(bad_arg); rep_INTERN(invalid_read_syntax); rep_ERROR(invalid_read_syntax); rep_INTERN(end_of_stream); rep_ERROR(end_of_stream); rep_INTERN(premature_end_of_stream); rep_ERROR(premature_end_of_stream); rep_INTERN(invalid_lambda_list); rep_ERROR(invalid_lambda_list); rep_INTERN(missing_arg); rep_ERROR(missing_arg); rep_INTERN(invalid_macro); rep_ERROR(invalid_macro); rep_INTERN(invalid_autoload); rep_ERROR(invalid_autoload); rep_INTERN(no_catcher); rep_ERROR(no_catcher); rep_INTERN(file_error); rep_ERROR(file_error); rep_INTERN(invalid_stream); rep_ERROR(invalid_stream); rep_INTERN(setting_constant); rep_ERROR(setting_constant); rep_INTERN(process_error); rep_ERROR(process_error); rep_INTERN(no_memory); rep_ERROR(no_memory); rep_INTERN(user_interrupt); rep_ERROR(user_interrupt); rep_INTERN(arith_error); rep_ERROR(arith_error); rep_INTERN(term_interrupt); rep_INTERN_SPECIAL(debug_on_error); Fset (Qdebug_on_error, Qnil); rep_INTERN_SPECIAL(backtrace_on_error); Fset (Qbacktrace_on_error, Qnil); rep_INTERN_SPECIAL(debug_macros); Fset (Qdebug_macros, Qnil); rep_INTERN_SPECIAL(error_handler_function); rep_int_cell = Fcons(Quser_interrupt, Qnil); rep_mark_static(&rep_int_cell); rep_term_cell = Fcons(Qterm_interrupt, Qnil); rep_mark_static(&rep_term_cell); rep_INTERN_SPECIAL(print_escape); rep_INTERN_SPECIAL(print_length); rep_INTERN_SPECIAL(print_level); Fset (Qprint_escape, Qnil); Fset (Qprint_length, Qnil); Fset (Qprint_level, Qnil); rep_INTERN(newlines); rep_INTERN(load); rep_INTERN(require); rep_INTERN(ellipsis); /* Allow the bootstrap code to work.. */ rep_STRUCTURE (rep_default_structure)->imports = Fcons (Qrep_lang_interpreter, rep_STRUCTURE (rep_default_structure)->imports); } librep-0.90.2/src/librep.sym0000644000175200017520000002535211245011153014663 0ustar chrischrisF_define F_structure_ref Faccept_process_output Faccept_process_output_1 Faccess_structures Facos Factive_processes Fall_threads Falpha_char_p Falphanumericp Fappend Fapply Fapropos Faref Farrayp Faset Fash Fasin Fassoc Fassq Fatan Fatom Fbacktrace Fbeep Fbinding_immutable_p Fboundp Fbreak Fbytecodep Fcall_cc Fcall_hook Fcall_process Fcall_with_barrier Fcall_with_dynamic_root Fcall_with_exception_handler Fcall_with_object Fcanonical_file_name Fcar Fcdr Fceiling Fchar_downcase Fchar_upcase Fclose_file Fclosure_function Fclosure_name Fclosure_structure Fclosurep Fcomplete_string Fconcat Fcond Fcons Fconsp Fcontinuation_callable_p Fcontinue_process Fcopy_file Fcopy_sequence Fcopy_stream Fcos Fcurrent_structure Fcurrent_thread Fcurrent_time Fcurrent_time_string Fcurrent_utime Fdatum_ref Fdatum_set Fdefault_boundp Fdefault_value Fdefine_datum_printer Fdefvar Fdelete Fdelete_directory Fdelete_file Fdelete_if Fdelete_if_not Fdelq Fdenominator Fdigit_char_p Fdirectory_file_name Fdirectory_files Fdivide Felt Feq Feql Fequal Feval Fexact_to_inexact Fexactp Fexp Fexpand_file_name Fexpand_last_match Fexport_binding Fexport_bindings Fexpt Fexternal_structure_ref Ffeaturep Ffile_binding Ffile_bound_stream Ffile_directory_p Ffile_exists_p Ffile_handler_data Ffile_modes Ffile_modes_as_string Ffile_modtime Ffile_name_absolute_p Ffile_name_as_directory Ffile_name_directory Ffile_name_nondirectory Ffile_nlinks Ffile_owner_p Ffile_readable_p Ffile_regular_p Ffile_size Ffile_symlink_p Ffile_writable_p Ffilep Ffilter Ffind_symbol Ffix_time Ffixnump Ffloor Ffluid Ffluid_set Fflush_file Fformat Ffuncall Ffunctionp Fgarbage_collect Fgarbage_threshold Fgcd Fgensym Fget Fget_command_line_option Fget_output_stream_string Fget_structure Fgethan Fgtthan Fhas_type_p Fidle_garbage_threshold Finexact_to_exact Finput_stream_p Fintegerp Fintern Fintern_structure Fintern_symbol Finterrupt_process Fkeywordp Fkill_process Flambda Flast Flength Flethan Flist Flist_star Flistp Fload Fload_autoload Fload_dl_file Fload_file Flocal_file_name Flog Flogand Flogior Flognot Flogxor Flower_case_p Fltthan Fmacroexpand Fmacroexpand_1 Fmacrop Fmake_binding_immutable Fmake_byte_code_subr Fmake_closure Fmake_datum Fmake_directory Fmake_file_from_stream Fmake_fluid Fmake_keyword Fmake_list Fmake_obarray Fmake_primitive_guardian Fmake_process Fmake_string Fmake_string_input_stream Fmake_string_output_stream Fmake_structure Fmake_symbol Fmake_symlink Fmake_temp_name Fmake_thread Fmake_variable_special Fmake_vector Fmakunbound Fmapc Fmapcar Fmatch_end Fmatch_start Fmax Fmax_lisp_depth Fmember Fmemq Fmemql Fmessage Fmin Fminus Fmod Fname_structure Fnconc Fnot Fnreverse Fnth Fnthcdr Fnull Fnum_eq Fnum_noteq Fnumber_to_string Fnumberp Fnumerator Fobarray Fopen_file Fopen_structures Foutput_stream_p Fpeek_char Fplus Fplus1 Fprimitive_guardian_pop Fprimitive_guardian_push Fprimitive_invoke_continuation Fprin1 Fprinc Fprint Fprocess_args Fprocess_connection_type Fprocess_dir Fprocess_error_stream Fprocess_exit_status Fprocess_exit_value Fprocess_function Fprocess_id Fprocess_in_use_p Fprocess_output_stream Fprocess_prog Fprocess_running_p Fprocess_stopped_p Fprocessp Fproduct Fprogn Fprovide Fput Fquote Fquote_regexp Fquotient Fraise_exception Frandom Frassoc Frassq Fread Fread_char Fread_chars Fread_line Fread_symlink Freal_eval Freal_set Frecursion_depth Frecursive_edit Fregexp_cache_control Fremainder Frename_file Frequire Freverse Fround Frplaca Frplacd Frun_byte_code Fseek_file Fsequencep Fset Fset_closure_function Fset_closure_structure Fset_default Fset_file_handler_data Fset_file_handler_environment Fset_file_modes Fset_input_handler Fset_interface Fset_process_args Fset_process_connection_type Fset_process_dir Fset_process_error_stream Fset_process_function Fset_process_output_stream Fset_process_prog Fset_special_environment Fsetplist Fsetq Fsignal Fsignal_process Fsin Fsit_for Fsleep_for Fspace_char_p Fspecial_form_p Fspecial_variable_p Fsqrt Fstart_process Fstderr_file Fstdin_file Fstdout_file Fstep Fstop_process Fstring_equal Fstring_head_eq Fstring_lessp Fstring_looking_at Fstring_match Fstring_to_number Fstringp Fstructure_accessible Fstructure_bound_p Fstructure_define Fstructure_exports_all Fstructure_exports_p Fstructure_file Fstructure_imports Fstructure_install_vm Fstructure_interface Fstructure_name Fstructure_set Fstructure_set_binds Fstructure_walk Fstructurep Fsub1 Fsubr_name Fsubrp Fsubstring Fsymbol_name Fsymbol_plist Fsymbol_value Fsymbolp Fsystem Fsystem_name Ftan Fthread_delete Fthread_exited_p Fthread_forbid Fthread_join Fthread_name Fthread_permit Fthread_suspend Fthread_suspended_p Fthread_wake Fthread_yield Fthreadp Fthrow Ftime_later_p Ftrace Ftranslate_string Ftruncate Funintern Funtrace Fupper_case_p Fuser_full_name Fuser_home_directory Fuser_login_name Fvalidate_byte_code Fvector Fvectorp Fwith_fluids Fwrite Fzerop Q_load_suffixes Q_meta Q_specials Q_structures Q_user_structure_ Qafter_gc_hook Qafter_load_alist Qamp_optional Qamp_rest Qand Qappend Qarith_error Qautoload Qbackquote Qbackquote_splice Qbackquote_unquote Qbacktrace_on_error Qbad_arg Qbatch_mode Qbefore_exit_hook Qbytecode_error Qcanonical_file_name Qclose_file Qcommand_line_args Qcontinuation Qcopy_file Qcopy_file_from_local_fs Qcopy_file_to_local_fs Qdebug_entry Qdebug_error_entry Qdebug_exit Qdebug_macros Qdebug_on_error Qdefault_directory Qdelete_directory Qdelete_file Qdirectory_file_name Qdirectory_files Qdl_load_path Qdl_load_reloc_now Qdocumentation Qdocumentation_file Qdocumentation_files Qdowncase_table Qend Qend_of_stream Qerror Qerror_handler_function Qerror_message Qerror_mode Qexec_directory Qexit Qexpand_file_name Qexternal Qfeatures Qfh_env_key Qfile_directory_p Qfile_error Qfile_exists_p Qfile_handler_alist Qfile_modes Qfile_modes_as_string Qfile_modtime Qfile_name_absolute_p Qfile_name_as_directory Qfile_name_directory Qfile_name_nondirectory Qfile_nlinks Qfile_owner_p Qfile_readable_p Qfile_regular_p Qfile_size Qfile_symlink_p Qfile_writable_p Qflatten_table Qfluid Qflush_file Qformat_hooks_alist Qfunction Qidle_hook Qinterpreted_mode Qinterrupt_mode Qinvalid_autoload Qinvalid_function Qinvalid_lambda_list Qinvalid_macro Qinvalid_read_syntax Qinvalid_stream Qlambda Qlisp_lib_directory Qload Qload_filename Qload_path Qlocal Qlocal_file_name Qmacro Qmacro_environment Qmake_directory Qmake_symlink Qmissing_arg Qnewlines Qnil Qno_catcher Qno_memory Qopen_file Qoperating_system Qor Qpermanent_local Qpipe Qprint_escape Qprint_length Qprint_level Qprocess_environment Qprocess_error Qprogram_name Qprovide Qpty Qquit Qquote Qread Qread_symlink Qregexp_error Qrename_file Qrep Qrep_build_id Qrep_directory Qrep_interface_id Qrep_io_file_handlers Qrep_lang_interpreter Qrep_structures Qrep_version Qrep_vm_interpreter Qrequire Qseek_file Qset_file_modes Qsetting_constant Qsite_lisp_directory Qsocketpair Qstandard_input Qstandard_output Qstart Qstructure_ref Qt Qterm_interrupt Qtop_level Qunix Qupcase_table Quser_interrupt Qvoid_value Qwrite rep_accept_input rep_accept_input_for_callbacks rep_accept_input_for_fds rep_add_binding_to_env rep_add_event_loop_callback rep_add_subr rep_alias_structure rep_allocate_cons rep_apply rep_assign_args rep_beep_fun rep_bind_special rep_bind_symbol rep_bootstrap_structure rep_box_pointer rep_box_string rep_call_file_handler rep_call_lisp0 rep_call_lisp1 rep_call_lisp2 rep_call_lisp3 rep_call_lisp4 rep_call_lispn rep_call_stack rep_call_with_barrier rep_call_with_closure rep_common_db rep_compare_error rep_compare_numbers rep_compile_regexp rep_concat2 rep_concat3 rep_concat4 rep_cons_free rep_cons_freelist rep_copy_list rep_data_after_gc rep_db_alloc rep_db_free rep_db_kill rep_db_print_backtrace rep_db_printf rep_db_return_address rep_db_spew rep_db_spew_all rep_db_vprintf rep_default_regsub rep_default_regsublen rep_default_structure rep_deprecated rep_deref_local_symbol_fun rep_deregister_input_fd rep_deregister_input_fd_fun rep_documentation_property rep_env rep_eol_datum rep_eval rep_event_loop rep_event_loop_fun rep_expand_and_get_handler rep_file_fdopen rep_file_length rep_file_type rep_find_c_symbol rep_find_dl_symbol rep_foldl rep_funcall rep_gc_n_roots_stack rep_gc_root_stack rep_gc_threshold rep_get_data_type rep_get_file_handler rep_get_float rep_get_handler_from_file_or_name rep_get_initial_special_value rep_get_long_int rep_get_long_uint rep_get_longlong_int rep_get_option rep_guardian_type rep_handle_error rep_handle_input_exception rep_handle_var_int rep_handle_var_long_int rep_idle_gc_threshold rep_in_gc rep_init rep_init_from_dump rep_input_timeout_secs rep_int_cell rep_integer_foldl rep_integer_gcd rep_intern_dl_library rep_intern_static rep_keyword_obarray rep_kill rep_lisp_depth rep_list_1 rep_list_2 rep_list_3 rep_list_4 rep_list_5 rep_list_length rep_load_autoload rep_load_environment rep_localise_and_get_handler rep_lookup_dl_symbol rep_lookup_errno rep_make_float rep_make_long_int rep_make_long_uint rep_make_longlong_int rep_make_string rep_make_tuple rep_make_vector rep_map_inputs rep_mark_input_pending rep_mark_static rep_mark_tuple rep_mark_value rep_max_lisp_depth rep_max_sleep_for rep_mem_error rep_message_fun rep_null_string rep_number_add rep_number_div rep_number_foldl rep_number_logand rep_number_logior rep_number_lognot rep_number_logxor rep_number_max rep_number_min rep_number_mul rep_number_neg rep_number_sub rep_obarray rep_on_idle rep_on_idle_fun rep_on_termination_fun rep_op_insert_file_contents rep_op_read_file_contents rep_op_write_buffer_contents rep_parse_number rep_pending_thread_yield rep_poll_input rep_pop_regexp_data rep_pop_structure rep_princ_val rep_print_number_to_string rep_print_val rep_proc_periodically rep_ptr_cmp rep_push_regexp_data rep_push_structure rep_push_structure_name rep_readl rep_recurse_depth rep_redisplay_fun rep_regcomp rep_regerror rep_regexec2 rep_regexp_max_depth rep_register_input_fd rep_register_input_fd_fun rep_register_new_type rep_register_process_input_handler rep_register_type rep_regmatch_string rep_regsub_fun rep_regsublen_fun rep_scm_f rep_scm_t rep_search_imports rep_set_local_symbol_fun rep_set_string_len rep_set_string_match rep_sig_restart rep_sigchld_fun rep_signal_arg_error rep_signal_file_error rep_signal_missing_arg rep_sit_for rep_sleep_for rep_special_bindings rep_str_dupn rep_stream_getc rep_stream_putc rep_stream_puts rep_stream_read_esc rep_stream_ungetc rep_string_dup rep_string_dupn rep_string_modified rep_structure rep_structure_exports_all rep_structure_set_binds rep_structure_type rep_term_cell rep_test_int_counter rep_test_int_fun rep_test_int_period rep_thread_lock rep_throw_value rep_time rep_top_level_exit rep_top_level_recursive_edit rep_type_cmp rep_unbind_symbols rep_unbound_file_error rep_unbox_pointer rep_undefined_value rep_unix_set_fd_blocking rep_unix_set_fd_cloexec rep_unix_set_fd_nonblocking rep_update_last_match rep_used_cons rep_utime rep_value_cmp rep_void_value rep_wait_for_input_fun librep-0.90.2/src/gh.c0000644000175200017520000003337011245011153013415 0ustar chrischris/* gh.c -- Guile Helper compat functions Copyright (C) 2003 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* The GH interface to guile is deprecated, and this is only a partial implementation, but it may be useful. E.g. it made it easier to get SWIG working with rep.. */ #define _GNU_SOURCE #include "rep_gh.h" #include "repint.h" #include #define UNIMP \ do { \ static int warned; \ if (!warned) \ { \ fprintf (stderr, "%s: unimplemented", __FUNCTION__); \ warned = 1; \ } \ } while (0) #define UNIMP_RET UNIMP; return rep_undefined_value void gh_enter(int argc, char *argv[], void (*c_main_prog)(int, char **)) { UNIMP; } void gh_repl(int argc, char *argv[]) { UNIMP; } repv gh_catch(repv tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) { UNIMP_RET; } repv gh_standard_handler(void *data, repv tag, repv throw_args) { UNIMP_RET; } repv gh_eval_str(const char *scheme_code) { UNIMP_RET; } repv gh_eval_str_with_catch(const char *scheme_code, scm_t_catch_handler handler) { UNIMP_RET; } repv gh_eval_str_with_standard_handler(const char *scheme_code) { UNIMP_RET; } repv gh_eval_str_with_stack_saving_handler(const char *scheme_code) { UNIMP_RET; } repv gh_eval_file(const char *fname) { UNIMP_RET; } repv gh_eval_file_with_catch(const char *scheme_code, scm_t_catch_handler handler) { UNIMP_RET; } repv gh_eval_file_with_standard_handler(const char *scheme_code) { UNIMP_RET; } repv gh_new_procedure(const char *proc_name, repv (*fn)(), int n_required_args, int n_optional_args, int varp) { UNIMP_RET; } repv gh_new_procedure0_0(const char *proc_name, repv (*fn)(void)) { return gh_new_procedure (proc_name, fn, 0, 0, 0); } repv gh_new_procedure0_1(const char *proc_name, repv (*fn)(repv)) { return gh_new_procedure (proc_name, fn, 0, 1, 0); } repv gh_new_procedure0_2(const char *proc_name, repv (*fn)(repv, repv)) { return gh_new_procedure (proc_name, fn, 0, 2, 0); } repv gh_new_procedure1_0(const char *proc_name, repv (*fn)(repv)) { return gh_new_procedure (proc_name, fn, 1, 0, 0); } repv gh_new_procedure1_1(const char *proc_name, repv (*fn)(repv, repv)) { return gh_new_procedure (proc_name, fn, 1, 1, 0); } repv gh_new_procedure1_2(const char *proc_name, repv (*fn)(repv, repv, repv)) { return gh_new_procedure (proc_name, fn, 1, 2, 0); } repv gh_new_procedure2_0(const char *proc_name, repv (*fn)(repv, repv)) { return gh_new_procedure (proc_name, fn, 2, 0, 0); } repv gh_new_procedure2_1(const char *proc_name, repv (*fn)(repv, repv, repv)) { return gh_new_procedure (proc_name, fn, 2, 1, 0); } repv gh_new_procedure2_2(const char *proc_name, repv (*fn)(repv, repv, repv, repv)) { return gh_new_procedure (proc_name, fn, 2, 2, 0); } repv gh_new_procedure3_0(const char *proc_name, repv (*fn)(repv, repv, repv)) { return gh_new_procedure (proc_name, fn, 3, 0, 0); } repv gh_new_procedure4_0(const char *proc_name, repv (*fn)(repv, repv, repv, repv)) { return gh_new_procedure (proc_name, fn, 4, 0, 0); } repv gh_new_procedure5_0(const char *proc_name, repv (*fn)(repv, repv, repv, repv, repv)) { return gh_new_procedure (proc_name, fn, 5, 0, 0); } /* C to Scheme conversion */ repv gh_bool2scm(int x) { return x ? Qt : Qnil; } repv gh_int2scm(int x) { return rep_make_long_int (x); } repv gh_ulong2scm(unsigned long x) { return rep_make_long_uint (x); } repv gh_long2scm(long x) { return rep_make_long_int (x); } repv gh_double2scm(double x) { return rep_make_float (x, rep_FALSE); } repv gh_char2scm(char c) { return rep_MAKE_INT (c); } repv gh_str2scm(const char *s, size_t len) { return rep_string_dupn (s, len); } repv gh_str02scm(const char *s) { return rep_string_dup (s); } void gh_set_substr(char *src, repv dst, long start, size_t len) { UNIMP; } repv gh_symbol2scm(const char *symbol_str) { return Fintern (rep_string_dup (symbol_str), Qnil); } repv gh_ints2scm(const int *d, long n) { int i; repv vec; vec = rep_make_vector (n); for (i = 0; i < n; i++) rep_VECTI (vec, i) = rep_make_long_int (d[i]); return vec; } repv gh_doubles2scm(const double *d, long n) { int i; repv vec; vec = rep_make_vector (n); for (i = 0; i < n; i++) rep_VECTI (vec, i) = rep_make_float (d[i], rep_FALSE); return vec; } /* Scheme to C conversion */ int gh_scm2bool(repv obj) { return obj != Qnil; } int gh_scm2int(repv obj) { return rep_get_long_int (obj); } unsigned long gh_scm2ulong(repv obj) { return rep_get_long_uint (obj); } long gh_scm2long(repv obj) { return rep_get_long_int (obj); } char gh_scm2char(repv obj) { return rep_INTP (obj) && rep_INT (obj); } double gh_scm2double(repv obj) { return rep_get_float (obj); } char *gh_scm2newstr(repv str, size_t *lenp) { char *buf; size_t len; if (!rep_STRINGP (str)) return NULL; len = rep_STRING_LEN (str); buf = malloc (len + 1); memcpy (buf, rep_STR (str), len); buf[len] = 0; if (lenp != NULL) *lenp = len; return buf; } void gh_get_substr(repv src, char *dst, long start, size_t len) { if (!rep_STRING (src) || rep_STRING_LEN (src) <= start) return; len = MIN (len, rep_STRING_LEN (src) - start); memcpy (dst, rep_STR (src) + start, len); } char *gh_symbol2newstr(repv sym, size_t *lenp) { if (!rep_SYMBOLP (sym)) return NULL; return gh_scm2newstr (rep_SYM (sym)->name, lenp); } char *gh_scm2chars(repv vector, char *result) { int len = gh_length (vector), i; if (len == 0) return result; if (result == NULL) result = malloc (len * sizeof (result[0])); for (i = 0; i < len; i++) result[i] = gh_scm2char (Felt (vector, rep_MAKE_INT (i))); return result; } short *gh_scm2shorts(repv vector, short *result) { int len = gh_length (vector), i; if (len == 0) return result; if (result == NULL) result = malloc (len * sizeof (result[0])); for (i = 0; i < len; i++) result[i] = rep_get_long_int (Felt (vector, rep_MAKE_INT (i))); return result; } long *gh_scm2longs(repv vector, long *result) { int len = gh_length (vector), i; if (len == 0) return result; if (result == NULL) result = malloc (len * sizeof (result[0])); for (i = 0; i < len; i++) result[i] = rep_get_long_int (Felt (vector, rep_MAKE_INT (i))); return result; } float *gh_scm2floats(repv vector, float *result) { int len = gh_length (vector), i; if (len == 0) return result; if (result == NULL) result = malloc (len * sizeof (result[0])); for (i = 0; i < len; i++) result[i] = rep_get_float (Felt (vector, rep_MAKE_INT (i))); return result; } double *gh_scm2doubles(repv vector, double *result) { int len = gh_length (vector), i; if (len == 0) return result; if (result == NULL) result = malloc (len * sizeof (result[0])); for (i = 0; i < len; i++) result[i] = rep_get_float (Felt (vector, rep_MAKE_INT (i))); return result; } /* type predicates: tell you if an repv object has a given type */ int gh_boolean_p(repv val) { return Qt; } int gh_symbol_p(repv val) { return rep_SYMBOLP (val); } int gh_char_p(repv val) { return rep_INTP (val); } int gh_vector_p(repv val) { return rep_VECTORP (val); } int gh_pair_p(repv val) { return rep_CONSP (val); } int gh_number_p(repv val) { return rep_NUMERICP (val); } int gh_string_p(repv val) { return rep_STRINGP (val); } int gh_procedure_p(repv val) { val = Ffunctionp (val); return val && val != Qnil; } int gh_list_p(repv val) { return rep_LISTP (val); } int gh_inexact_p(repv val) { val = Fexactp (val); return val && val == Qnil; } int gh_exact_p(repv val) { val = Fexactp (val); return val && val != Qnil; } /* more predicates */ int gh_eq_p(repv x, repv y) { return x == y; } int gh_eqv_p(repv x, repv y) { repv val = Feql (x, y); return val && val != Qnil; } int gh_equal_p(repv x, repv y) { repv val = Fequal (x, y); return val && val != Qnil; } int gh_string_equal_p(repv s1, repv s2) { return rep_STRINGP (s1) && rep_STRINGP (s2) && gh_equal_p (s1, s2); } int gh_null_p(repv l) { return l == Qnil; } /* standard Scheme procedures available from C */ repv gh_not(repv val) { return val == Qnil ? Qt : Qnil; } repv gh_define(const char *name, repv val) { UNIMP_RET; } /* string manipulation routines */ repv gh_make_string(repv k, repv chr) { return Fmake_string (k, chr); } repv gh_string_length(repv str) { return Flength (str); } repv gh_string_ref(repv str, repv k) { return Faref (str, k); } repv gh_string_set_x(repv str, repv k, repv chr) { return Faset (str, k, chr); } repv gh_substring(repv str, repv start, repv end) { return Fsubstring (str, start, end); } #define APPLY_LIST(lst,fun) \ int n = gh_length (lst), i; \ repv *v = NULL; \ if (n != 0) { \ v = alloca (sizeof (repv) * n); \ for (i = 0; i < n; i++) { \ v[i] = rep_CAR (lst); \ lst = rep_CDR (lst); \ } \ } \ return fun (n, v) repv gh_string_append(repv args) { APPLY_LIST (args, Fconcat); } repv gh_vector(repv ls) { APPLY_LIST (ls, Fvector); } repv gh_make_vector(repv length, repv val) { return Fmake_vector (length, val); } repv gh_vector_set_x(repv vec, repv pos, repv val) { return Faset (vec, pos, val); } repv gh_vector_ref(repv vec, repv pos) { return Faref (vec, pos); } unsigned long gh_vector_length (repv v) { return gh_length (v); } unsigned long gh_uniform_vector_length (repv v) { UNIMP; return 0; } repv gh_uniform_vector_ref (repv v, repv ilist) { UNIMP_RET; } #define gh_list_to_vector(ls) gh_vector(ls) repv gh_vector_to_list(repv v) { UNIMP_RET; } repv gh_lookup (const char *sname) { UNIMP_RET; } repv gh_module_lookup (repv module, const char *sname) { UNIMP_RET; } repv gh_cons(repv x, repv y) { return Fcons (x, y); } repv gh_list(repv elt, ...) { repv lst = Qnil; va_list args; va_start (args, elt); while (elt != rep_undefined_value) { lst = Fcons (elt, lst); elt = va_arg (args, repv); } va_end (args); return Fnreverse (lst); } unsigned long gh_length(repv l) { repv len = Flength (l); return len && rep_INTP (len) ? rep_INT (len) : 0; } repv gh_append(repv args) { APPLY_LIST (args, Fappend); } repv gh_append2(repv l1, repv l2) { repv v[2]; v[0] = l1; v[1] = l2; return Fappend (2, v); } repv gh_append3(repv l1, repv l2, repv l3) { repv v[3]; v[0] = l1; v[1] = l2; v[2] = l3; return Fappend (3, v); } repv gh_append4(repv l1, repv l2, repv l3, repv l4) { repv v[4]; v[0] = l1; v[1] = l2; v[2] = l3; v[3] = l4; return Fappend (4, v); } repv gh_reverse(repv ls) { return Freverse (ls); } repv gh_list_tail(repv ls, repv k) { return Fnthcdr (k, ls); } repv gh_list_ref(repv ls, repv k) { return Fnth (k, ls); } repv gh_memq(repv x, repv ls) { return Fmemq (x, ls); } repv gh_memv(repv x, repv ls) { return Fmemql (x, ls); } repv gh_member(repv x, repv ls) { return Fmember (x, ls); } repv gh_assq(repv x, repv alist) { return Fassq (x, alist); } repv gh_assv(repv x, repv alist) { UNIMP_RET; } repv gh_assoc(repv x, repv alist) { return Fassoc (x, alist); } repv gh_car(repv x) { return rep_CONSP (x) ? rep_CAR (x) : rep_undefined_value; } repv gh_cdr(repv x) { return rep_CONSP (x) ? rep_CDR (x) : rep_undefined_value; } repv gh_caar(repv x) { return gh_car (gh_car (x)); } repv gh_cadr(repv x) { return gh_car (gh_cdr (x)); } repv gh_cdar(repv x) { return gh_cdr (gh_car (x)); } repv gh_cddr(repv x) { return gh_cdr (gh_cdr (x)); } repv gh_caaar(repv x) { return gh_car (gh_car (gh_car (x))); } repv gh_caadr(repv x) { return gh_car (gh_car (gh_cdr (x))); } repv gh_cadar(repv x) { return gh_car (gh_cdr (gh_car (x))); } repv gh_caddr(repv x) { return gh_car (gh_cdr (gh_cdr (x))); } repv gh_cdaar(repv x) { return gh_cdr (gh_car (gh_car (x))); } repv gh_cdadr(repv x) { return gh_cdr (gh_car (gh_cdr (x))); } repv gh_cddar(repv x) { return gh_cdr (gh_cdr (gh_car (x))); } repv gh_cdddr(repv x) { return gh_cdr (gh_cdr (gh_cdr (x))); } repv gh_set_car_x(repv pair, repv value) { return Frplaca (pair, value) ? value : rep_undefined_value; } repv gh_set_cdr_x(repv pair, repv value) { return Frplacd (pair, value) ? value : rep_undefined_value; } /* Calling Scheme functions from C. */ repv gh_apply (repv proc, repv ls) { return Ffuncall (Fcons (proc, ls)); } repv gh_call0 (repv proc) { return rep_call_lisp0 (proc); } repv gh_call1 (repv proc, repv arg) { return rep_call_lisp1 (proc, arg); } repv gh_call2 (repv proc, repv arg1, repv arg2) { return rep_call_lisp2 (proc, arg1, arg2); } repv gh_call3 (repv proc, repv arg1, repv arg2, repv arg3) { return rep_call_lisp3 (proc, arg1, arg2, arg3); } /* reading and writing Scheme objects. */ void gh_display (repv x) { UNIMP; } void gh_write (repv x) { UNIMP; } void gh_newline (void) { UNIMP; } librep-0.90.2/src/gettext.c0000644000175200017520000000677511245011153014514 0ustar chrischris/* gettext.c -- wrap some i18n functions when available Copyright (C) 1999 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include #include #ifdef LIBC_GETTEXT # ifdef HAVE_LIBINTL_H # include # endif # define gnu_gettext gettext # define gnu_textdomain textdomain # define gnu_bindtextdomain bindtextdomain # define gnu_bind_textdomain_codeset bind_textdomain_codeset #else # define gnu_gettext gettext__ # define gnu_textdomain textdomain__ # define gnu_bindtextdomain bindtextdomain__ # ifdef FIXME_SOMEONE_PLEASE # define gnu_bind_textdomain_codeset bind_textdomain_codeset__ # endif extern char *gnu_gettext (const char *msgid); extern char *gnu_textdomain (const char *domainname); extern char *gnu_bindtextdomain (const char *domainname, const char *dirname); extern char *gnu_bind_textdomain_codeset (const char *domainname, const char *codeset); #endif DEFUN("gettext", Fgettext, Sgettext, (repv in), rep_Subr1) { char *out; rep_DECLARE1(in, rep_STRINGP); out = gnu_gettext (rep_STR(in)); if (out == 0 || (char *) out == rep_STR(in)) return in; else return rep_string_dup (out); } DEFUN("bindtextdomain", Fbindtextdomain, Sbindtextdomain, (repv dom, repv dir), rep_Subr2) { char *domainname = 0, *dirname = 0, *out; if (rep_STRINGP(dom)) domainname = rep_STR(dom); if (rep_STRINGP(dir)) dirname = rep_STR(dir); out = gnu_bindtextdomain (domainname, dirname); return out ? rep_string_dup (out) : Qnil; } DEFUN("bindtextdomaincodeset", Fbindtextdomaincodeset, Sbindtextdomaincodeset, (repv dom, repv cod), rep_Subr2) { char *domainname = 0, *codeset = 0, *out; if (rep_STRINGP(dom)) domainname = rep_STR(dom); if (rep_STRINGP(cod)) codeset = rep_STR(cod); #ifdef gnu_bind_textdomain_codeset out = gnu_bind_textdomain_codeset (domainname, codeset); #else out = NULL; #endif return out ? rep_string_dup (out) : Qnil; } DEFUN("textdomain", Ftextdomain, Stextdomain, (repv dom), rep_Subr1) { char *domainname = 0, *out; if (rep_STRINGP(dom)) domainname = rep_STR(dom); out = gnu_textdomain (domainname); return out ? rep_string_dup (out) : Qnil; } /* DL hooks */ DEFSTRING(underscore, "_"); repv rep_dl_init(void) { repv tem = rep_push_structure ("rep.i18n.gettext"), ret; /* ::alias:gettext rep.i18n.gettext:: */ rep_alias_structure ("gettext"); rep_ADD_SUBR(Sgettext); rep_ADD_SUBR(Sbindtextdomain); rep_ADD_SUBR(Sbindtextdomaincodeset); rep_ADD_SUBR(Stextdomain); ret = rep_pop_structure (tem); /* Update binding of `_' in `rep' structure to point at the gettext function */ tem = rep_push_structure ("rep"); Fset (Fintern (rep_VAL (&underscore), Qnil), rep_VAL (&Sgettext)); rep_pop_structure (tem); return ret; } librep-0.90.2/src/getpagesize.h0000644000175200017520000000175611245011153015336 0ustar chrischris/* Emulate getpagesize on systems that lack it. */ #ifndef HAVE_GETPAGESIZE # ifdef VMS # define getpagesize() 512 # endif # ifdef HAVE_UNISTD_H # include # endif # ifdef _SC_PAGESIZE # define getpagesize() sysconf(_SC_PAGESIZE) # else /* no _SC_PAGESIZE */ # ifdef HAVE_SYS_PARAM_H # include # ifdef EXEC_PAGESIZE # define getpagesize() EXEC_PAGESIZE # else /* no EXEC_PAGESIZE */ # ifdef NBPG # define getpagesize() NBPG * CLSIZE # ifndef CLSIZE # define CLSIZE 1 # endif /* no CLSIZE */ # else /* no NBPG */ # ifdef NBPC # define getpagesize() NBPC # else /* no NBPC */ # ifdef PAGESIZE # define getpagesize() PAGESIZE # endif /* PAGESIZE */ # endif /* no NBPC */ # endif /* no NBPG */ # endif /* no EXEC_PAGESIZE */ # else /* no HAVE_SYS_PARAM_H */ # define getpagesize() 8192 /* punt totally */ # endif /* no HAVE_SYS_PARAM_H */ # endif /* no _SC_PAGESIZE */ #endif /* no HAVE_GETPAGESIZE */ librep-0.90.2/src/fluids.c0000644000175200017520000001023411245011153014277 0ustar chrischris/* fluids.c -- anonymous dynamic bindings Copyright (C) 2000 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "repint.h" DEFSYM (fluid, "fluid"); /* XXX give fluids their own distinct type..? */ #define FLUIDP(x) rep_CONSP(x) #define FLUID_GLOBAL_VALUE(x) rep_CDR(x) /* from symbols.c */ static inline repv inlined_search_special_bindings (repv sym) { register repv env; for (env = rep_special_bindings; env != Qnil; env = rep_CDR (env)) { if (rep_CAAR(env) == sym) return rep_CAR (env); } return Qnil; } static repv search_special_bindings (repv sym) { return inlined_search_special_bindings (sym); } DEFUN ("make-fluid", Fmake_fluid, Smake_fluid, (repv value), rep_Subr1) /* ::doc:rep.lang.interpreter#make-fluid:: make-fluid [VALUE] Create and return an object representing a `fluid' value--an anonymous dynamically bound variable. If VALUE is defined the initial value of the fluid is VALUE, otherwise it is the symbol `nil'. ::end:: */ { return Fcons (Qfluid, value); } /* hardcoded in lispmach.c */ DEFUN ("fluid", Ffluid, Sfluid, (repv f), rep_Subr1) /* ::doc:rep.lang.interpreter#fluid:: fluid FLUID Return the value of the most recently created binding of the fluid variable object FLUID. ::end:: */ { repv tem; rep_DECLARE1(f, FLUIDP); tem = search_special_bindings (f); if (tem != Qnil) return rep_CDR (tem); else return FLUID_GLOBAL_VALUE (f); } /* hardcoded in lispmach.c */ DEFUN ("fluid-set", Ffluid_set, Sfluid_set, (repv f, repv v), rep_Subr2) /* ::doc:rep.lang.interpreter#fluid-set:: fluid-set FLUID VALUE Set the value of the most recently created binding of the fluid variable object FLUID to VALUE. ::end:: */ { repv tem; rep_DECLARE1(f, FLUIDP); tem = search_special_bindings (f); if (tem != Qnil) rep_CDR (tem) = v; else FLUID_GLOBAL_VALUE (f) = v; return v; } DEFUN ("with-fluids", Fwith_fluids, Swith_fluids, (repv fluids, repv values, repv thunk), rep_Subr3) /* ::doc:rep.lang.interpreter#with-fluids:: with-fluids FLUIDS VALUES THUNK Call THUNK and return the value that it returns with new bindings created for each of the fluid variables specified in the list FLUIDS. For each member of FLUIDS the corresponding member of the VALUES list provides the initial value of the new binding. If the lists FLUIDS and VALUES are not of the same length, an error is signalled. ::end:: */ { repv ret; repv old_bindings; rep_GC_root gc_old_bindings; rep_DECLARE (1, fluids, rep_LISTP (fluids)); rep_DECLARE (2, values, rep_LISTP (values)); rep_DECLARE (2, values, rep_list_length (fluids) == rep_list_length (values)); old_bindings = rep_special_bindings; while (rep_CONSP (fluids) && rep_CONSP (values)) { repv f = rep_CAR (fluids), v = rep_CAR (values); rep_DECLARE (1, f, FLUIDP (f)); rep_special_bindings = Fcons (Fcons (f, v), rep_special_bindings); fluids = rep_CDR (fluids); values = rep_CDR (values); rep_TEST_INT; if (rep_INTERRUPTP) { rep_special_bindings = old_bindings; return rep_NULL; } } rep_PUSHGC (gc_old_bindings, old_bindings); ret = rep_call_lisp0 (thunk); rep_POPGC; rep_special_bindings = old_bindings; return ret; } void rep_fluids_init (void) { repv tem = rep_push_structure ("rep.lang.interpreter"); rep_INTERN (fluid); rep_ADD_SUBR (Smake_fluid); rep_ADD_SUBR (Sfluid); rep_ADD_SUBR (Sfluid_set); rep_ADD_SUBR (Swith_fluids); rep_pop_structure (tem); } librep-0.90.2/src/find.c0000644000175200017520000003405411245011153013737 0ustar chrischris/* find.c -- Searching and replacing Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #include #include #include #include /* Hooks for dealing with the rep_reg_obj match type. */ void (*rep_regsub_fun)(int, rep_regsubs *, char *, char *, void *); int (*rep_regsublen_fun)(int, rep_regsubs *, char *, void *); /* Compiling regexps. */ /* A linked list is used to store all recently-used regexps in MRU order. At GC the regexps at the tail of the list are freed to satisfy the size limit. It might be better to use a hash-table. But by experience it seems that the cache is usually quite small, and therefore searching the list each compilation isn't too bad (and it makes the gc easier). Also, the hit-ratio is very good (as I'm typing this, ~0.97) */ struct cached_regexp { struct cached_regexp *next; repv regexp; rep_regexp *compiled; }; static struct cached_regexp *cached_regexps; /* should be a hash table? */ static int regexp_hits, regexp_misses; static int regexp_cache_limit = 1024; DEFSYM(regexp_error, "regexp-error"); DEFSTRING(err_regexp_error, "Regexp error"); rep_regexp * rep_compile_regexp(repv re) { struct cached_regexp **x = &cached_regexps; int re_len; assert(rep_STRINGP(re)); re_len = rep_STRING_LEN(re); while(*x != 0) { repv saved_re = (*x)->regexp; assert(rep_STRINGP(saved_re)); if(saved_re == re || (rep_STRING_LEN(saved_re) == re_len && memcmp(rep_STR(saved_re), rep_STR(re), re_len) == 0)) { /* Found it. Move this node to the head of the list. Then return the compiled copy. */ struct cached_regexp *this = *x; if(x != &cached_regexps) { *x = this->next; this->next = cached_regexps; cached_regexps = this; } regexp_hits++; return this->compiled; } x = &((*x)->next); } /* No cached copy. Compile it, then add it to the cache. */ { struct cached_regexp *this; rep_regexp *compiled = rep_regcomp(rep_STR(re)); if(compiled != 0) { this = rep_alloc(sizeof(struct cached_regexp)); if(this != 0) { this->regexp = re; this->compiled = compiled; this->next = cached_regexps; cached_regexps = this; regexp_misses++; rep_data_after_gc += (sizeof(struct cached_regexp) + compiled->regsize); return compiled; } } return 0; } } /* Remove any cached compilation of STRING from the regexp cache */ void rep_string_modified (repv string) { struct cached_regexp **x; for (x = &cached_regexps; *x != 0; x = &((*x)->next)) { if ((*x)->regexp == string) { /* found the string, remove it from the cache */ struct cached_regexp *ptr = *x; *x = ptr->next; free (ptr->compiled); rep_free (ptr); } } } /* Called at GC */ static void mark_cached_regexps(void) { unsigned long total = 0; struct cached_regexp *x = cached_regexps, *xp = 0; while(x != 0 && total < regexp_cache_limit) { assert(rep_STRINGP(x->regexp)); rep_MARKVAL(x->regexp); total += sizeof(struct cached_regexp) + x->compiled->regsize; xp = x; x = x->next; } if(xp != 0) { /* Free all following regexps */ x = xp->next; xp->next = 0; while(x != 0) { xp = x->next; free(x->compiled); rep_free(x); x = xp; } } } /* Free all cached regexps */ static void release_cached_regexps(void) { struct cached_regexp *x = cached_regexps; cached_regexps = 0; while(x != 0) { struct cached_regexp *next = x->next; free(x->compiled); rep_free(x); x = next; } } /* Storing regexp context. */ /* Storage for remembering where the last match was. last_match_data is the string or buffer that was matched against. last_matches is a copy of the subexpression data of the last match. */ static rep_regtype last_match_type; static repv last_match_data; static rep_regsubs last_matches; struct rep_saved_regexp_data *rep_saved_matches; void rep_update_last_match(repv data, rep_regexp *prog) { last_match_type = prog->lasttype; last_match_data = data; memcpy(&last_matches, &prog->matches, sizeof(last_matches)); } /* Called by GC */ void rep_mark_regexp_data(void) { struct rep_saved_regexp_data *sd; /* Don't keep too many cached REs through GC. */ mark_cached_regexps(); if(last_match_type == rep_reg_obj) { int i; for(i = 0; i < rep_NSUBEXP; i++) { rep_MARKVAL(last_matches.obj.startp[i]); rep_MARKVAL(last_matches.obj.endp[i]); } } rep_MARKVAL(last_match_data); for(sd = rep_saved_matches; sd != 0; sd = sd->next) { if(sd->type == rep_reg_obj) { int i; for(i = 0; i < rep_NSUBEXP; i++) { rep_MARKVAL(sd->matches.obj.startp[i]); rep_MARKVAL(sd->matches.obj.endp[i]); } } rep_MARKVAL(sd->data); } } /* Fix the match buffers to reflect matching a string from START to END. */ void rep_set_string_match(repv obj, repv start, repv end) { int i; last_match_data = obj; last_match_type = rep_reg_obj; last_matches.obj.startp[0] = start; last_matches.obj.endp[0] = end; for(i = 1; i < rep_NSUBEXP; i++) { last_matches.obj.startp[i] = rep_NULL; last_matches.obj.endp[i] = rep_NULL; } } void rep_push_regexp_data(struct rep_saved_regexp_data *sd) { sd->type = last_match_type; sd->data = last_match_data; memcpy(&sd->matches, &last_matches, sizeof(rep_regsubs)); sd->next = rep_saved_matches; rep_saved_matches = sd; } void rep_pop_regexp_data(void) { struct rep_saved_regexp_data *sd = rep_saved_matches; rep_saved_matches = sd->next; last_match_type = sd->type; last_match_data = sd->data; memcpy(&last_matches, &sd->matches, sizeof(rep_regsubs)); } /* Simple string matching */ DEFUN("string-match", Fstring_match, Sstring_match, (repv re, repv str, repv start, repv nocasep), rep_Subr4) /* ::doc:rep.regexp#string-match:: string-match REGEXP STRING [START] [IGNORE-CASE-P] Return t if REGEXP matches STRING. Updates the match data. When defined, START is the index of the first character to start matching at (counting from zero). When IGNORE-CASE-P is non-nil the case of matched strings are ignored. Note that character classes are still case-significant. ::end:: */ { rep_regexp *prog; long xstart; rep_DECLARE1(re, rep_STRINGP); rep_DECLARE2(str, rep_STRINGP); rep_DECLARE3_OPT(start, rep_INTP); xstart = rep_INTP(start) ? rep_INT(start) : 0; prog = rep_compile_regexp(re); if(prog) { repv res; if(rep_regexec2(prog, rep_STR(str) + xstart, (rep_NILP(nocasep) ? 0 : rep_REG_NOCASE) | (xstart == 0 ? 0 : rep_REG_NOTBOL))) { rep_update_last_match(str, prog); res = Qt; } else res = Qnil; return(res); } return rep_NULL; } DEFUN("string-looking-at", Fstring_looking_at, Sstring_looking_at, (repv re, repv string, repv start, repv nocasep), rep_Subr4) /* ::doc:rep.regexp#string-looking-at:: string-looking-at REGEXP STRING [START] [IGNORE-CASE-P] Returns t if REGEXP matches the STRING (starting at character START). Updates the match data. ::end:: */ { rep_regexp *prog; long xstart; rep_DECLARE1(re, rep_STRINGP); rep_DECLARE2(string, rep_STRINGP); rep_DECLARE3_OPT(start, rep_INTP); xstart = rep_INTP(start) ? rep_INT(start) : 0; prog = rep_compile_regexp(re); if(prog != NULL) { repv res; if(rep_regmatch_string(prog, rep_STR(string) + xstart, (rep_NILP(nocasep) ? 0 : rep_REG_NOCASE) | (xstart == 0 ? 0 : rep_REG_NOTBOL))) { rep_update_last_match(string, prog); res = Qt; } else res = Qnil; return res; } return rep_NULL; } DEFUN("expand-last-match", Fexpand_last_match, Sexpand_last_match, (repv template), rep_Subr1) /* ::doc:rep.regexp#expand-last-match:: expand-last-match TEMPLATE-STRING Expand the saved expressions from the most recent successfully matched regexp according to TEMPLATE-STRING, a string that may contain any of the following escape sequences, \0, \& whole string matched by REGEXP \N N'th parenthensized expression (1 <= N <= 9) ::end:: */ { long len; repv string; rep_DECLARE1(template, rep_STRINGP); len = (*rep_regsublen_fun)(last_match_type, &last_matches, rep_STR(template), rep_PTR(last_match_data)); string = rep_make_string(len); (*rep_regsub_fun)(last_match_type, &last_matches, rep_STR(template), rep_STR(string), rep_PTR(last_match_data)); return string; } DEFUN("match-start", Fmatch_start, Smatch_start, (repv exp), rep_Subr1) /* ::doc:rep.regexp#match-start:: match-start [EXPRESSION-INDEX] Return the position which the EXPRESSION-INDEX'th parenthesised expression started at in the last successful regexp match. If EXPRESSION-INDEX is nil or 0 the start of the whole match is returned instead. The returned value will either be a position if the last match was in a buffer, or an integer if the last match was in a string (i.e. regexp-match). ::end:: */ { long i; rep_DECLARE1_OPT(exp, rep_INTP); if(rep_INTP(exp)) { i = rep_INT(exp); if((i >= rep_NSUBEXP) || (i < 0)) return(rep_signal_arg_error(exp, 1)); } else i = 0; if(last_match_type == rep_reg_obj) { if(last_matches.obj.startp[i] != rep_NULL) return last_matches.obj.startp[i]; return Qnil; } else { if(last_matches.string.startp[i] == NULL) return(Qnil); i = last_matches.string.startp[i] - (char *)rep_STR(last_match_data); return(rep_MAKE_INT(i)); } } DEFUN("match-end", Fmatch_end, Smatch_end, (repv exp), rep_Subr1) /* ::doc:rep.regexp#match-end:: match-end [EXPRESSION-INDEX] Return the position which the EXPRESSION-INDEX'th parenthesised expression ended at in the last successful regexp match. If EXPRESSION-INDEX is nil or 0 the end of the whole match is returned instead. The returned value will either be a position if the last match was in a buffer, or an integer if the last match was in a string (i.e. regexp-match). ::end:: */ { long i; rep_DECLARE1_OPT(exp, rep_INTP); if(rep_INTP(exp)) { i = rep_INT(exp); if((i >= rep_NSUBEXP) || (i < 0)) return rep_signal_arg_error(exp, 1); } else i = 0; if(last_match_type == rep_reg_obj) { if(last_matches.obj.endp[i] != rep_NULL) return last_matches.obj.endp[i]; return Qnil; } else { if(last_matches.string.endp[i] == NULL) return(Qnil); i = last_matches.string.endp[i] - (char *)rep_STR(last_match_data); return(rep_MAKE_INT(i)); } } DEFUN("quote-regexp", Fquote_regexp, Squote_regexp, (repv str), rep_Subr1) /* ::doc:rep.regexp#quote-regexp:: quote-regexp STRING Returns a new version of STRING, any characters which the regexp routines treat specially (asterisks, square brackets, etc...) is quoted by the escape character `\'. If the STRING does not contain any regexp meta-characters it is returned as-is (un-copied). ::end:: */ { char *buf, *s; int buflen = 128, slen, i = 0; rep_bool quoted = rep_FALSE; repv res = rep_NULL; rep_DECLARE1(str, rep_STRINGP); s = rep_STR(str); slen = rep_STRING_LEN(str); buf = rep_alloc(buflen); if(!buf) goto error; while(slen-- > 0) { char c; /* Ensure string is long enough, this saves doing this twice. */ if(i + 2 >= buflen) { int newlen = buflen * 2; char *newbuf = rep_alloc(newlen); if(!newbuf) goto error; memcpy(newbuf, buf, i); rep_free(buf); buf = newbuf; buflen = newlen; } switch(c = *s++) { case '*': case '+': case '?': case '.': case '[': case ']': case '(': case ')': case '|': case '^': case '$': case '\\': /* do I want to do this? */ /* quote this character */ buf[i++] = '\\'; buf[i++] = c; quoted = rep_TRUE; break; default: buf[i++] = c; break; } } if(!quoted) res = str; else res = rep_string_dupn(buf, i); error: if(buf) rep_free(buf); return(res); } DEFUN("regexp-cache-control", Fregexp_cache_control, Sregexp_cache_control, (repv limit), rep_Subr1) /* ::doc:rep.regexp#regexp-cache-control:: regexp-cache-control [SOFT-LIMIT] If SOFT-LIMIT is defined, it specifies the maximum number of bytes that the regexp cache may occupy after garbage collection. Returns (SOFT-LIMIT CURRENT-SIZE CURRENT-ENTRIES HITS MISSES). ::end:: */ { int current_size = 0, current_items = 0; struct cached_regexp *x; rep_DECLARE1_OPT(limit, rep_INTP); if(rep_INTP(limit) && rep_INT(limit) >= 0) regexp_cache_limit = rep_INT(limit); x = cached_regexps; while(x != 0) { current_items++; current_size += sizeof(struct cached_regexp) + x->compiled->regsize; x = x->next; } return rep_list_5(rep_MAKE_INT(regexp_cache_limit), rep_MAKE_INT(current_size), rep_MAKE_INT(current_items), rep_MAKE_INT(regexp_hits), rep_MAKE_INT(regexp_misses)); } void rep_regerror(char *err) { Fsignal(Qregexp_error, rep_LIST_1(rep_string_dup(err))); } void rep_find_init(void) { repv tem = rep_push_structure ("rep.regexp"); rep_ADD_SUBR(Sstring_match); rep_ADD_SUBR(Sstring_looking_at); rep_ADD_SUBR(Sexpand_last_match); rep_ADD_SUBR(Smatch_start); rep_ADD_SUBR(Smatch_end); rep_ADD_SUBR(Squote_regexp); rep_ADD_SUBR(Sregexp_cache_control); rep_pop_structure (tem); rep_INTERN(regexp_error); rep_ERROR(regexp_error); rep_regsub_fun = rep_default_regsub; rep_regsublen_fun = rep_default_regsublen; } void rep_find_kill(void) { release_cached_regexps(); } librep-0.90.2/src/files.c0000644000175200017520000013731311245011153014123 0ustar chrischris/* files.c -- Extendable file handling Copyright (C) 1998 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #include #include #include #ifdef NEED_MEMORY_H # include #endif #ifdef HAVE_UNISTD_H # include #endif #ifndef DEV_SLASH_NULL # define DEV_SLASH_NULL "/dev/null" #endif /* List of operations. If there's a file handler defined for the file being manipulated it will be called to execute the operation. (file-name-absolute-p NAME) (expand-file-name NAME) (local-file-name NAME) (canonical-file-name NAME) (file-name-nondirectory NAME) (file-name-directory NAME) (file-name-as-directory NAME) (directory-file-name NAME) (open-file NAME ACCESS-TYPE) (close-file FILE) (flush-file FILE) (seek-file FILE [OFFSET] [WHENCE]) [ XXX these are for jade only, must be defined later.. ] (write-buffer-contents FILE-OR-NAME START END) (read-file-contents FILE-OR-NAME) (insert-file-contents FILE-OR-NAME) (delete-file NAME) (rename-file OLD-NAME NEW-NAME) (copy-file SOURCE DEST) (copy-file-to-local-fs SOURCE LOCAL-DEST) (copy-file-from-local-fs LOCAL-SOURCE DEST) (make-directory NAME) (delete-directory NAME) (file-exists-p NAME) (file-regular-p NAME) (file-readable-p NAME) (file-writable-p NAME) (file-directory-p NAME) (file-symlink-p NAME) (file-owner-p NAME) (file-nlinks NAME) (file-size NAME) (file-modes NAME) (file-modes-as-string NAME) (set-file-modes NAME MODES) (file-modtime NAME) (directory-files NAME) (read-symlink NAME) (make-symlink NAME CONTENTS) ACCESS-TYPE is one of `read', `write' or `append'. WHENCE is one off `nil', `start', `end'. */ DEFSYM(file_handler_alist, "file-handler-alist"); /* ::doc:file-handler-alist:: a list of `(REGEXP . HANDLER)'. If REGEXP matches the name of a file being manipulated the function HANDLER is called as (HANDLER OPERATION ARGS...) where ARGS matches how the original function is called. ::end:: */ DEFSYM(default_directory, "default-directory"); /* ::doc:default-directory:: Buffer-local variable absolutely defining the directory to which all files accessed in the buffer are resolved from (unless they're absolute.) ::end:: */ /* List of all allocated file objects */ static rep_file *file_list; int rep_file_type; DEFSYM(file_name_absolute_p, "file-name-absolute-p"); DEFSYM(expand_file_name, "expand-file-name"); DEFSYM(local_file_name, "local-file-name"); DEFSYM(canonical_file_name, "canonical-file-name"); DEFSYM(file_name_nondirectory, "file-name-nondirectory"); DEFSYM(file_name_directory, "file-name-directory"); DEFSYM(file_name_as_directory, "file-name-as-directory"); DEFSYM(directory_file_name, "directory-file-name"); DEFSYM(open_file, "open-file"); DEFSYM(close_file, "close-file"); DEFSYM(flush_file, "flush-file"); DEFSYM(seek_file, "seek-file"); DEFSYM(delete_file, "delete-file"); DEFSYM(rename_file, "rename-file"); DEFSYM(make_directory, "make-directory"); DEFSYM(delete_directory, "delete-directory"); DEFSYM(copy_file, "copy-file"); DEFSYM(copy_file_to_local_fs, "copy-file-to-local-fs"); DEFSYM(copy_file_from_local_fs, "copy-file-from-local-fs"); DEFSYM(file_readable_p, "file-readable-p"); DEFSYM(file_writable_p, "file-writable-p"); DEFSYM(file_exists_p, "file-exists-p"); DEFSYM(file_regular_p, "file-regular-p"); DEFSYM(file_directory_p, "file-directory-p"); DEFSYM(file_symlink_p, "file-symlink-p"); DEFSYM(file_owner_p, "file-owner-p"); DEFSYM(file_nlinks, "file-nlinks"); DEFSYM(file_size, "file-size"); DEFSYM(file_modes, "file-modes"); DEFSYM(set_file_modes, "set-file-modes"); DEFSYM(file_modes_as_string, "file-modes-as-string"); DEFSYM(file_modtime, "file-modtime"); DEFSYM(directory_files, "directory-files"); DEFSYM(read_symlink, "read-symlink"); DEFSYM(make_symlink, "make-symlink"); DEFSYM(start, "start"); DEFSYM(end, "end"); DEFSYM(read, "read"); DEFSYM(write, "write"); DEFSYM(append, "append"); DEFSYM(fh_env_key, "fh-env-key"); /* Vector of blocked operations */ struct blocked_op *rep_blocked_ops[op_MAX]; int rep_op_write_buffer_contents = op_write_buffer_contents; int rep_op_read_file_contents = op_read_file_contents; int rep_op_insert_file_contents = op_insert_file_contents; DEFSYM (rep_io_file_handlers, "rep.io.file-handlers"); static inline repv get_fh_env (void) { repv ret = F_structure_ref (rep_structure, Qfh_env_key); return rep_VOIDP (ret) ? Qt : ret; } /* this is duplicated in rep/io/file-handlers.jl */ static inline repv file_handler_ref (repv handler) { repv tem = Fget_structure (Qrep_io_file_handlers); if (tem != Qnil) { tem = F_structure_ref (tem, handler); if (!tem || rep_VOIDP (tem)) tem = Qnil; } return tem; } repv rep_signal_file_error(repv cdr) { repv data = Fcons(rep_lookup_errno(), Qnil); if(cdr) { if(rep_CONSP(cdr) || rep_NILP(cdr)) rep_CDR(data) = cdr; else rep_CDR(data) = Fcons(cdr, Qnil); } return Fsignal(Qfile_error, data); } DEFSTRING(unbound_file, "File is unbound"); repv rep_unbound_file_error(repv file) { return rep_signal_file_error(rep_list_2(rep_VAL(&unbound_file), file)); } /* Note that this function never returns rep_NULL. It preserves the regexp match data throughout. */ repv rep_get_file_handler(repv file_name, int op) { repv list = Fsymbol_value(Qfile_handler_alist, Qt); struct rep_saved_regexp_data matches; if(!list) return Qnil; rep_DECLARE1(file_name, rep_STRINGP); rep_push_regexp_data(&matches); while(rep_CONSP(list) && rep_CONSP(rep_CAR(list))) { repv tem = Fstring_match(rep_CAR(rep_CAR(list)), file_name, Qnil, Qnil); if(tem && !rep_NILP(tem)) { /* Check that this operation isn't already active. */ struct blocked_op *ptr = rep_blocked_ops[op]; repv handler = rep_CDR(rep_CAR(list)); while(ptr != 0 && ptr->handler != handler) ptr = ptr->next; if(ptr == 0) { rep_pop_regexp_data(); return handler; } } list = rep_CDR(list); rep_TEST_INT; if(rep_INTERRUPTP) break; } rep_pop_regexp_data(); return Qnil; } /* Call the file handler function HANDLER, for file operation OP/SYM. Pass NARGS arguments to it (each a lisp object). Note that for the duration of the call, all args and HANDLER will be gc-protected, and the the regexp match data is preserved. */ repv rep_call_file_handler(repv handler, int op, repv sym, int nargs, ...) { struct blocked_op op_data; struct rep_saved_regexp_data matches; repv arg_list = Qnil; repv *ptr = &arg_list; repv res; int i; va_list args; va_start(args, nargs); for(i = 0; i < nargs; i++) { *ptr = Fcons((repv)va_arg(args, repv), Qnil); ptr = &rep_CDR(*ptr); } va_end(args); arg_list = Fcons(sym, arg_list); /* before it gets dereferenced */ op_data.handler = handler; if (rep_SYMBOLP(handler)) { repv fh_env = get_fh_env (); if (fh_env == Qt) handler = file_handler_ref (handler); else { repv tem = Fassq (handler, fh_env); if (tem && rep_CONSP(tem)) { if (rep_CDR(tem) == Qt) handler = file_handler_ref (handler); else if (rep_FUNARGP(rep_CDR(tem))) handler = rep_CDR(tem); } } } if (handler != rep_NULL && !rep_VOIDP (handler)) { rep_push_regexp_data(&matches); op_data.next = rep_blocked_ops[op]; rep_blocked_ops[op] = &op_data; /* handler and arg_list are automatically protected by rep_funcall */ res = rep_funcall(handler, arg_list, rep_FALSE); rep_blocked_ops[op] = op_data.next; rep_pop_regexp_data(); } else res = rep_NULL; return res; } /* *rep_FILEP may be an opened file, or the name of a file. Returns the handler to call, or nil if no handler exists, or rep_NULL if an error occurred. Expands *rep_FILEP to its canonical form, leaving this value in *rep_FILEP. */ repv rep_get_handler_from_file_or_name(repv *filep, int op) { repv file = *filep, handler; if(!rep_FILEP(file) && !rep_STRINGP(file)) return rep_signal_arg_error(file, 1); if(rep_FILEP(file)) { if(rep_NILP(rep_FILE(file)->name)) return rep_unbound_file_error(file); handler = rep_FILE(file)->handler; if(handler == Qt) handler = Qnil; } else { file = Fexpand_file_name(file, Qnil); if(file) { *filep = file; handler = rep_get_file_handler(file, op); } else handler = Qnil; } return handler; } /* Expand *FILE-NAME leaving the result in *FILE-NAME, and find its handler for OP. Return the handler or nil. */ repv rep_expand_and_get_handler(repv *file_namep, int op) { repv file_name = *file_namep, handler; rep_DECLARE1(file_name, rep_STRINGP); file_name = Fexpand_file_name(file_name, Qnil); if(!file_name) return rep_NULL; handler = rep_get_file_handler(file_name, op); *file_namep = file_name; return handler; } /* Similar to above, but also tries to make file name local to the underlying fs if at all possible. */ repv rep_localise_and_get_handler(repv *file_namep, int op) { repv file_name = *file_namep, handler; rep_DECLARE1(file_name, rep_STRINGP); file_name = Flocal_file_name(file_name); if(!file_name) return rep_NULL; if(rep_NILP(file_name)) { file_name = Fexpand_file_name(*file_namep, Qnil); if(!file_name) return rep_NULL; } handler = rep_get_file_handler(file_name, op); *file_namep = file_name; return handler; } /* File name handling */ DEFUN("file-name-absolute-p", Ffile_name_absolute_p, Sfile_name_absolute_p, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-name-absolute-p:: file-name-absolute-p FILE-NAME Returns t if FILE-NAME is context-independent, i.e. it does not name a file relative to the default-directory. ::end:: */ { repv handler; rep_DECLARE1(file, rep_STRINGP); handler = rep_get_file_handler(file, op_file_name_absolute_p); if(rep_NILP(handler)) return rep_file_name_absolute_p(file); else return rep_call_file_handler(handler, op_file_name_absolute_p, Qfile_name_absolute_p, 1, file); } DEFUN("expand-file-name", Fexpand_file_name, Sexpand_file_name, (repv file_name, repv dir_name), rep_Subr2) /* ::doc:rep.io.files#expand-file-name:: expand-file-name FILE-NAME [BASE-DIR] Expands FILE-NAME assuming that it specifies a file relative to BASE-DIR. If BASE-DIR is undefined it is taken as the current value of the `default-directory' variable. While expanding the file name, any obvious simplifications will be performed (e.g. on Unix the removal of "." and ".." where possible). Note that the returned file name will only be absolute if one of the following conditions is met: 1. BASE-DIR (or `default-directory') is absolute 2. FILE-NAME is already absolute. Note for file handler implementors: when a handler is called for the `expand-file-name' operation, it will only ever receive one argument, the already expanded file name. The only action that may be need to be taken is to simplify the file name (e.g. removing "." and ".." entries or whatever). ::end:: */ { repv abs, handler; rep_GC_root gc_file_name, gc_dir_name; rep_DECLARE1(file_name, rep_STRINGP); rep_PUSHGC(gc_file_name, file_name); rep_PUSHGC(gc_dir_name, dir_name); abs = Ffile_name_absolute_p(file_name); if(!abs) { rep_POPGC; rep_POPGC; return rep_NULL; } else if(rep_NILP(abs)) { /* Not absolute, tack on DIR */ if(!rep_STRINGP(dir_name)) dir_name = Fsymbol_value(Qdefault_directory, Qt); if(rep_VOIDP(dir_name)) dir_name = Qnil; dir_name = Ffile_name_as_directory(dir_name); if(dir_name && rep_STRINGP(dir_name) && rep_STRING_LEN(dir_name) > 0) file_name = rep_concat2(rep_STR(dir_name), rep_STR(file_name)); } rep_POPGC; rep_POPGC; if(!file_name) return rep_NULL; /* Now simplify FILE-NAME. */ handler = rep_get_file_handler(file_name, op_expand_file_name); if(rep_NILP(handler)) return rep_expand_file_name(file_name); else return rep_call_file_handler(handler, op_expand_file_name, Qexpand_file_name, 1, file_name); } DEFUN("local-file-name", Flocal_file_name, Slocal_file_name, (repv file), rep_Subr1) /* ::doc:rep.io.files#local-file-name:: local-file-name FILE-NAME When possible, return a string absolutely naming the file in the local file system that FILE-NAME refers to. If FILE-NAME does not refer to a file in the local system, return nil. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_local_file_name); if(!handler) return rep_NULL; if(rep_NILP(handler)) /* Assume that it's already a local file. */ return file; else return rep_call_file_handler(handler, op_local_file_name, Qlocal_file_name, 1, file); } DEFUN("canonical-file-name", Fcanonical_file_name, Scanonical_file_name, (repv file), rep_Subr1) /* ::doc:rep.io.files#canonical-file-name:: canonical-file-name FILE-NAME Return the canonical name of the file called FILE-NAME. The canonical name of a file is defined such that two files can be compared simply by comparing their canonical names; if the names match, they refer to the same file. (Note that the opposite isn't always true, if two canonical names don't match the file could still be the same, for example via links. On most operating systems, symbolic links will be expanded where possible.) ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_canonical_file_name); if(!handler) return rep_NULL; if(rep_NILP(handler)) return rep_canonical_file_name(file); else return rep_call_file_handler(handler, op_canonical_file_name, Qcanonical_file_name, 1, file); } DEFUN("file-name-nondirectory", Ffile_name_nondirectory, Sfile_name_nondirectory, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-name-nondirectory:: file-name-nondirectory FILE-NAME Return the directory component of FILE-NAME, including the final directory separator. ::end:: */ { repv handler; rep_DECLARE1(file, rep_STRINGP); handler = rep_get_file_handler(file, op_file_name_nondirectory); if(rep_NILP(handler)) return rep_file_name_nondirectory(file); else return rep_call_file_handler(handler, op_file_name_nondirectory, Qfile_name_nondirectory, 1, file); } DEFUN("file-name-directory", Ffile_name_directory, Sfile_name_directory, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-name-directory:: file-name-directory FILE-NAME Return the file name component of FILE-NAME, i.e. everything following the final directory separator. ::end:: */ { repv handler; rep_DECLARE1(file, rep_STRINGP); handler = rep_get_file_handler(file, op_file_name_directory); if(rep_NILP(handler)) return rep_file_name_directory(file); else return rep_call_file_handler(handler, op_file_name_directory, Qfile_name_directory, 1, file); } DEFUN("file-name-as-directory", Ffile_name_as_directory, Sfile_name_as_directory, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-name-as-directory:: file-name-as-directory FILE-NAME Return FILE-NAME such that it names a directory (i.e with a terminating directory separator character.) ::end:: */ { repv handler; rep_DECLARE1(file, rep_STRINGP); handler = rep_get_file_handler(file, op_file_name_as_directory); if(rep_NILP(handler)) return rep_file_name_as_directory(file); else return rep_call_file_handler(handler, op_file_name_as_directory, Qfile_name_as_directory, 1, file); } DEFUN("directory-file-name", Fdirectory_file_name, Sdirectory_file_name, (repv file), rep_Subr1) /* ::doc:rep.io.files#directory-file-name:: directory-file-name DIR-NAME Return the name of the file representing the directory called DIR-NAME. This is the opposite of file-name-as-directory, since its effect is to _remove_ any terminating directory separator. ::end:: */ { repv handler; rep_DECLARE1(file, rep_STRINGP); handler = rep_get_file_handler(file, op_directory_file_name); if(rep_NILP(handler)) return rep_directory_file_name(file); else return rep_call_file_handler(handler, op_directory_file_name, Qdirectory_file_name, 1, file); } /* input handlers */ struct input_handler { struct input_handler *next; int fd; repv function; }; static struct input_handler *input_handlers; static void input_handler_callback (int fd) { struct input_handler *x; for (x = input_handlers; x != 0; x = x->next) { if (x->fd == fd) { rep_call_lisp0 (x->function); break; } } } DEFUN("set-input-handler", Fset_input_handler, Sset_input_handler, (repv file, repv function), rep_Subr2) /* ::doc:rep.io.files#set-input-handler:: set-input-handler LOCAL-FILE FUNCTION Arrange for FUNCTION to be called whenever pending input is available on LOCAL-FILE. Note that this makes LOCAL-FILE do non-blocking input. ::end:: */ { int fd; rep_DECLARE(1, file, rep_FILEP(file) && rep_LOCAL_FILE_P(file)); fd = fileno(rep_FILE(file)->file.fh); if (function != Qnil) { struct input_handler *x; for (x = input_handlers; x != 0; x = x->next) { if (x->fd == fd) { x->function = function; return function; } } x = rep_alloc (sizeof (struct input_handler)); x->next = input_handlers; input_handlers = x; x->fd = fd; x->function = function; rep_register_input_fd (fd, input_handler_callback); return function; } else { struct input_handler **p; for (p = &input_handlers; *p != 0; p = &((*p)->next)) { if ((*p)->fd == fd) { struct input_handler *x = *p; *p = x->next; rep_deregister_input_fd (fd); rep_free (x); } } return Qnil; } } static void mark_input_handlers (void) { struct input_handler *x; for (x = input_handlers; x != 0; x = x->next) { rep_MARKVAL(x->function); } } /* File structures */ static repv make_file(void) { repv file = rep_VAL(rep_ALLOC_CELL(sizeof(rep_file))); if(file == rep_NULL) return rep_mem_error(); rep_data_after_gc += sizeof (rep_file); rep_FILE(file)->car = rep_file_type | rep_LFF_BOGUS_LINE_NUMBER; rep_FILE(file)->name = Qnil; rep_FILE(file)->handler = Qnil; rep_FILE(file)->handler_data = Qnil; rep_FILE(file)->file.stream = Qnil; rep_FILE(file)->next = file_list; file_list = rep_FILE(file); return file; } static void file_sweep(void) { rep_file *lf = file_list; file_list = NULL; while(lf) { rep_file *nxt = lf->next; if(!rep_GC_CELL_MARKEDP(rep_VAL(lf))) { if(rep_LOCAL_FILE_P(rep_VAL(lf)) && !(lf->car & rep_LFF_DONT_CLOSE)) { fclose(lf->file.fh); } rep_FREE_CELL(lf); } else { rep_GC_CLR_CELL(rep_VAL(lf)); lf->next = file_list; file_list = lf; } lf = nxt; } } static void file_prin(repv strm, repv obj) { rep_stream_puts(strm, "#name != Qnil) { rep_stream_puts(strm, rep_PTR(rep_FILE(obj)->name), -1, rep_TRUE); rep_stream_putc(strm, '>'); } else rep_stream_puts(strm, "*unbound*>", -1, rep_FALSE); } static void file_mark(repv val) { rep_MARKVAL(rep_FILE(val)->name); rep_MARKVAL(rep_FILE(val)->handler); rep_MARKVAL(rep_FILE(val)->handler_data); if(!rep_LOCAL_FILE_P(val)) rep_MARKVAL(rep_FILE(val)->file.stream); } DEFUN("filep", Ffilep, Sfilep, (repv arg), rep_Subr1) /* ::doc:rep.io.files#filep:: filep ARG Returns t if ARG is a file object. ::end:: */ { return rep_FILEP(arg) ? Qt : Qnil; } DEFUN("file-binding", Ffile_binding, Sfile_binding, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-binding:: file-binding FILE Returns the name of the logical file that FILE was opened to access, or nil if it has been closed, but is still to be garbage collected. ::end:: */ { rep_DECLARE1(file, rep_FILEP); return rep_FILE(file)->name; } DEFUN("file-ttyp", Ffile_ttyp, Sfile_ttyp, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-ttyp:: file-ttyp FILE Returns true if FILE is linked to a tty. ::end:: */ { rep_DECLARE1 (file, rep_FILEP); return (rep_LOCAL_FILE_P (file) && isatty (fileno (rep_FILE (file)->file.fh))) ? Qt : Qnil; } DEFUN("file-bound-stream", Ffile_bound_stream, Sfile_bound_stream, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-bound-stream:: file-bound-stream FILE If file object FILE doesn't refer to a local file, return the stream that it's bound to. ::end:: */ { rep_DECLARE1(file, rep_FILEP); return !rep_LOCAL_FILE_P(file) ? rep_FILE(file)->file.stream : Qnil; } DEFUN("file-handler-data", Ffile_handler_data, Sfile_handler_data, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-handler-data:: file-handler-data FILE Return the handler-specific data for FILE. ::end:: */ { rep_DECLARE1(file, rep_FILEP); return rep_FILE(file)->handler_data; } DEFUN("set-file-handler-data", Fset_file_handler_data, Sset_file_handler_data, (repv file, repv data), rep_Subr2) /* ::doc:rep.io.files#set-file-handler-data:: set-file-handler-data FILE DATA Set the handler-specific data of file object FILE to DATA. ::end:: */ { rep_DECLARE1(file, rep_FILEP); rep_FILE(file)->handler_data = data; return data; } /* Low level file handling Lisp functions */ DEFUN("open-file", Fopen_file, Sopen_file, (repv file_name, repv access_type), rep_Subr2) /* ::doc:rep.io.files#open-file:: open-file FILE-NAME ACCESS-TYPE Return a new file object referencing the logical file called FILE-NAME, for ACCESS-TYPE requests. ACCESS-TYPE can be one of the symbols: read For input write Truncate or create the file, and open for output append Open for output at the end of the file. ::end:: */ { repv handler, file; rep_GC_root gc; rep_DECLARE1(file_name, rep_STRINGP); rep_DECLARE2(access_type, rep_SYMBOLP); rep_PUSHGC(gc, access_type); file_name = Fexpand_file_name(file_name, Qnil); rep_POPGC; if(!file_name) return file_name; handler = rep_get_file_handler(file_name, op_open_file); if(rep_NILP(handler)) { file = make_file(); if(file != rep_NULL) { rep_FILE(file)->file.fh = fopen(rep_STR(file_name), (access_type == Qwrite ? "w" : (access_type == Qappend ? "a" : "r"))); if(rep_FILE(file)->file.fh == 0) return rep_signal_file_error(file_name); rep_FILE(file)->handler = Qt; rep_FILE(file)->handler_data = file_name; if (access_type != Qwrite) { rep_FILE (file)->line_number = 1; rep_FILE (file)->car &= ~rep_LFF_BOGUS_LINE_NUMBER; } } } else file = rep_call_file_handler(handler, op_open_file, Qopen_file, 2, file_name, access_type); if(file && rep_FILEP(file)) { /* Install the original file name. */ rep_FILE(file)->name = file_name; } return file; } DEFUN("make-file-from-stream", Fmake_file_from_stream, Smake_file_from_stream, (repv file_name, repv stream, repv handler), rep_Subr3) /* ::doc:rep.io.files#make-file-from-stream:: make-file-from-stream FILE-NAME STREAM HANDLER Return a new file object that refers to the logical file called FILE-NAME, that is not in the local filing system. All access to the file object will be directed through the stream object STREAM, and the file handler function HANDLER. ::end:: */ { repv file; rep_DECLARE1(file_name, rep_STRINGP); file = make_file(); if(file != rep_NULL) { rep_FILE(file)->name = file_name; rep_FILE(file)->handler = handler; rep_FILE(file)->file.stream = stream; } return file; } DEFUN("close-file", Fclose_file, Sclose_file, (repv file), rep_Subr1) /* ::doc:rep.io.files#close-file:: close-file FILE Signal that there will be no more I/O through the file object FILE. ::end:: */ { rep_DECLARE1(file, rep_FILEP); if(rep_NILP(rep_FILE(file)->name)) return rep_unbound_file_error(file); if(rep_LOCAL_FILE_P(file)) { Fset_input_handler (file, Qnil); if (!(rep_FILE(file)->car & rep_LFF_DONT_CLOSE)) fclose(rep_FILE(file)->file.fh); else { /* One of stdin, stdout, stderr. freopen onto /dev/null */ char *mode; if (rep_FILE(file)->file.fh == stdin) mode = "r"; else mode = "w"; freopen (DEV_SLASH_NULL, mode, rep_FILE(file)->file.fh); return Qt; } } else rep_call_file_handler(rep_FILE(file)->handler, op_close_file, Qclose_file, 1, file); rep_FILE(file)->name = Qnil; rep_FILE(file)->handler = Qnil; rep_FILE(file)->file.stream = Qnil; return Qt; } DEFUN("flush-file", Fflush_file, Sflush_file, (repv file), rep_Subr1) /* ::doc:rep.io.files#flush-file:: flush-file FILE Flush any buffered output on FILE. This is usually unnecessary since all output will be flushed when FILE is eventually closed. ::end:: */ { rep_DECLARE1(file, rep_FILEP); if(rep_NILP(rep_FILE(file)->name)) return rep_unbound_file_error(file); if(rep_LOCAL_FILE_P(file)) fflush(rep_FILE(file)->file.fh); else rep_call_file_handler(rep_FILE(file)->handler, op_flush_file, Qflush_file, 1, file); return file; } DEFUN("seek-file", Fseek_file, Sseek_file, (repv file, repv offset, repv where), rep_Subr3) /* ::doc:rep.io.files#seek-file:: seek-file FILE [OFFSET] [WHERE-FROM] Called as (seek-file FILE), returns the distance in bytes from the start of the file that the next character would be read from. Called as (seek-file FILE OFFSET [WHERE]) alters the position from which the next byte will be read. WHERE can be one of, nil OFFSET bytes after the current position start OFFSET bytes after the beginning of the file end OFFSET bytes before the end of the file. Note that not all files may be seekable; if (seek-file FILE) returns nil (i.e. the current position is unknown) any attempts to set the current position will also fail. ::end:: */ { rep_DECLARE1(file, rep_FILEP); rep_DECLARE2_OPT(offset, rep_INTP); if(!rep_FILE(file)->name) return rep_unbound_file_error(file); if(rep_LOCAL_FILE_P(file)) { if(offset == Qnil) return rep_make_long_int (ftell(rep_FILE(file)->file.fh)); else { int whence = SEEK_CUR; if(where == Qstart) whence = SEEK_SET; else if(where == Qend) whence = SEEK_END; if (whence == SEEK_SET && offset == rep_MAKE_INT (0)) { rep_FILE (file)->line_number = 1; rep_FILE (file)->car &= ~rep_LFF_BOGUS_LINE_NUMBER; } else rep_FILE (file)->car |= rep_LFF_BOGUS_LINE_NUMBER; if(fseek(rep_FILE(file)->file.fh, rep_get_long_int(offset), whence) != 0) { if (rep_FILE (file)->car & rep_LFF_SILENT_ERRORS) return Qnil; else return rep_signal_file_error(rep_LIST_1(file)); } else return Qt; } } else return rep_call_file_handler(rep_FILE(file)->handler, op_seek_file, Qseek_file, 3, file, offset, where); } DEFUN("set-file-ignore-errors", Fset_file_ignore_errors, Sset_file_ignore_errors, (repv file, repv status), rep_Subr2) { rep_DECLARE1 (file, rep_FILEP); rep_FILE (file)->car &= ~rep_LFF_SILENT_ERRORS; rep_FILE (file)->car |= (status == Qnil) ? 0 : rep_LFF_SILENT_ERRORS; return rep_undefined_value; } /* General file operations */ DEFUN_INT("delete-file", Fdelete_file, Sdelete_file, (repv file_name), rep_Subr1, "fFile to delete:") /* ::doc:rep.io.files#delete-file:: delete-file FILE-NAME Delete the file called FILE-NAME. ::end:: */ { repv handler = rep_expand_and_get_handler(&file_name, op_delete_file); if(!handler) return handler; if(rep_NILP(handler)) return rep_delete_file(file_name); else return rep_call_file_handler(handler, op_delete_file, Qdelete_file, 1, file_name); } DEFSTRING(cant_rename, "Can't rename files across handlers"); DEFUN_INT("rename-file", Frename_file, Srename_file, (repv old, repv new), rep_Subr2, "fOld name of file:" rep_DS_NL "FNew name of file:") /* ::doc:rep.io.files#rename-file:: rename-file OLD-NAME NEW-NAME Rename the file called OLD-NAME so that it is called NEW-NAME. Note that this almost certainly won't work across filing systems. ::end:: */ { repv old_handler, new_handler; rep_GC_root gc_old, gc_new; rep_PUSHGC(gc_old, old); rep_PUSHGC(gc_new, new); old_handler = rep_localise_and_get_handler(&old, op_rename_file); new_handler = rep_localise_and_get_handler(&new, op_rename_file); rep_POPGC; rep_POPGC; if(!old_handler || !new_handler) return rep_NULL; if(old_handler == new_handler) { if(rep_NILP(old_handler)) /* Both names on local fs. */ return rep_rename_file(old, new); else return rep_call_file_handler(old_handler, op_rename_file, Qrename_file, 2, old, new); } else /* TODO: use copy ops to make this work. */ return Fsignal(Qfile_error, rep_LIST_1(rep_VAL(&cant_rename))); } DEFUN_INT("make-directory", Fmake_directory, Smake_directory, (repv dir_name), rep_Subr1, "DDirectory to create:") /* ::doc:rep.io.files#make-directory:: make-directory DIRECTORY-NAME Create a directory called DIRECTORY-NAME. ::end:: */ { repv handler = rep_expand_and_get_handler(&dir_name, op_make_directory); if(!handler) return handler; if(rep_NILP(handler)) return rep_make_directory(dir_name); else return rep_call_file_handler(handler, op_make_directory, Qmake_directory, 1, dir_name); } DEFUN_INT("delete-directory", Fdelete_directory, Sdelete_directory, (repv dir_name), rep_Subr1, "DDirectory to delete:") /* ::doc:rep.io.files#delete-directory:: delete-directory DIRECTORY-NAME Delete the directory called DIRECTORY-NAME. Note that the directory in question should be empty. ::end:: */ { repv handler = rep_expand_and_get_handler(&dir_name, op_delete_directory); if(!handler) return handler; if(rep_NILP(handler)) return rep_delete_directory(dir_name); else return rep_call_file_handler(handler, op_delete_directory, Qdelete_directory, 1, dir_name); } DEFUN_INT("copy-file", Fcopy_file, Scopy_file, (repv src, repv dst), rep_Subr2, "fSource file:" rep_DS_NL "FDestination file:") /* ::doc:rep.io.files#copy-file:: copy-file SOURCE DESTINATION Create a new copy of the file called SOURCE, as the file called DESTINATION. ::end:: */ { repv src_handler, dst_handler, res; rep_GC_root gc_src, gc_dst; rep_PUSHGC(gc_src, src); rep_PUSHGC(gc_dst, dst); src_handler = rep_localise_and_get_handler(&src, op_copy_file); dst_handler = rep_localise_and_get_handler(&dst, op_copy_file); rep_POPGC; rep_POPGC; if(!src_handler || !dst_handler) return rep_NULL; if(src_handler == dst_handler) { if(rep_NILP(src_handler)) /* Both names on local fs. */ res = rep_copy_file(src, dst); else res = rep_call_file_handler(src_handler, op_copy_file, Qcopy_file, 2, src, dst); } else if(rep_NILP(src_handler)) { /* Copying from local to remote */ res = rep_call_file_handler(dst_handler, op_copy_file_from_local_fs, Qcopy_file_from_local_fs, 2, src, dst); } else if(rep_NILP(dst_handler)) { /* Copying from remote to local */ res = rep_call_file_handler(src_handler, op_copy_file_to_local_fs, Qcopy_file_to_local_fs, 2, src, dst); } else { /* Copy from remote-1 to remote-2 via local fs. */ repv temp = Fmake_temp_name(); if(temp) { res = rep_call_file_handler(src_handler, op_copy_file_to_local_fs, Qcopy_file_to_local_fs, 2, src, temp); if(res) { res = rep_call_file_handler(dst_handler, op_copy_file_from_local_fs, Qcopy_file_from_local_fs, 2, temp, dst); } remove(rep_STR(temp)); } else res = rep_NULL; } return res; } /* File attribute operations */ DEFUN("file-readable-p", Ffile_readable_p, Sfile_readable_p, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-readable-p:: file-readable-p FILE-NAME Returns t if the file called FILE-NAME is available for reading from. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_readable_p); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_readable_p(file); else return rep_call_file_handler(handler, op_file_readable_p, Qfile_readable_p, 1, file); } DEFUN("file-writable-p", Ffile_writable_p, Sfile_writable_p, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-writeable-p:: file-writable-p FILE-NAME Returns t if the file called FILE-NAME is available for writing to. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_writable_p); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_writable_p(file); else return rep_call_file_handler(handler, op_file_writable_p, Qfile_writable_p, 1, file); } DEFUN("file-exists-p", Ffile_exists_p, Sfile_exists_p, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-exists-p:: file-exists-p FILE-NAME Returns t if the file called FILE-NAME exists. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_exists_p); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_exists_p(file); else return rep_call_file_handler(handler, op_file_exists_p, Qfile_exists_p, 1, file); } DEFUN("file-regular-p", Ffile_regular_p, Sfile_regular_p, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-regular-p:: file-regular-p FILE-NAME Returns t if the file called FILE-NAME is a normal file, ie, not a directory, device, symbolic link, etc... ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_regular_p); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_regular_p(file); else return rep_call_file_handler(handler, op_file_regular_p, Qfile_regular_p, 1, file); } DEFUN("file-directory-p", Ffile_directory_p, Sfile_directory_p, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-directory-p:: file-directory-p FILE-NAME Returns t if the file called FILE-NAME is a directory. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_directory_p); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_directory_p(file); else return rep_call_file_handler(handler, op_file_directory_p, Qfile_directory_p, 1, file); } DEFUN("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-symlink-p:: file-symlink-p FILE-NAME Returns t if the file called FILE-NAME is a symbolic link to another file. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_symlink_p); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_symlink_p(file); else return rep_call_file_handler(handler, op_file_symlink_p, Qfile_symlink_p, 1, file); } DEFUN("file-owner-p", Ffile_owner_p, Sfile_owner_p, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-owner-p:: file-owner-p FILE-NAME Returns t if the ownership (uid & gid) of the file called FILE-NAME is the same as that of any files written by the editor. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_owner_p); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_owner_p(file); else return rep_call_file_handler(handler, op_file_owner_p, Qfile_owner_p, 1, file); } DEFUN("file-nlinks", Ffile_nlinks, Sfile_nlinks, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-nlinks:: file-nlinks FILE-NAME Returns the number of links pointing to the file called FILE-NAME. This will be one if FILE-NAME has only one name. Doesn't count symbolic links. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_nlinks); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_nlinks(file); else return rep_call_file_handler(handler, op_file_nlinks, Qfile_nlinks, 1, file); } DEFUN("file-size", Ffile_size, Sfile_size, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-size:: file-size FILE-NAME Returns the size of the file called FILE-NAME in bytes. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_size); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_size(file); else return rep_call_file_handler(handler, op_file_size, Qfile_size, 1, file); } DEFUN("file-modes", Ffile_modes, Sfile_modes, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-modes:: file-modes FILE-NAME Return the access permissions of the file called FILE-NAME. Note that the format of this object is filing system dependent. It's only portable use is as an argument to set-file-modes. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_modes); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_modes(file); else return rep_call_file_handler(handler, op_file_modes, Qfile_modes, 1, file); } DEFUN("set-file-modes", Fset_file_modes, Sset_file_modes, (repv file, repv modes), rep_Subr2) /* ::doc:rep.io.files#set-file-modes:: set-file-modes FILE-NAME MODES Sets the access permissions of the file called FILE-NAME to MODES. The only portable way of getting MODES is from the `file-modes' function since it may change across filing systems. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_set_file_modes); if(!handler) return handler; if(rep_NILP(handler)) return rep_set_file_modes(file, modes); else return rep_call_file_handler(handler, op_set_file_modes, Qset_file_modes, 2, file, modes); } DEFUN("file-modes-as-string", Ffile_modes_as_string, Sfile_modes_as_string, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-modes-as-string:: file-modes-as-string FILE-NAME Returns a ten character string describing the attributes of the file called FILE-NAME. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_modes_as_string); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_modes_as_string(file); else return rep_call_file_handler(handler, op_file_modes_as_string, Qfile_modes_as_string, 1, file); } DEFUN("file-modtime", Ffile_modtime, Sfile_modtime, (repv file), rep_Subr1) /* ::doc:rep.io.files#file-modtime:: file-modtime FILE-NAME Return the time that the file called FILE-NAME was last modified, as a cons cell storing two integers, the low 24 bits, and the high bits. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_file_modtime); if(!handler) return handler; if(rep_NILP(handler)) return rep_file_modtime(file); else return rep_call_file_handler(handler, op_file_modtime, Qfile_modtime, 1, file); } rep_bool rep_file_newer_than(repv name1, repv name2) { rep_bool res = rep_FALSE; repv time1; rep_GC_root gc_name1, gc_name2; rep_PUSHGC(gc_name1, name1); rep_PUSHGC(gc_name2, name2); time1 = Ffile_modtime(name1); if(time1 && !rep_NILP(time1)) { repv time2; rep_GC_root gc_time1; rep_PUSHGC(gc_time1, time1); time2 = Ffile_modtime(name2); rep_POPGC; if(time2 && !rep_NILP(time2)) { repv foo = Ftime_later_p(time1, time2); if(foo && !rep_NILP(foo)) res = rep_TRUE; } } rep_POPGC; rep_POPGC; return res; } DEFUN("directory-files", Fdirectory_files, Sdirectory_files, (repv dir), rep_Subr1) /* ::doc:rep.io.files#directory-files:: directory-files DIRECTORY Returns a list of the names of all files in the directory called DIRECTORY. The list is unsorted. ::end:: */ { repv handler = rep_expand_and_get_handler(&dir, op_directory_files); if(!handler) return handler; if(rep_NILP(handler)) return rep_directory_files(dir); else return rep_call_file_handler(handler, op_directory_files, Qdirectory_files, 1, dir); } DEFUN("read-symlink", Fread_symlink, Sread_symlink, (repv file), rep_Subr1) /* ::doc:rep.io.files#read-symlink:: read-symlink FILENAME Return the string that is the contents of the symbolic link FILENAME. This string may be relative to the directory containing FILENAME. Signals an error if FILENAME isn't a symbolic link. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_read_symlink); if(!handler) return handler; if(rep_NILP(handler)) return rep_read_symlink(file); else return rep_call_file_handler(handler, op_read_symlink, Qread_symlink, 1, file); } DEFUN("make-symlink", Fmake_symlink, Smake_symlink, (repv file, repv contents), rep_Subr2) /* ::doc:rep.io.files#make-symlink:: make-symlink FILENAME CONTENTS Create a symbolic link FILENAME pointing to the file called CONTENTS. CONTENTS may be relative to the directory containing FILENAME. ::end:: */ { repv handler = rep_expand_and_get_handler(&file, op_make_symlink); rep_DECLARE2(contents, rep_STRINGP); if(!handler) return handler; if(rep_NILP(handler)) return rep_make_symlink(file, contents); else return rep_call_file_handler(handler, op_make_symlink, Qmake_symlink, 2, file, contents); } /* Utility functions */ repv rep_file_fdopen (int fd, char *mode) { rep_file *ptr; for (ptr = file_list; ptr != 0; ptr = ptr->next) { if (rep_LOCAL_FILE_P (rep_VAL (ptr)) && fileno (ptr->file.fh) == fd) return rep_VAL (ptr); } ptr = rep_FILE (make_file ()); ptr->handler = Qt; ptr->file.fh = fdopen (fd, mode); if (ptr->file.fh == 0) return rep_NULL; else return rep_VAL (ptr); } DEFSTRING(stdin_name, ""); DEFUN("stdin-file", Fstdin_file, Sstdin_file, (void), rep_Subr0) /* ::doc:rep.io.files#stdin-file:: stdin-file Returns the file object representing the editor's standard input. ::end:: */ { static repv stdin_file; if(stdin_file) return stdin_file; stdin_file = make_file(); rep_FILE(stdin_file)->name = rep_VAL(&stdin_name); rep_FILE(stdin_file)->handler = Qt; rep_FILE(stdin_file)->file.fh = stdin; rep_FILE(stdin_file)->car |= rep_LFF_DONT_CLOSE; rep_mark_static(&stdin_file); return stdin_file; } DEFSTRING(stdout_name, ""); DEFUN("stdout-file", Fstdout_file, Sstdout_file, (void), rep_Subr0) /* ::doc:rep.io.files#stdout-file:: stdout-file Returns the file object representing the editor's standard output. ::end:: */ { static repv stdout_file; if(stdout_file) return stdout_file; stdout_file = make_file(); rep_FILE(stdout_file)->name = rep_VAL(&stdout_name); rep_FILE(stdout_file)->handler = Qt; rep_FILE(stdout_file)->file.fh = stdout; rep_FILE(stdout_file)->car |= rep_LFF_DONT_CLOSE; rep_mark_static(&stdout_file); return stdout_file; } DEFSTRING(stderr_name, ""); DEFUN("stderr-file", Fstderr_file, Sstderr_file, (void), rep_Subr0) /* ::doc:rep.io.files#stderr-file:: stderr-file Returns the file object representing the editor's standard output. ::end:: */ { static repv stderr_file; if(stderr_file) return stderr_file; stderr_file = make_file(); rep_FILE(stderr_file)->name = rep_VAL(&stderr_name); rep_FILE(stderr_file)->handler = Qt; rep_FILE(stderr_file)->file.fh = stderr; rep_FILE(stderr_file)->car |= rep_LFF_DONT_CLOSE; rep_mark_static(&stderr_file); return stderr_file; } DEFSTRING(no_temp, "Can't create temporary file name"); DEFUN("make-temp-name", Fmake_temp_name, Smake_temp_name, (void), rep_Subr0) /* ::doc:rep.io.files#make-temp-name:: make-temp-name Returns the name of a unique file in the local filing system. ::end:: */ { char buf[L_tmpnam]; if(tmpnam(buf)) return rep_string_dup(buf); else return rep_signal_file_error(rep_VAL(&no_temp)); } DEFUN("set-file-handler-environment", Fset_file_handler_environment, Sset_file_handler_environment, (repv env, repv structure), rep_Subr2) /* ::doc:rep.io.files#set-file-handler-environment:: set-file-handler-environment ENV ::end:: */ { return Fstructure_define (structure, Qfh_env_key, env); } /* init */ void rep_files_init(void) { repv tem; Qfh_env_key = Fmake_symbol (rep_VAL (&str_fh_env_key)); rep_mark_static (&Qfh_env_key); rep_INTERN_SPECIAL(file_handler_alist); Fset (Qfile_handler_alist, Qnil); rep_INTERN_SPECIAL(default_directory); tem = rep_getpwd(); if (tem == rep_NULL) tem = rep_null_string (); Fset (Qdefault_directory, tem); rep_INTERN(file_name_absolute_p); rep_INTERN(expand_file_name); rep_INTERN(local_file_name); rep_INTERN(canonical_file_name); rep_INTERN(file_name_nondirectory); rep_INTERN(file_name_directory); rep_INTERN(file_name_as_directory); rep_INTERN(directory_file_name); rep_INTERN(open_file); rep_INTERN(close_file); rep_INTERN(flush_file); rep_INTERN(seek_file); rep_INTERN(delete_file); rep_INTERN(rename_file); rep_INTERN(make_directory); rep_INTERN(delete_directory); rep_INTERN(copy_file); rep_INTERN(copy_file_to_local_fs); rep_INTERN(copy_file_from_local_fs); rep_INTERN(file_readable_p); rep_INTERN(file_writable_p); rep_INTERN(file_exists_p); rep_INTERN(file_regular_p); rep_INTERN(file_directory_p); rep_INTERN(file_symlink_p); rep_INTERN(file_owner_p); rep_INTERN(file_nlinks); rep_INTERN(file_size); rep_INTERN(file_modes); rep_INTERN(set_file_modes); rep_INTERN(file_modes_as_string); rep_INTERN(file_modtime); rep_INTERN(directory_files); rep_INTERN(read_symlink); rep_INTERN(make_symlink); rep_INTERN(start); rep_INTERN(end); rep_INTERN(read); rep_INTERN(write); rep_INTERN(append); rep_INTERN(rep_io_file_handlers); tem = rep_push_structure ("rep.io.files"); rep_ADD_SUBR(Sfilep); rep_ADD_SUBR(Sfile_binding); rep_ADD_SUBR(Sfile_ttyp); rep_ADD_SUBR(Sfile_bound_stream); rep_ADD_SUBR(Sfile_handler_data); rep_ADD_SUBR(Sset_file_handler_data); rep_ADD_SUBR(Sfile_name_absolute_p); rep_ADD_SUBR(Sexpand_file_name); rep_ADD_SUBR(Slocal_file_name); rep_ADD_SUBR(Scanonical_file_name); rep_ADD_SUBR(Sfile_name_nondirectory); rep_ADD_SUBR(Sfile_name_directory); rep_ADD_SUBR(Sfile_name_as_directory); rep_ADD_SUBR(Sdirectory_file_name); rep_ADD_SUBR(Sset_input_handler); rep_ADD_SUBR(Sopen_file); rep_ADD_SUBR(Smake_file_from_stream); rep_ADD_SUBR(Sclose_file); rep_ADD_SUBR(Sflush_file); rep_ADD_SUBR(Sseek_file); rep_ADD_SUBR(Sset_file_ignore_errors); rep_ADD_SUBR_INT(Sdelete_file); rep_ADD_SUBR_INT(Srename_file); rep_ADD_SUBR_INT(Scopy_file); rep_ADD_SUBR_INT(Smake_directory); rep_ADD_SUBR_INT(Sdelete_directory); rep_ADD_SUBR(Sfile_readable_p); rep_ADD_SUBR(Sfile_writable_p); rep_ADD_SUBR(Sfile_exists_p); rep_ADD_SUBR(Sfile_regular_p); rep_ADD_SUBR(Sfile_directory_p); rep_ADD_SUBR(Sfile_symlink_p); rep_ADD_SUBR(Sfile_owner_p); rep_ADD_SUBR(Sfile_nlinks); rep_ADD_SUBR(Sfile_size); rep_ADD_SUBR(Sfile_modes); rep_ADD_SUBR(Sset_file_modes); rep_ADD_SUBR(Sfile_modes_as_string); rep_ADD_SUBR(Sfile_modtime); rep_ADD_SUBR(Sdirectory_files); rep_ADD_SUBR(Sread_symlink); rep_ADD_SUBR(Smake_symlink); rep_ADD_SUBR(Sstdin_file); rep_ADD_SUBR(Sstdout_file); rep_ADD_SUBR(Sstderr_file); rep_ADD_SUBR(Smake_temp_name); rep_ADD_SUBR(Sset_file_handler_environment); rep_pop_structure (tem); /* Initialise the type information. */ rep_file_type = rep_register_new_type("file", rep_ptr_cmp, file_prin, file_prin, file_sweep, file_mark, mark_input_handlers, 0, 0, 0, 0, 0, 0); } void rep_files_kill(void) { rep_file *lf = file_list; while(lf) { rep_file *nxt = lf->next; if(rep_LOCAL_FILE_P(rep_VAL(lf)) && !(lf->car & rep_LFF_DONT_CLOSE)) { fclose(lf->file.fh); } rep_FREE_CELL(lf); lf = nxt; } file_list = NULL; } librep-0.90.2/src/ffi.c0000644000175200017520000006216511245011153013567 0ustar chrischris/* ffi.c -- foreigh function interface plugin $Id$ Copyright (C) 2003 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* Commentary: (ffi-struct [MEMBER-TYPES ...]) -> TYPE -- creates a new structure type (ffi-interface RET-TYPE (PARAM-TYPES ...)) -> INTERFACE -- creates a new ffi function signature (ffi-type BASE-TYPE [PREDICATE] [TYPE->BASE] [BASE->TYPE]) -> TYPE -- creates a new type alias (ffi-apply INTERFACE FN-POINTER ARG-LIST) -> RET-VALUE -- calls a function and returns its result Apply works by walking the list of arguments converting everything into native or structure types. It calls the function then converts any returned value back to lisp data. Question: how to handle `out' parameters? E.g. void foo (int a, int *out_b) { *out_b = a + 1 } one possibility is to recognize `(out TYPE)' as meaning, allocate space for one of TYPE on the stack, pass its address to the function, then return the converted value (somehow) but then how do you handle arrays? E.g. void foo (int n, int values[]) {...} Perhaps just provide some primitives: (ffi-new TYPE #!optional (COUNT 1)) -> POINTER (ffi-delete TYPE POINTER) (ffi-address-of TYPE POINTER INDEX) -> POINTER' (ffi-set! TYPE POINTER VALUE) (ffi-get TYPE POINTER) -> VALUE this should be enough to allow everything to be handled by higher level code. */ #include "repint.h" #include #include #include #include #ifdef HAVE_FFI_H #include #ifndef ALIGN /* was in older ffi.h */ #define ALIGN(v, a) (((((unsigned) (v))-1) | ((a)-1))+1) #endif #endif #if SIZEOF_VOID_P == SIZEOF_LONG # define rep_make_pointer(p) rep_make_long_uint ((unsigned long) p) # define rep_get_pointer(x) (void *) rep_get_long_uint (x) # define rep_pointerp(x) rep_INTEGERP (x) #elif SIZEOF_VOID_P != SIZEOF_LONG_LONG # define rep_make_pointer(p) rep_make_longlong_int ((unsigned long long) p) # define rep_get_pointer(x) (void *) rep_get_longlong_int (x) # define rep_pointerp(x) rep_INTEGERP (x) #else # error "weird pointer size" #endif #ifdef HAVE_LIBFFI typedef struct rep_ffi_type_struct rep_ffi_type; typedef struct rep_ffi_alias_struct rep_ffi_alias; typedef struct rep_ffi_struct_struct rep_ffi_struct; typedef struct rep_ffi_interface_struct rep_ffi_interface; struct rep_ffi_type_struct { ffi_type *type; unsigned int subtype; }; enum rep_ffi_subtype_enum { rep_FFI_PRIMITIVE = 0, rep_FFI_STRUCT, rep_FFI_ALIAS, }; struct rep_ffi_alias_struct { rep_ffi_type super; repv predicate; repv conv_in; repv conv_out; unsigned int base; }; struct rep_ffi_struct_struct { rep_ffi_type super; ffi_type type; unsigned int n_elements; unsigned int *element_ids; ffi_type *elements[1]; }; #define SIZEOF_REP_FFI_STRUCT(n) \ (sizeof (rep_ffi_struct) + (sizeof (ffi_type *) * (n))) struct rep_ffi_interface_struct { ffi_cif cif; ffi_type *ret_type; unsigned int n_args; ffi_type **arg_types; size_t args_size; unsigned int ret; unsigned int args[1]; }; #define SIZEOF_REP_FFI_INTERFACE(n) \ (sizeof (rep_ffi_interface) + (sizeof (int) * ((n) - 1))) static int n_ffi_types, n_alloc_ffi_types; static rep_ffi_type **ffi_types; static int n_ffi_interfaces, n_alloc_ffi_interfaces; static rep_ffi_interface **ffi_interfaces; #define rep_VALID_TYPE_P(x) \ (rep_INTP (x) && rep_INT (x) >= 0 && rep_INT (x) < n_ffi_types) #define rep_VALID_INTERFACE_P(x) \ (rep_INTP (x) && rep_INT (x) >= 0 && rep_INT (x) < n_ffi_interfaces) static rep_bool ffi_types_equal_p (const rep_ffi_type *a, const rep_ffi_type *b) { if (a->subtype != b->subtype) return rep_FALSE; if (a->type != NULL && a->type == b->type) return rep_TRUE; switch (a->subtype) { case rep_FFI_PRIMITIVE: return (a->type->type == b->type->type && a->type->size == b->type->size && a->type->alignment == b->type->alignment); case rep_FFI_STRUCT: { const rep_ffi_struct *sa, *sb; unsigned int i; sa = (rep_ffi_struct *) a; sb = (rep_ffi_struct *) b; if (sa->n_elements != sb->n_elements) return rep_FALSE; for (i = 0; i < sa->n_elements; i++) { if (sa->element_ids[i] != sb->element_ids[i]) return rep_FALSE; } return rep_TRUE; } case rep_FFI_ALIAS: { const rep_ffi_alias *aa, *ab; aa = (rep_ffi_alias *) a; ab = (rep_ffi_alias *) b; return (aa->base == ab->base && aa->predicate == ab->predicate && aa->conv_in == ab->conv_in && aa->conv_out == ab->conv_out); } default: return rep_FALSE; } } static rep_bool ffi_interfaces_equal_p (const rep_ffi_interface *a, const rep_ffi_interface *b) { unsigned int i; if (a->n_args != b->n_args || a->args_size != b->args_size || a->ret != b->ret) { return rep_FALSE; } for (i = 0; i < a->n_args; i++) { if (a->args[i] != b->args[i]) return rep_FALSE; } return rep_TRUE; } static unsigned int ffi_alloc_type (rep_ffi_type *type) { unsigned int i; /* FIXME: this is O(N), it should be hashed. */ for (i = 0; i < n_ffi_types; i++) { if (ffi_types_equal_p (type, ffi_types[i])) { rep_free (type); return i; } } i = n_ffi_types++; if (i >= n_alloc_ffi_types) { n_alloc_ffi_types = MAX (n_alloc_ffi_types * 2, 256); ffi_types = rep_realloc (ffi_types, sizeof (ffi_types[0]) * n_alloc_ffi_types); } ffi_types[i] = type; return i; } static unsigned int ffi_alloc_interface (rep_ffi_interface *iface) { unsigned int i; /* FIXME: this is O(N), it should be hashed. */ for (i = 0; i < n_ffi_interfaces; i++) { if (ffi_interfaces_equal_p (iface, ffi_interfaces[i])) { rep_free (iface); return i; } } i = n_ffi_interfaces++; if (i >= n_alloc_ffi_interfaces) { n_alloc_ffi_interfaces = MAX (n_alloc_ffi_interfaces * 2, 256); ffi_interfaces = rep_realloc (ffi_interfaces, sizeof (ffi_interfaces[0]) * n_alloc_ffi_interfaces); } ffi_interfaces[i] = iface; return i; } static char * rep_ffi_marshal (unsigned int type_id, repv value, char *ptr) { rep_ffi_type *type = ffi_types[type_id]; switch (type->subtype) { DEFSTRING (err, "unknown ffi type id"); DEFSTRING (err2, "ffi struct expected a vector or list"); case rep_FFI_PRIMITIVE: switch (type->type->type) { case FFI_TYPE_VOID: return ptr; case FFI_TYPE_INT: *(int *)ptr = (int) rep_get_long_int (value); return ptr + sizeof (int); case FFI_TYPE_FLOAT: *(float *)ptr = (float) rep_get_float (value); return ptr + sizeof (float); case FFI_TYPE_DOUBLE: *(double *)ptr = (double) rep_get_float (value); return ptr + sizeof (double); #if FFI_TYPE_LONGDOUBLE != FFI_TYPE_DOUBLE case FFI_TYPE_LONGDOUBLE: *(long double *)ptr = (long double) rep_get_float (value); return ptr + sizeof (long double); #endif case FFI_TYPE_UINT8: *(uint8_t *)ptr = (uint8_t) rep_get_long_int (value); return ptr + sizeof (uint8_t); case FFI_TYPE_SINT8: *(int8_t *)ptr = (int8_t) rep_get_long_int (value); return ptr + sizeof (int8_t); case FFI_TYPE_UINT16: *(uint16_t *)ptr = (uint16_t) rep_get_long_int (value); return ptr + sizeof (uint16_t); case FFI_TYPE_SINT16: *(int16_t *)ptr = (int16_t) rep_get_long_int (value); return ptr + sizeof (int16_t); case FFI_TYPE_UINT32: *(uint32_t *)ptr = (uint32_t) rep_get_long_int (value); return ptr + sizeof (uint32_t); case FFI_TYPE_SINT32: *(int32_t *)ptr = (int32_t) rep_get_long_int (value); return ptr + sizeof (int32_t); case FFI_TYPE_UINT64: *(uint64_t *)ptr = (uint64_t) rep_get_longlong_int (value); return ptr + sizeof (uint64_t); case FFI_TYPE_SINT64: *(int64_t *)ptr = (int64_t) rep_get_longlong_int (value); return ptr + sizeof (int64_t); case FFI_TYPE_POINTER: *(void **)ptr = (rep_STRINGP(value)) ? rep_STR (value) : rep_get_pointer (value); return ptr + sizeof (void *); case FFI_TYPE_STRUCT: /* FIXME: */ default: Fsignal (Qerror, rep_list_2 (rep_VAL (&err), rep_MAKE_INT (type_id))); return NULL; } /* not reached */ case rep_FFI_STRUCT: { rep_ffi_struct *s = (rep_ffi_struct *) type; rep_GC_root gc_value; int i; rep_PUSHGC (gc_value, value); for (i = 0; i < s->n_elements; i++) { repv elt; if (rep_VECTORP (value)) elt = rep_VECTI (value, i); else if (rep_CONSP (value)) { elt = rep_CAR (value); value = rep_CDR (value); } else { rep_POPGC; Fsignal (Qerror, rep_list_2 (rep_VAL (&err2), value)); return NULL; } ptr = rep_ffi_marshal (s->element_ids[i], elt, ptr); if (ptr == NULL) { rep_POPGC; return NULL; } } rep_POPGC; return ptr; } case rep_FFI_ALIAS: { rep_ffi_alias *s = (rep_ffi_alias *) type; if (s->conv_in != rep_NULL) { value = rep_call_lisp1 (s->conv_in, value); if (value == rep_NULL) return NULL; } return rep_ffi_marshal (s->base, value, ptr); } default: Fsignal (Qerror, rep_list_2 (rep_VAL (&err), rep_MAKE_INT (type_id))); return NULL; } } static char * rep_ffi_demarshal (unsigned int type_id, char *ptr, repv *value) { rep_ffi_type *type = ffi_types[type_id]; switch (type->subtype) { DEFSTRING (err, "unknown ffi type id"); case rep_FFI_PRIMITIVE: switch (type->type->type) { case FFI_TYPE_VOID: *value = rep_undefined_value; return ptr; case FFI_TYPE_INT: *value = rep_make_long_int (*(int *)ptr); return ptr + sizeof (int); case FFI_TYPE_FLOAT: *value = rep_make_float (*(float *)ptr, rep_TRUE); return ptr + sizeof (float); case FFI_TYPE_DOUBLE: *value = rep_make_float (*(double *)ptr, rep_TRUE); return ptr + sizeof (double); #if FFI_TYPE_LONGDOUBLE != FFI_TYPE_DOUBLE case FFI_TYPE_LONGDOUBLE: *value = rep_make_float (*(long double *)ptr, rep_TRUE); return ptr + sizeof (long double); #endif case FFI_TYPE_UINT8: *value = rep_MAKE_INT (*(uint8_t *)ptr); return ptr + sizeof (uint8_t); case FFI_TYPE_SINT8: *value = rep_MAKE_INT (*(int8_t *)ptr); return ptr + sizeof (int8_t); case FFI_TYPE_UINT16: *value = rep_MAKE_INT (*(uint16_t *)ptr); return ptr + sizeof (uint16_t); case FFI_TYPE_SINT16: *value = rep_MAKE_INT (*(int16_t *)ptr); return ptr + sizeof (int16_t); case FFI_TYPE_UINT32: *value = rep_make_long_int (*(uint32_t *)ptr); return ptr + sizeof (uint32_t); case FFI_TYPE_SINT32: *value = rep_make_long_int (*(int32_t *)ptr); return ptr + sizeof (int32_t); case FFI_TYPE_UINT64: *value = rep_make_longlong_int (*(uint64_t *)ptr); return ptr + sizeof (uint64_t); case FFI_TYPE_SINT64: *value = rep_make_longlong_int (*(int64_t *)ptr); return ptr + sizeof (int64_t); case FFI_TYPE_POINTER: *value = rep_make_pointer (*(void **)ptr); return ptr + sizeof (void *); case FFI_TYPE_STRUCT: /* FIXME: */ default: Fsignal (Qerror, rep_list_2 (rep_VAL (&err), rep_MAKE_INT (type_id))); return NULL; } /* not reached */ case rep_FFI_STRUCT: { rep_ffi_struct *s = (rep_ffi_struct *) type; rep_GC_n_roots gc_value; int i; *value = rep_make_vector (s->n_elements); rep_PUSHGCN (gc_value, value, 1); for (i = 0; i < s->n_elements; i++) { ptr = rep_ffi_demarshal (s->element_ids[i], ptr, &rep_VECTI (*value, i)); if (ptr == NULL) { rep_POPGCN; return NULL; } } rep_POPGCN; return ptr; } case rep_FFI_ALIAS: { rep_ffi_alias *s = (rep_ffi_alias *) type; ptr = rep_ffi_marshal (s->base, *value, ptr); if (s->conv_in != rep_NULL) { *value = rep_call_lisp1 (s->conv_out, *value); if (*value == rep_NULL) return NULL; } return ptr; } default: Fsignal (Qerror, rep_list_2 (rep_VAL (&err), rep_MAKE_INT (type_id))); return NULL; } } DEFUN ("ffi-struct", Fffi_struct, Sffi_struct, (repv fields), rep_Subr1) { unsigned int i, n; rep_ffi_struct *s; if (rep_VECTORP (fields)) n = rep_VECT_LEN (fields); else if (rep_CONSP (fields)) n = rep_list_length (fields); else return rep_signal_arg_error (fields, 1); s = rep_alloc (SIZEOF_REP_FFI_STRUCT (n) + sizeof (unsigned int) * n); s->super.type = &s->type; s->super.subtype = rep_FFI_STRUCT; s->element_ids = (void *) ((char *) s + SIZEOF_REP_FFI_STRUCT (n)); for (i = 0; i < n; i++) { repv x; if (rep_VECTORP (fields)) x = rep_VECTI (fields, i); else if (rep_CONSP (fields)) { x = rep_CAR (fields); fields = rep_CDR (fields); } else x = rep_NULL; if (x == rep_NULL || !rep_VALID_TYPE_P (x)) { rep_free (s); return rep_signal_arg_error (x, 1); } s->element_ids[i] = rep_INT (x); s->elements[i] = ffi_types[rep_INT (x)]->type; } s->elements[n] = NULL; s->n_elements = n; s->type.elements = s->elements; s->type.size = s->type.alignment = 0; /* We should leave size and alignment as zero and let libffi initialize them. But that doesn't for me, need the size known at all times. */ for (i = 0; i < s->n_elements; i++) { s->type.size = ALIGN (s->type.size, s->elements[i]->alignment); s->type.size += s->elements[i]->size; s->type.alignment = MAX (s->type.alignment, s->elements[i]->alignment); } return rep_MAKE_INT (ffi_alloc_type (&s->super)); } DEFUN ("ffi-type", Fffi_type, Sffi_type, (repv base, repv pred, repv in, repv out), rep_Subr4) { rep_ffi_alias *s; rep_DECLARE (1, base, rep_VALID_TYPE_P (base)); s = rep_alloc (sizeof (rep_ffi_alias)); s->super.subtype = rep_FFI_ALIAS; s->super.type = ffi_types[rep_INT (base)]->type; s->predicate = pred; s->conv_in = in; s->conv_out = out; s->base = rep_INT (base); return rep_MAKE_INT (ffi_alloc_type (&s->super)); } static repv ffi_add_primitive_type (ffi_type *type) { rep_ffi_type *s; s = rep_alloc (sizeof (rep_ffi_type)); s->subtype = rep_FFI_PRIMITIVE; s->type = type; return rep_MAKE_INT (ffi_alloc_type (s)); } DEFUN ("ffi-interface", Fffi_interface, Sffi_interface, (repv ret, repv args), rep_Subr2) { unsigned int i, n; rep_ffi_interface *s; if (ret != Qnil) rep_DECLARE (1, ret, rep_VALID_TYPE_P (ret)); if (rep_VECTORP (args)) n = rep_VECT_LEN (args); else if (rep_LISTP (args)) n = rep_list_length (args); else return rep_signal_arg_error (args, 2); s = rep_alloc (SIZEOF_REP_FFI_INTERFACE (n) + sizeof (ffi_type *) * n); s->arg_types = (void *) (((char *) s) + SIZEOF_REP_FFI_INTERFACE (n)); s->n_args = n; s->ret = (ret != Qnil) ? rep_INT (ret) : 0; s->ret_type = ffi_types[s->ret]->type; s->args_size = 0; for (i = 0; i < n; i++) { repv elt; if (rep_VECTORP (args)) elt = rep_VECTI (args, i); else { elt = rep_CAR (args); args = rep_CDR (args); } if (!rep_VALID_TYPE_P (elt)) { rep_free (s); return rep_signal_arg_error (args, 2); } s->args[i] = rep_INT (elt); s->arg_types[i] = ffi_types[s->args[i]]->type; if (s->arg_types[i]->alignment > 1) s->args_size = ALIGN (s->args_size, s->arg_types[i]->alignment); s->args_size += s->arg_types[i]->size; } if (ffi_prep_cif (&s->cif, FFI_DEFAULT_ABI, s->n_args, s->ret_type, s->arg_types) != FFI_OK) { rep_free (s); return rep_signal_arg_error (args, 1); /* FIXME: */ } return rep_MAKE_INT (ffi_alloc_interface (s)); } DEFUN ("ffi-apply", Fffi_apply, Sffi_apply, (repv iface_id, repv ptr, repv args), rep_Subr3) { rep_ffi_interface *iface; void *function_ptr; rep_GC_root gc_args; rep_DECLARE (1, iface_id, rep_VALID_INTERFACE_P (iface_id)); rep_DECLARE (2, ptr, rep_pointerp (ptr)); iface = ffi_interfaces[rep_INT (iface_id)]; function_ptr = rep_get_pointer (ptr); if (function_ptr != NULL) { /* use arrays of doubles to get good alignment. */ double _args_data[(iface->args_size >> 3) + 1]; double _ret_data[(iface->cif.rtype->size >> 3) + 1]; void *values[iface->n_args]; char *ret_data = NULL, *args_data = NULL, *args_ptr; repv ret_value = rep_undefined_value; int i; if (iface->cif.rtype->size != 0) ret_data = (char *) _ret_data; args_data = (char *) _args_data; args_ptr = args_data; rep_PUSHGC (gc_args, args); for (i = 0; i < iface->n_args; i++) { repv elt; values[i] = args_ptr; if (!rep_CONSP (args)) { rep_POPGC; return rep_signal_arg_error (args, 3); } elt = rep_CAR (args); args = rep_CDR (args); args_ptr = rep_ffi_marshal (iface->args[i], elt, args_ptr); if (args_ptr == NULL) { rep_POPGC; return rep_NULL; } } rep_POPGC; ffi_call (&iface->cif, function_ptr, ret_data, values); if (ret_data != NULL) { if (rep_ffi_demarshal (iface->ret, ret_data, &ret_value) == NULL) return rep_NULL; } return ret_value; } return rep_signal_arg_error (ptr, 2); } DEFUN ("ffi-new", Fffi_new, Sffi_new, (repv type_id, repv count), rep_Subr2) { rep_ffi_type *type; void *ptr; rep_DECLARE1 (type_id, rep_VALID_TYPE_P); if (count != Qnil) rep_DECLARE2 (count, rep_INTP); else count = rep_MAKE_INT (1); type = ffi_types[rep_INT (type_id)]; ptr = rep_alloc (type->type->size * rep_INT (count)); return rep_make_pointer (ptr); } DEFUN ("ffi-delete", Fffi_delete, Sffi_delete, (repv type_id, repv addr), rep_Subr2) { rep_DECLARE1 (type_id, rep_VALID_TYPE_P); rep_DECLARE2 (addr, rep_pointerp); rep_free (rep_get_pointer (addr)); return rep_undefined_value; } DEFUN ("ffi-address-of", Fffi_address_of, Sffi_address_of, (repv type_id, repv addr, repv idx), rep_Subr3) { rep_ffi_type *type; char *ptr; int i; rep_DECLARE1 (type_id, rep_VALID_TYPE_P); rep_DECLARE2 (addr, rep_pointerp); rep_DECLARE (3, idx, rep_INTP (idx) && rep_INT (idx) >= 0); type = ffi_types[rep_INT (type_id)]; ptr = rep_get_pointer (addr); for (i = rep_INT (idx); i > 0; i--) { ptr = (void *) ALIGN (ptr, type->type->alignment); ptr += type->type->size; } return rep_make_pointer (ptr); } DEFUN ("ffi-set!", Fffi_set_, Sffi_set_, (repv type_id, repv addr, repv value), rep_Subr4) { rep_ffi_type *type; char *ptr; rep_DECLARE1 (type_id, rep_VALID_TYPE_P); rep_DECLARE2 (addr, rep_pointerp); type = ffi_types[rep_INT (type_id)]; ptr = rep_get_pointer (addr); ptr = (void *) ALIGN (ptr, type->type->alignment); if (rep_ffi_marshal (rep_INT (type_id), value, ptr) == NULL) return rep_NULL; return rep_undefined_value; } DEFUN ("ffi-get", Fffi_get, Sffi_get, (repv type_id, repv addr), rep_Subr2) { rep_ffi_type *type; char *ptr; repv value; rep_DECLARE1 (type_id, rep_VALID_TYPE_P); rep_DECLARE2 (addr, rep_pointerp); type = ffi_types[rep_INT (type_id)]; ptr = rep_get_pointer (addr); ptr = (void *) ALIGN (ptr, type->type->alignment); if (rep_ffi_demarshal (rep_INT (type_id), ptr, &value) == NULL) return rep_NULL; return value; } #else /* HAVE_LIBFFI */ static repv no_libffi_error (void) { DEFSTRING (err, "ffi support is not present in this installation"); return Fsignal (Qerror, Fcons (rep_VAL (&err), Qnil)); } DEFUN ("ffi-struct", Fffi_struct, Sffi_struct, (repv fields), rep_Subr1) { return no_libffi_error (); } DEFUN ("ffi-type", Fffi_type, Sffi_type, (repv base, repv pred, repv in, repv out), rep_Subr4) { return no_libffi_error (); } DEFUN ("ffi-interface", Fffi_interface, Sffi_interface, (repv ret, repv args), rep_Subr2) { return no_libffi_error (); } DEFUN ("ffi-apply", Fffi_apply, Sffi_apply, (repv iface_id, repv ptr, repv args), rep_Subr3) { return no_libffi_error (); } DEFUN ("ffi-new", Fffi_new, Sffi_new, (repv type_id, repv count), rep_Subr2) { return no_libffi_error (); } DEFUN ("ffi-delete", Fffi_delete, Sffi_delete, (repv type_id, repv addr), rep_Subr2) { return no_libffi_error (); } DEFUN ("ffi-address-of", Fffi_address_of, Sffi_address_of, (repv type_id, repv addr, repv idx), rep_Subr3) { return no_libffi_error (); } DEFUN ("ffi-set!", Fffi_set_, Sffi_set_, (repv type_id, repv addr, repv value), rep_Subr4) { return no_libffi_error (); } DEFUN ("ffi-get", Fffi_get, Sffi_get, (repv type_id, repv addr), rep_Subr2) { return no_libffi_error (); } #endif /* HAVE_LIBFFI */ DEFUN ("ffi-load-library", Fffi_load_library, Sffi_load_library, (repv name), rep_Subr1) { int handle; rep_DECLARE (1, name, rep_STRINGP (name)); handle = rep_intern_dl_library (name); if (name == -1) { DEFSTRING (err, "Can't open shared library"); return Fsignal (Qerror, rep_list_2 (rep_VAL (&err), name)); } return rep_MAKE_INT (handle); } DEFUN ("ffi-lookup-symbol", Fffi_lookup_symbol, Sffi_lookup_symbol, (repv handle, repv name), rep_Subr2) { void *ptr; if (handle != Qnil) rep_DECLARE (1, handle, rep_INTP (handle)); rep_DECLARE (2, name, rep_STRINGP (name)); /* anything outside the range of valid handles means RTLD_DEFAULT. */ ptr = rep_lookup_dl_symbol (handle != Qnil ? rep_INT (handle) : -1, rep_STR (name)); return ptr != NULL ? rep_make_pointer (ptr) : Qnil; } /* dl hooks */ DEFSYM (ffi_type_void, "ffi-type-void"); DEFSYM (ffi_type_uint8, "ffi-type-uint8"); DEFSYM (ffi_type_sint8, "ffi-type-sint8"); DEFSYM (ffi_type_uint16, "ffi-type-uint16"); DEFSYM (ffi_type_sint16, "ffi-type-sint16"); DEFSYM (ffi_type_uint32, "ffi-type-uint32"); DEFSYM (ffi_type_sint32, "ffi-type-sint32"); DEFSYM (ffi_type_uint64, "ffi-type-uint64"); DEFSYM (ffi_type_sint64, "ffi-type-sint64"); DEFSYM (ffi_type_float, "ffi-type-float"); DEFSYM (ffi_type_double, "ffi-type-double"); DEFSYM (ffi_type_longdouble, "ffi-type-longdouble"); DEFSYM (ffi_type_pointer, "ffi-type-pointer"); repv rep_dl_init (void) { repv tem = rep_push_structure ("rep.ffi"); rep_INTERN (ffi_type_void); rep_INTERN (ffi_type_uint8); rep_INTERN (ffi_type_sint8); rep_INTERN (ffi_type_uint16); rep_INTERN (ffi_type_sint16); rep_INTERN (ffi_type_uint32); rep_INTERN (ffi_type_sint32); rep_INTERN (ffi_type_uint64); rep_INTERN (ffi_type_sint64); rep_INTERN (ffi_type_float); rep_INTERN (ffi_type_double); rep_INTERN (ffi_type_longdouble); rep_INTERN (ffi_type_pointer); #ifdef HAVE_LIBFFI Fset (Qffi_type_void, ffi_add_primitive_type (&ffi_type_void)); Fset (Qffi_type_uint8, ffi_add_primitive_type (&ffi_type_uint8)); Fset (Qffi_type_sint8, ffi_add_primitive_type (&ffi_type_sint8)); Fset (Qffi_type_uint16, ffi_add_primitive_type (&ffi_type_uint16)); Fset (Qffi_type_sint16, ffi_add_primitive_type (&ffi_type_sint16)); Fset (Qffi_type_uint32, ffi_add_primitive_type (&ffi_type_uint32)); Fset (Qffi_type_sint32, ffi_add_primitive_type (&ffi_type_sint32)); Fset (Qffi_type_uint64, ffi_add_primitive_type (&ffi_type_uint64)); Fset (Qffi_type_sint64, ffi_add_primitive_type (&ffi_type_sint64)); Fset (Qffi_type_float, ffi_add_primitive_type (&ffi_type_float)); Fset (Qffi_type_double, ffi_add_primitive_type (&ffi_type_double)); Fset (Qffi_type_longdouble, ffi_add_primitive_type (&ffi_type_longdouble)); Fset (Qffi_type_pointer, ffi_add_primitive_type (&ffi_type_pointer)); #else Fset (Qffi_type_void, Qnil); Fset (Qffi_type_uint8, Qnil); Fset (Qffi_type_sint8, Qnil); Fset (Qffi_type_uint16, Qnil); Fset (Qffi_type_sint16, Qnil); Fset (Qffi_type_uint32, Qnil); Fset (Qffi_type_sint32, Qnil); Fset (Qffi_type_uint64, Qnil); Fset (Qffi_type_sint64, Qnil); Fset (Qffi_type_float, Qnil); Fset (Qffi_type_double, Qnil); Fset (Qffi_type_longdouble, Qnil); Fset (Qffi_type_pointer, Qnil); #endif Fexport_binding (Qffi_type_void); Fexport_binding (Qffi_type_uint8); Fexport_binding (Qffi_type_sint8); Fexport_binding (Qffi_type_uint16); Fexport_binding (Qffi_type_sint16); Fexport_binding (Qffi_type_uint32); Fexport_binding (Qffi_type_sint32); Fexport_binding (Qffi_type_uint64); Fexport_binding (Qffi_type_sint64); Fexport_binding (Qffi_type_float); Fexport_binding (Qffi_type_double); Fexport_binding (Qffi_type_longdouble); Fexport_binding (Qffi_type_pointer); rep_ADD_SUBR (Sffi_struct); rep_ADD_SUBR (Sffi_type); rep_ADD_SUBR (Sffi_interface); rep_ADD_SUBR (Sffi_apply); rep_ADD_SUBR (Sffi_load_library); rep_ADD_SUBR (Sffi_lookup_symbol); rep_ADD_SUBR (Sffi_new); rep_ADD_SUBR (Sffi_delete); rep_ADD_SUBR (Sffi_address_of); rep_ADD_SUBR (Sffi_set_); rep_ADD_SUBR (Sffi_get); return rep_pop_structure (tem); } librep-0.90.2/src/fake-libexec0000755000175200017520000000113111245011153015106 0ustar chrischris#! /bin/sh # fake the module hierarchy for uninstalled shared objects libdir="`pwd`/.libs" libexecdir="./.libexec" libs="rep.io.db.gdbm rep.io.db.sdbm rep.i18n.gettext rep.io.readline \ rep.lang.record-profile rep.data.tables rep.io.timers \ rep.vm.safe-interpreter rep.io.sockets rep.util.md5 rep.ffi" rm -rf $libexecdir for f in $libs; do g=`echo $f | tr . /` src=$libdir dest=$libexecdir/`dirname $g` for b in `( cd $libdir && echo *\`basename $g\`* )`; do rm -f $dest/$b echo "$src/$b -> $dest/$b" ../mkinstalldirs $dest ln -s $src/$b $dest/$b done done librep-0.90.2/src/dlmalloc.c0000644000175200017520000030530211245011153014603 0ustar chrischris/* ---------- To make a malloc.h, start cutting here ------------ */ /* A version of malloc/free/realloc written by Doug Lea and released to the public domain. Send questions/comments/complaints/performance data to dl@cs.oswego.edu * VERSION 2.6.5 Wed Jun 17 15:55:16 1998 Doug Lea (dl at gee) Note: There may be an updated version of this malloc obtainable at ftp://g.oswego.edu/pub/misc/malloc.c Check before installing! Note: This version differs from 2.6.4 only by correcting a statement ordering error that could cause failures only when calls to this malloc are interposed with calls to other memory allocators. * Why use this malloc? This is not the fastest, most space-conserving, most portable, or most tunable malloc ever written. However it is among the fastest while also being among the most space-conserving, portable and tunable. Consistent balance across these factors results in a good general-purpose allocator. For a high-level description, see http://g.oswego.edu/dl/html/malloc.html * Synopsis of public routines (Much fuller descriptions are contained in the program documentation below.) malloc(size_t n); Return a pointer to a newly allocated chunk of at least n bytes, or null if no space is available. free(Void_t* p); Release the chunk of memory pointed to by p, or no effect if p is null. realloc(Void_t* p, size_t n); Return a pointer to a chunk of size n that contains the same data as does chunk p up to the minimum of (n, p's size) bytes, or null if no space is available. The returned pointer may or may not be the same as p. If p is null, equivalent to malloc. Unless the #define REALLOC_ZERO_BYTES_FREES below is set, realloc with a size argument of zero (re)allocates a minimum-sized chunk. memalign(size_t alignment, size_t n); Return a pointer to a newly allocated chunk of n bytes, aligned in accord with the alignment argument, which must be a power of two. valloc(size_t n); Equivalent to memalign(pagesize, n), where pagesize is the page size of the system (or as near to this as can be figured out from all the includes/defines below.) pvalloc(size_t n); Equivalent to valloc(minimum-page-that-holds(n)), that is, round up n to nearest pagesize. calloc(size_t unit, size_t quantity); Returns a pointer to quantity * unit bytes, with all locations set to zero. cfree(Void_t* p); Equivalent to free(p). malloc_trim(size_t pad); Release all but pad bytes of freed top-most memory back to the system. Return 1 if successful, else 0. malloc_usable_size(Void_t* p); Report the number usable allocated bytes associated with allocated chunk p. This may or may not report more bytes than were requested, due to alignment and minimum size constraints. malloc_stats(); Prints brief summary statistics on stderr. mallinfo() Returns (by copy) a struct containing various summary statistics. mallopt(int parameter_number, int parameter_value) Changes one of the tunable parameters described below. Returns 1 if successful in changing the parameter, else 0. * Vital statistics: Alignment: 8-byte 8 byte alignment is currently hardwired into the design. This seems to suffice for all current machines and C compilers. Assumed pointer representation: 4 or 8 bytes Code for 8-byte pointers is untested by me but has worked reliably by Wolfram Gloger, who contributed most of the changes supporting this. Assumed size_t representation: 4 or 8 bytes Note that size_t is allowed to be 4 bytes even if pointers are 8. Minimum overhead per allocated chunk: 4 or 8 bytes Each malloced chunk has a hidden overhead of 4 bytes holding size and status information. Minimum allocated size: 4-byte ptrs: 16 bytes (including 4 overhead) 8-byte ptrs: 24/32 bytes (including, 4/8 overhead) When a chunk is freed, 12 (for 4byte ptrs) or 20 (for 8 byte ptrs but 4 byte size) or 24 (for 8/8) additional bytes are needed; 4 (8) for a trailing size field and 8 (16) bytes for free list pointers. Thus, the minimum allocatable size is 16/24/32 bytes. Even a request for zero bytes (i.e., malloc(0)) returns a pointer to something of the minimum allocatable size. Maximum allocated size: 4-byte size_t: 2^31 - 8 bytes 8-byte size_t: 2^63 - 16 bytes It is assumed that (possibly signed) size_t bit values suffice to represent chunk sizes. `Possibly signed' is due to the fact that `size_t' may be defined on a system as either a signed or an unsigned type. To be conservative, values that would appear as negative numbers are avoided. Requests for sizes with a negative sign bit will return a minimum-sized chunk. Maximum overhead wastage per allocated chunk: normally 15 bytes Alignnment demands, plus the minimum allocatable size restriction make the normal worst-case wastage 15 bytes (i.e., up to 15 more bytes will be allocated than were requested in malloc), with two exceptions: 1. Because requests for zero bytes allocate non-zero space, the worst case wastage for a request of zero bytes is 24 bytes. 2. For requests >= mmap_threshold that are serviced via mmap(), the worst case wastage is 8 bytes plus the remainder from a system page (the minimal mmap unit); typically 4096 bytes. * Limitations Here are some features that are NOT currently supported * No user-definable hooks for callbacks and the like. * No automated mechanism for fully checking that all accesses to malloced memory stay within their bounds. * No support for compaction. * Synopsis of compile-time options: People have reported using previous versions of this malloc on all versions of Unix, sometimes by tweaking some of the defines below. It has been tested most extensively on Solaris and Linux. It is also reported to work on WIN32 platforms. People have also reported adapting this malloc for use in stand-alone embedded systems. The implementation is in straight, hand-tuned ANSI C. Among other consequences, it uses a lot of macros. Because of this, to be at all usable, this code should be compiled using an optimizing compiler (for example gcc -O2) that can simplify expressions and control paths. __STD_C (default: derived from C compiler defines) Nonzero if using ANSI-standard C compiler, a C++ compiler, or a C compiler sufficiently close to ANSI to get away with it. DEBUG (default: NOT defined) Define to enable debugging. Adds fairly extensive assertion-based checking to help track down memory errors, but noticeably slows down execution. REALLOC_ZERO_BYTES_FREES (default: NOT defined) Define this if you think that realloc(p, 0) should be equivalent to free(p). Otherwise, since malloc returns a unique pointer for malloc(0), so does realloc(p, 0). HAVE_MEMCPY (default: defined) Define if you are not otherwise using ANSI STD C, but still have memcpy and memset in your C library and want to use them. Otherwise, simple internal versions are supplied. USE_MEMCPY (default: 1 if HAVE_MEMCPY is defined, 0 otherwise) Define as 1 if you want the C library versions of memset and memcpy called in realloc and calloc (otherwise macro versions are used). At least on some platforms, the simple macro versions usually outperform libc versions. HAVE_MMAP (default: defined as 1) Define to non-zero to optionally make malloc() use mmap() to allocate very large blocks. HAVE_MREMAP (default: defined as 0 unless Linux libc set) Define to non-zero to optionally make realloc() use mremap() to reallocate very large blocks. malloc_getpagesize (default: derived from system #includes) Either a constant or routine call returning the system page size. HAVE_USR_INCLUDE_MALLOC_H (default: NOT defined) Optionally define if you are on a system with a /usr/include/malloc.h that declares struct mallinfo. It is not at all necessary to define this even if you do, but will ensure consistency. INTERNAL_SIZE_T (default: size_t) Define to a 32-bit type (probably `unsigned int') if you are on a 64-bit machine, yet do not want or need to allow malloc requests of greater than 2^31 to be handled. This saves space, especially for very small chunks. INTERNAL_LINUX_C_LIB (default: NOT defined) Defined only when compiled as part of Linux libc. Also note that there is some odd internal name-mangling via defines (for example, internally, `malloc' is named `mALLOc') needed when compiling in this case. These look funny but don't otherwise affect anything. WIN32 (default: undefined) Define this on MS win (95, nt) platforms to compile in sbrk emulation. LACKS_UNISTD_H (default: undefined) Define this if your system does not have a . MORECORE (default: sbrk) The name of the routine to call to obtain more memory from the system. MORECORE_FAILURE (default: -1) The value returned upon failure of MORECORE. MORECORE_CLEARS (default 1) True (1) if the routine mapped to MORECORE zeroes out memory (which holds for sbrk). DEFAULT_TRIM_THRESHOLD DEFAULT_TOP_PAD DEFAULT_MMAP_THRESHOLD DEFAULT_MMAP_MAX Default values of tunable parameters (described in detail below) controlling interaction with host system routines (sbrk, mmap, etc). These values may also be changed dynamically via mallopt(). The preset defaults are those that give best performance for typical programs/systems. */ /* Preliminaries */ #ifndef __STD_C #ifdef __STDC__ #define __STD_C 1 #else #if __cplusplus #define __STD_C 1 #else #define __STD_C 0 #endif /*__cplusplus*/ #endif /*__STDC__*/ #endif /*__STD_C*/ #ifndef Void_t #if __STD_C #define Void_t void #else #define Void_t char #endif #endif /*Void_t*/ #if __STD_C #include /* for size_t */ #else #include #endif #ifdef __cplusplus extern "C" { #endif #include /* needed for malloc_stats */ /* Compile-time options */ /* Debugging: Because freed chunks may be overwritten with link fields, this malloc will often die when freed memory is overwritten by user programs. This can be very effective (albeit in an annoying way) in helping track down dangling pointers. If you compile with -DDEBUG, a number of assertion checks are enabled that will catch more memory errors. You probably won't be able to make much sense of the actual assertion errors, but they should help you locate incorrectly overwritten memory. The checking is fairly extensive, and will slow down execution noticeably. Calling malloc_stats or mallinfo with DEBUG set will attempt to check every non-mmapped allocated and free chunk in the course of computing the summmaries. (By nature, mmapped regions cannot be checked very much automatically.) Setting DEBUG may also be helpful if you are trying to modify this code. The assertions in the check routines spell out in more detail the assumptions and invariants underlying the algorithms. */ #if DEBUG #include #else #define assert(x) ((void)0) #endif /* INTERNAL_SIZE_T is the word-size used for internal bookkeeping of chunk sizes. On a 64-bit machine, you can reduce malloc overhead by defining INTERNAL_SIZE_T to be a 32 bit `unsigned int' at the expense of not being able to handle requests greater than 2^31. This limitation is hardly ever a concern; you are encouraged to set this. However, the default version is the same as size_t. */ #ifndef INTERNAL_SIZE_T #define INTERNAL_SIZE_T size_t #endif /* REALLOC_ZERO_BYTES_FREES should be set if a call to realloc with zero bytes should be the same as a call to free. Some people think it should. Otherwise, since this malloc returns a unique pointer for malloc(0), so does realloc(p, 0). */ /* #define REALLOC_ZERO_BYTES_FREES */ /* WIN32 causes an emulation of sbrk to be compiled in mmap-based options are not currently supported in WIN32. */ /* #define WIN32 */ #ifdef WIN32 #define MORECORE wsbrk #define HAVE_MMAP 0 #endif /* HAVE_MEMCPY should be defined if you are not otherwise using ANSI STD C, but still have memcpy and memset in your C library and want to use them in calloc and realloc. Otherwise simple macro versions are defined here. USE_MEMCPY should be defined as 1 if you actually want to have memset and memcpy called. People report that the macro versions are often enough faster than libc versions on many systems that it is better to use them. */ #define HAVE_MEMCPY #ifndef USE_MEMCPY #ifdef HAVE_MEMCPY #define USE_MEMCPY 1 #else #define USE_MEMCPY 0 #endif #endif #if (__STD_C || defined(HAVE_MEMCPY)) #if __STD_C void* memset(void*, int, size_t); void* memcpy(void*, const void*, size_t); #else Void_t* memset(); Void_t* memcpy(); #endif #endif #if USE_MEMCPY /* The following macros are only invoked with (2n+1)-multiples of INTERNAL_SIZE_T units, with a positive integer n. This is exploited for fast inline execution when n is small. */ #define MALLOC_ZERO(charp, nbytes) \ do { \ INTERNAL_SIZE_T mzsz = (nbytes); \ if(mzsz <= 9*sizeof(mzsz)) { \ INTERNAL_SIZE_T* mz = (INTERNAL_SIZE_T*) (charp); \ if(mzsz >= 5*sizeof(mzsz)) { *mz++ = 0; \ *mz++ = 0; \ if(mzsz >= 7*sizeof(mzsz)) { *mz++ = 0; \ *mz++ = 0; \ if(mzsz >= 9*sizeof(mzsz)) { *mz++ = 0; \ *mz++ = 0; }}} \ *mz++ = 0; \ *mz++ = 0; \ *mz = 0; \ } else memset((charp), 0, mzsz); \ } while(0) #define MALLOC_COPY(dest,src,nbytes) \ do { \ INTERNAL_SIZE_T mcsz = (nbytes); \ if(mcsz <= 9*sizeof(mcsz)) { \ INTERNAL_SIZE_T* mcsrc = (INTERNAL_SIZE_T*) (src); \ INTERNAL_SIZE_T* mcdst = (INTERNAL_SIZE_T*) (dest); \ if(mcsz >= 5*sizeof(mcsz)) { *mcdst++ = *mcsrc++; \ *mcdst++ = *mcsrc++; \ if(mcsz >= 7*sizeof(mcsz)) { *mcdst++ = *mcsrc++; \ *mcdst++ = *mcsrc++; \ if(mcsz >= 9*sizeof(mcsz)) { *mcdst++ = *mcsrc++; \ *mcdst++ = *mcsrc++; }}} \ *mcdst++ = *mcsrc++; \ *mcdst++ = *mcsrc++; \ *mcdst = *mcsrc ; \ } else memcpy(dest, src, mcsz); \ } while(0) #else /* !USE_MEMCPY */ /* Use Duff's device for good zeroing/copying performance. */ #define MALLOC_ZERO(charp, nbytes) \ do { \ INTERNAL_SIZE_T* mzp = (INTERNAL_SIZE_T*)(charp); \ long mctmp = (nbytes)/sizeof(INTERNAL_SIZE_T), mcn; \ if (mctmp < 8) mcn = 0; else { mcn = (mctmp-1)/8; mctmp %= 8; } \ switch (mctmp) { \ case 0: for(;;) { *mzp++ = 0; \ case 7: *mzp++ = 0; \ case 6: *mzp++ = 0; \ case 5: *mzp++ = 0; \ case 4: *mzp++ = 0; \ case 3: *mzp++ = 0; \ case 2: *mzp++ = 0; \ case 1: *mzp++ = 0; if(mcn <= 0) break; mcn--; } \ } \ } while(0) #define MALLOC_COPY(dest,src,nbytes) \ do { \ INTERNAL_SIZE_T* mcsrc = (INTERNAL_SIZE_T*) src; \ INTERNAL_SIZE_T* mcdst = (INTERNAL_SIZE_T*) dest; \ long mctmp = (nbytes)/sizeof(INTERNAL_SIZE_T), mcn; \ if (mctmp < 8) mcn = 0; else { mcn = (mctmp-1)/8; mctmp %= 8; } \ switch (mctmp) { \ case 0: for(;;) { *mcdst++ = *mcsrc++; \ case 7: *mcdst++ = *mcsrc++; \ case 6: *mcdst++ = *mcsrc++; \ case 5: *mcdst++ = *mcsrc++; \ case 4: *mcdst++ = *mcsrc++; \ case 3: *mcdst++ = *mcsrc++; \ case 2: *mcdst++ = *mcsrc++; \ case 1: *mcdst++ = *mcsrc++; if(mcn <= 0) break; mcn--; } \ } \ } while(0) #endif /* Define HAVE_MMAP to optionally make malloc() use mmap() to allocate very large blocks. These will be returned to the operating system immediately after a free(). */ #ifndef HAVE_MMAP #define HAVE_MMAP 1 #endif /* Define HAVE_MREMAP to make realloc() use mremap() to re-allocate large blocks. This is currently only possible on Linux with kernel versions newer than 1.3.77. */ #ifndef HAVE_MREMAP #ifdef INTERNAL_LINUX_C_LIB #define HAVE_MREMAP 1 #else #define HAVE_MREMAP 0 #endif #endif #if HAVE_MMAP #include #include #include #if !defined(MAP_ANONYMOUS) && defined(MAP_ANON) #define MAP_ANONYMOUS MAP_ANON #endif #endif /* HAVE_MMAP */ /* Access to system page size. To the extent possible, this malloc manages memory from the system in page-size units. The following mechanics for getpagesize were adapted from bsd/gnu getpagesize.h */ #ifndef LACKS_UNISTD_H # include #endif #ifndef malloc_getpagesize # ifdef _SC_PAGESIZE /* some SVR4 systems omit an underscore */ # ifndef _SC_PAGE_SIZE # define _SC_PAGE_SIZE _SC_PAGESIZE # endif # endif # ifdef _SC_PAGE_SIZE # define malloc_getpagesize sysconf(_SC_PAGE_SIZE) # else # if defined(BSD) || defined(DGUX) || defined(HAVE_GETPAGESIZE) extern size_t getpagesize(); # define malloc_getpagesize getpagesize() # else # include # ifdef EXEC_PAGESIZE # define malloc_getpagesize EXEC_PAGESIZE # else # ifdef NBPG # ifndef CLSIZE # define malloc_getpagesize NBPG # else # define malloc_getpagesize (NBPG * CLSIZE) # endif # else # ifdef NBPC # define malloc_getpagesize NBPC # else # ifdef PAGESIZE # define malloc_getpagesize PAGESIZE # else # define malloc_getpagesize (4096) /* just guess */ # endif # endif # endif # endif # endif # endif #endif /* This version of malloc supports the standard SVID/XPG mallinfo routine that returns a struct containing the same kind of information you can get from malloc_stats. It should work on any SVID/XPG compliant system that has a /usr/include/malloc.h defining struct mallinfo. (If you'd like to install such a thing yourself, cut out the preliminary declarations as described above and below and save them in a malloc.h file. But there's no compelling reason to bother to do this.) The main declaration needed is the mallinfo struct that is returned (by-copy) by mallinfo(). The SVID/XPG malloinfo struct contains a bunch of fields, most of which are not even meaningful in this version of malloc. Some of these fields are are instead filled by mallinfo() with other numbers that might possibly be of interest. HAVE_USR_INCLUDE_MALLOC_H should be set if you have a /usr/include/malloc.h file that includes a declaration of struct mallinfo. If so, it is included; else an SVID2/XPG2 compliant version is declared below. These must be precisely the same for mallinfo() to work. */ /* #define HAVE_USR_INCLUDE_MALLOC_H */ #if HAVE_USR_INCLUDE_MALLOC_H #include "/usr/include/malloc.h" #else /* SVID2/XPG mallinfo structure */ struct mallinfo { int arena; /* total space allocated from system */ int ordblks; /* number of non-inuse chunks */ int smblks; /* unused -- always zero */ int hblks; /* number of mmapped regions */ int hblkhd; /* total space in mmapped regions */ int usmblks; /* unused -- always zero */ int fsmblks; /* unused -- always zero */ int uordblks; /* total allocated space */ int fordblks; /* total non-inuse space */ int keepcost; /* top-most, releasable (via malloc_trim) space */ }; /* SVID2/XPG mallopt options */ #define M_MXFAST 1 /* UNUSED in this malloc */ #define M_NLBLKS 2 /* UNUSED in this malloc */ #define M_GRAIN 3 /* UNUSED in this malloc */ #define M_KEEP 4 /* UNUSED in this malloc */ #endif /* mallopt options that actually do something */ #define M_TRIM_THRESHOLD -1 #define M_TOP_PAD -2 #define M_MMAP_THRESHOLD -3 #define M_MMAP_MAX -4 #ifndef DEFAULT_TRIM_THRESHOLD #define DEFAULT_TRIM_THRESHOLD (128 * 1024) #endif /* M_TRIM_THRESHOLD is the maximum amount of unused top-most memory to keep before releasing via malloc_trim in free(). Automatic trimming is mainly useful in long-lived programs. Because trimming via sbrk can be slow on some systems, and can sometimes be wasteful (in cases where programs immediately afterward allocate more large chunks) the value should be high enough so that your overall system performance would improve by releasing. The trim threshold and the mmap control parameters (see below) can be traded off with one another. Trimming and mmapping are two different ways of releasing unused memory back to the system. Between these two, it is often possible to keep system-level demands of a long-lived program down to a bare minimum. For example, in one test suite of sessions measuring the XF86 X server on Linux, using a trim threshold of 128K and a mmap threshold of 192K led to near-minimal long term resource consumption. If you are using this malloc in a long-lived program, it should pay to experiment with these values. As a rough guide, you might set to a value close to the average size of a process (program) running on your system. Releasing this much memory would allow such a process to run in memory. Generally, it's worth it to tune for trimming rather tham memory mapping when a program undergoes phases where several large chunks are allocated and released in ways that can reuse each other's storage, perhaps mixed with phases where there are no such chunks at all. And in well-behaved long-lived programs, controlling release of large blocks via trimming versus mapping is usually faster. However, in most programs, these parameters serve mainly as protection against the system-level effects of carrying around massive amounts of unneeded memory. Since frequent calls to sbrk, mmap, and munmap otherwise degrade performance, the default parameters are set to relatively high values that serve only as safeguards. The default trim value is high enough to cause trimming only in fairly extreme (by current memory consumption standards) cases. It must be greater than page size to have any useful effect. To disable trimming completely, you can set to (unsigned long)(-1); */ #ifndef DEFAULT_TOP_PAD #define DEFAULT_TOP_PAD (0) #endif /* M_TOP_PAD is the amount of extra `padding' space to allocate or retain whenever sbrk is called. It is used in two ways internally: * When sbrk is called to extend the top of the arena to satisfy a new malloc request, this much padding is added to the sbrk request. * When malloc_trim is called automatically from free(), it is used as the `pad' argument. In both cases, the actual amount of padding is rounded so that the end of the arena is always a system page boundary. The main reason for using padding is to avoid calling sbrk so often. Having even a small pad greatly reduces the likelihood that nearly every malloc request during program start-up (or after trimming) will invoke sbrk, which needlessly wastes time. Automatic rounding-up to page-size units is normally sufficient to avoid measurable overhead, so the default is 0. However, in systems where sbrk is relatively slow, it can pay to increase this value, at the expense of carrying around more memory than the program needs. */ #ifndef DEFAULT_MMAP_THRESHOLD #define DEFAULT_MMAP_THRESHOLD (128 * 1024) #endif /* M_MMAP_THRESHOLD is the request size threshold for using mmap() to service a request. Requests of at least this size that cannot be allocated using already-existing space will be serviced via mmap. (If enough normal freed space already exists it is used instead.) Using mmap segregates relatively large chunks of memory so that they can be individually obtained and released from the host system. A request serviced through mmap is never reused by any other request (at least not directly; the system may just so happen to remap successive requests to the same locations). Segregating space in this way has the benefit that mmapped space can ALWAYS be individually released back to the system, which helps keep the system level memory demands of a long-lived program low. Mapped memory can never become `locked' between other chunks, as can happen with normally allocated chunks, which menas that even trimming via malloc_trim would not release them. However, it has the disadvantages that: 1. The space cannot be reclaimed, consolidated, and then used to service later requests, as happens with normal chunks. 2. It can lead to more wastage because of mmap page alignment requirements 3. It causes malloc performance to be more dependent on host system memory management support routines which may vary in implementation quality and may impose arbitrary limitations. Generally, servicing a request via normal malloc steps is faster than going through a system's mmap. All together, these considerations should lead you to use mmap only for relatively large requests. */ #ifndef DEFAULT_MMAP_MAX #if HAVE_MMAP #define DEFAULT_MMAP_MAX (64) #else #define DEFAULT_MMAP_MAX (0) #endif #endif /* M_MMAP_MAX is the maximum number of requests to simultaneously service using mmap. This parameter exists because: 1. Some systems have a limited number of internal tables for use by mmap. 2. In most systems, overreliance on mmap can degrade overall performance. 3. If a program allocates many large regions, it is probably better off using normal sbrk-based allocation routines that can reclaim and reallocate normal heap memory. Using a small value allows transition into this mode after the first few allocations. Setting to 0 disables all use of mmap. If HAVE_MMAP is not set, the default value is 0, and attempts to set it to non-zero values in mallopt will fail. */ /* Special defines for linux libc Except when compiled using these special defines for Linux libc using weak aliases, this malloc is NOT designed to work in multithreaded applications. No semaphores or other concurrency control are provided to ensure that multiple malloc or free calls don't run at the same time, which could be disasterous. A single semaphore could be used across malloc, realloc, and free (which is essentially the effect of the linux weak alias approach). It would be hard to obtain finer granularity. */ #if defined(INTERNAL_LINUX_C_LIB) #if __STD_C Void_t * __default_morecore_init (ptrdiff_t); Void_t *(*__morecore)(ptrdiff_t) = __default_morecore_init; #else Void_t * __default_morecore_init (); Void_t *(*__morecore)() = __default_morecore_init; #endif #define MORECORE (*__morecore) #define MORECORE_FAILURE 0 #define MORECORE_CLEARS 1 #else /* INTERNAL_LINUX_C_LIB */ #if !defined(__FreeBSD__) && !defined(__OpenBSD__) && !defined(__NetBSD__) #if __STD_C extern Void_t* sbrk(ptrdiff_t); #else extern Void_t* sbrk(); #endif #endif #ifndef MORECORE #define MORECORE sbrk #endif #ifndef MORECORE_FAILURE #define MORECORE_FAILURE -1 #endif #ifndef MORECORE_CLEARS #define MORECORE_CLEARS 1 #endif #endif /* INTERNAL_LINUX_C_LIB */ #if defined(INTERNAL_LINUX_C_LIB) && defined(__ELF__) #define cALLOc __libc_calloc #define fREe __libc_free #define mALLOc __libc_malloc #define mEMALIGn __libc_memalign #define rEALLOc __libc_realloc #define vALLOc __libc_valloc #define pvALLOc __libc_pvalloc #define mALLINFo __libc_mallinfo #define mALLOPt __libc_mallopt #pragma weak calloc = __libc_calloc #pragma weak free = __libc_free #pragma weak cfree = __libc_free #pragma weak malloc = __libc_malloc #pragma weak memalign = __libc_memalign #pragma weak realloc = __libc_realloc #pragma weak valloc = __libc_valloc #pragma weak pvalloc = __libc_pvalloc #pragma weak mallinfo = __libc_mallinfo #pragma weak mallopt = __libc_mallopt #else #define cALLOc calloc #define fREe free #define mALLOc malloc #define mEMALIGn memalign #define rEALLOc realloc #define vALLOc valloc #define pvALLOc pvalloc #define mALLINFo mallinfo #define mALLOPt mallopt #endif /* Public routines */ #if __STD_C Void_t* mALLOc(size_t); void fREe(Void_t*); Void_t* rEALLOc(Void_t*, size_t); Void_t* mEMALIGn(size_t, size_t); Void_t* vALLOc(size_t); Void_t* pvALLOc(size_t); Void_t* cALLOc(size_t, size_t); void cfree(Void_t*); int malloc_trim(size_t); size_t malloc_usable_size(Void_t*); void malloc_stats(); int mALLOPt(int, int); struct mallinfo mALLINFo(void); #else Void_t* mALLOc(); void fREe(); Void_t* rEALLOc(); Void_t* mEMALIGn(); Void_t* vALLOc(); Void_t* pvALLOc(); Void_t* cALLOc(); void cfree(); int malloc_trim(); size_t malloc_usable_size(); void malloc_stats(); int mALLOPt(); struct mallinfo mALLINFo(); #endif #ifdef __cplusplus }; /* end of extern "C" */ #endif /* ---------- To make a malloc.h, end cutting here ------------ */ /* Emulation of sbrk for WIN32 All code within the ifdef WIN32 is untested by me. */ #ifdef WIN32 #define AlignPage(add) (((add) + (malloc_getpagesize-1)) & ~(malloc_getpagesize-1)) /* resrve 64MB to insure large contiguous space */ #define RESERVED_SIZE (1024*1024*64) #define NEXT_SIZE (2048*1024) #define TOP_MEMORY ((unsigned long)2*1024*1024*1024) struct GmListElement; typedef struct GmListElement GmListElement; struct GmListElement { GmListElement* next; void* base; }; static GmListElement* head = 0; static unsigned int gNextAddress = 0; static unsigned int gAddressBase = 0; static unsigned int gAllocatedSize = 0; static GmListElement* makeGmListElement (void* bas) { GmListElement* this; this = (GmListElement*)(void*)LocalAlloc (0, sizeof (GmListElement)); ASSERT (this); if (this) { this->base = bas; this->next = head; head = this; } return this; } void gcleanup () { BOOL rval; ASSERT ( (head == NULL) || (head->base == (void*)gAddressBase)); if (gAddressBase && (gNextAddress - gAddressBase)) { rval = VirtualFree ((void*)gAddressBase, gNextAddress - gAddressBase, MEM_DECOMMIT); ASSERT (rval); } while (head) { GmListElement* next = head->next; rval = VirtualFree (head->base, 0, MEM_RELEASE); ASSERT (rval); LocalFree (head); head = next; } } static void* findRegion (void* start_address, unsigned long size) { MEMORY_BASIC_INFORMATION info; while ((unsigned long)start_address < TOP_MEMORY) { VirtualQuery (start_address, &info, sizeof (info)); if (info.State != MEM_FREE) start_address = (char*)info.BaseAddress + info.RegionSize; else if (info.RegionSize >= size) return start_address; else start_address = (char*)info.BaseAddress + info.RegionSize; } return NULL; } void* wsbrk (long size) { void* tmp; if (size > 0) { if (gAddressBase == 0) { gAllocatedSize = max (RESERVED_SIZE, AlignPage (size)); gNextAddress = gAddressBase = (unsigned int)VirtualAlloc (NULL, gAllocatedSize, MEM_RESERVE, PAGE_NOACCESS); } else if (AlignPage (gNextAddress + size) > (gAddressBase + gAllocatedSize)) { long new_size = max (NEXT_SIZE, AlignPage (size)); void* new_address = (void*)(gAddressBase+gAllocatedSize); do { new_address = findRegion (new_address, new_size); if (new_address == 0) return (void*)-1; gAddressBase = gNextAddress = (unsigned int)VirtualAlloc (new_address, new_size, MEM_RESERVE, PAGE_NOACCESS); /* repeat in case of race condition The region that we found has been snagged by another thread */ } while (gAddressBase == 0); ASSERT (new_address == (void*)gAddressBase); gAllocatedSize = new_size; if (!makeGmListElement ((void*)gAddressBase)) return (void*)-1; } if ((size + gNextAddress) > AlignPage (gNextAddress)) { void* res; res = VirtualAlloc ((void*)AlignPage (gNextAddress), (size + gNextAddress - AlignPage (gNextAddress)), MEM_COMMIT, PAGE_READWRITE); if (res == 0) return (void*)-1; } tmp = (void*)gNextAddress; gNextAddress = (unsigned int)tmp + size; return tmp; } else if (size < 0) { unsigned int alignedGoal = AlignPage (gNextAddress + size); /* Trim by releasing the virtual memory */ if (alignedGoal >= gAddressBase) { VirtualFree ((void*)alignedGoal, gNextAddress - alignedGoal, MEM_DECOMMIT); gNextAddress = gNextAddress + size; return (void*)gNextAddress; } else { VirtualFree ((void*)gAddressBase, gNextAddress - gAddressBase, MEM_DECOMMIT); gNextAddress = gAddressBase; return (void*)-1; } } else { return (void*)gNextAddress; } } #endif /* Type declarations */ struct malloc_chunk { INTERNAL_SIZE_T prev_size; /* Size of previous chunk (if free). */ INTERNAL_SIZE_T size; /* Size in bytes, including overhead. */ struct malloc_chunk* fd; /* double links -- used only if free. */ struct malloc_chunk* bk; }; typedef struct malloc_chunk* mchunkptr; /* malloc_chunk details: (The following includes lightly edited explanations by Colin Plumb.) Chunks of memory are maintained using a `boundary tag' method as described in e.g., Knuth or Standish. (See the paper by Paul Wilson ftp://ftp.cs.utexas.edu/pub/garbage/allocsrv.ps for a survey of such techniques.) Sizes of free chunks are stored both in the front of each chunk and at the end. This makes consolidating fragmented chunks into bigger chunks very fast. The size fields also hold bits representing whether chunks are free or in use. An allocated chunk looks like this: chunk-> +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | Size of previous chunk, if allocated | | +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | Size of chunk, in bytes |P| mem-> +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | User data starts here... . . . . (malloc_usable_space() bytes) . . | nextchunk-> +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | Size of chunk | +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ Where "chunk" is the front of the chunk for the purpose of most of the malloc code, but "mem" is the pointer that is returned to the user. "Nextchunk" is the beginning of the next contiguous chunk. Chunks always begin on even word boundries, so the mem portion (which is returned to the user) is also on an even word boundary, and thus double-word aligned. Free chunks are stored in circular doubly-linked lists, and look like this: chunk-> +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | Size of previous chunk | +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ `head:' | Size of chunk, in bytes |P| mem-> +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | Forward pointer to next chunk in list | +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | Back pointer to previous chunk in list | +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | Unused space (may be 0 bytes long) . . . . | nextchunk-> +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ `foot:' | Size of chunk, in bytes | +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ The P (PREV_INUSE) bit, stored in the unused low-order bit of the chunk size (which is always a multiple of two words), is an in-use bit for the *previous* chunk. If that bit is *clear*, then the word before the current chunk size contains the previous chunk size, and can be used to find the front of the previous chunk. (The very first chunk allocated always has this bit set, preventing access to non-existent (or non-owned) memory.) Note that the `foot' of the current chunk is actually represented as the prev_size of the NEXT chunk. (This makes it easier to deal with alignments etc). The two exceptions to all this are 1. The special chunk `top', which doesn't bother using the trailing size field since there is no next contiguous chunk that would have to index off it. (After initialization, `top' is forced to always exist. If it would become less than MINSIZE bytes long, it is replenished via malloc_extend_top.) 2. Chunks allocated via mmap, which have the second-lowest-order bit (IS_MMAPPED) set in their size fields. Because they are never merged or traversed from any other chunk, they have no foot size or inuse information. Available chunks are kept in any of several places (all declared below): * `av': An array of chunks serving as bin headers for consolidated chunks. Each bin is doubly linked. The bins are approximately proportionally (log) spaced. There are a lot of these bins (128). This may look excessive, but works very well in practice. All procedures maintain the invariant that no consolidated chunk physically borders another one. Chunks in bins are kept in size order, with ties going to the approximately least recently used chunk. The chunks in each bin are maintained in decreasing sorted order by size. This is irrelevant for the small bins, which all contain the same-sized chunks, but facilitates best-fit allocation for larger chunks. (These lists are just sequential. Keeping them in order almost never requires enough traversal to warrant using fancier ordered data structures.) Chunks of the same size are linked with the most recently freed at the front, and allocations are taken from the back. This results in LRU or FIFO allocation order, which tends to give each chunk an equal opportunity to be consolidated with adjacent freed chunks, resulting in larger free chunks and less fragmentation. * `top': The top-most available chunk (i.e., the one bordering the end of available memory) is treated specially. It is never included in any bin, is used only if no other chunk is available, and is released back to the system if it is very large (see M_TRIM_THRESHOLD). * `last_remainder': A bin holding only the remainder of the most recently split (non-top) chunk. This bin is checked before other non-fitting chunks, so as to provide better locality for runs of sequentially allocated chunks. * Implicitly, through the host system's memory mapping tables. If supported, requests greater than a threshold are usually serviced via calls to mmap, and then later released via munmap. */ /* sizes, alignments */ #define SIZE_SZ (sizeof(INTERNAL_SIZE_T)) #define MALLOC_ALIGNMENT (SIZE_SZ + SIZE_SZ) #define MALLOC_ALIGN_MASK (MALLOC_ALIGNMENT - 1) #define MINSIZE (sizeof(struct malloc_chunk)) /* conversion from malloc headers to user pointers, and back */ #define chunk2mem(p) ((Void_t*)((char*)(p) + 2*SIZE_SZ)) #define mem2chunk(mem) ((mchunkptr)((char*)(mem) - 2*SIZE_SZ)) /* pad request bytes into a usable size */ #define request2size(req) \ (((long)((req) + (SIZE_SZ + MALLOC_ALIGN_MASK)) < \ (long)(MINSIZE + MALLOC_ALIGN_MASK)) ? MINSIZE : \ (((req) + (SIZE_SZ + MALLOC_ALIGN_MASK)) & ~(MALLOC_ALIGN_MASK))) /* Check if m has acceptable alignment */ #define aligned_OK(m) (((unsigned long)((m)) & (MALLOC_ALIGN_MASK)) == 0) /* Physical chunk operations */ /* size field is or'ed with PREV_INUSE when previous adjacent chunk in use */ #define PREV_INUSE 0x1 /* size field is or'ed with IS_MMAPPED if the chunk was obtained with mmap() */ #define IS_MMAPPED 0x2 /* Bits to mask off when extracting size */ #define SIZE_BITS (PREV_INUSE|IS_MMAPPED) /* Ptr to next physical malloc_chunk. */ #define next_chunk(p) ((mchunkptr)( ((char*)(p)) + ((p)->size & ~PREV_INUSE) )) /* Ptr to previous physical malloc_chunk */ #define prev_chunk(p)\ ((mchunkptr)( ((char*)(p)) - ((p)->prev_size) )) /* Treat space at ptr + offset as a chunk */ #define chunk_at_offset(p, s) ((mchunkptr)(((char*)(p)) + (s))) /* Dealing with use bits */ /* extract p's inuse bit */ #define inuse(p)\ ((((mchunkptr)(((char*)(p))+((p)->size & ~PREV_INUSE)))->size) & PREV_INUSE) /* extract inuse bit of previous chunk */ #define prev_inuse(p) ((p)->size & PREV_INUSE) /* check for mmap()'ed chunk */ #define chunk_is_mmapped(p) ((p)->size & IS_MMAPPED) /* set/clear chunk as in use without otherwise disturbing */ #define set_inuse(p)\ ((mchunkptr)(((char*)(p)) + ((p)->size & ~PREV_INUSE)))->size |= PREV_INUSE #define clear_inuse(p)\ ((mchunkptr)(((char*)(p)) + ((p)->size & ~PREV_INUSE)))->size &= ~(PREV_INUSE) /* check/set/clear inuse bits in known places */ #define inuse_bit_at_offset(p, s)\ (((mchunkptr)(((char*)(p)) + (s)))->size & PREV_INUSE) #define set_inuse_bit_at_offset(p, s)\ (((mchunkptr)(((char*)(p)) + (s)))->size |= PREV_INUSE) #define clear_inuse_bit_at_offset(p, s)\ (((mchunkptr)(((char*)(p)) + (s)))->size &= ~(PREV_INUSE)) /* Dealing with size fields */ /* Get size, ignoring use bits */ #define chunksize(p) ((p)->size & ~(SIZE_BITS)) /* Set size at head, without disturbing its use bit */ #define set_head_size(p, s) ((p)->size = (((p)->size & PREV_INUSE) | (s))) /* Set size/use ignoring previous bits in header */ #define set_head(p, s) ((p)->size = (s)) /* Set size at footer (only when chunk is not in use) */ #define set_foot(p, s) (((mchunkptr)((char*)(p) + (s)))->prev_size = (s)) /* Bins The bins, `av_' are an array of pairs of pointers serving as the heads of (initially empty) doubly-linked lists of chunks, laid out in a way so that each pair can be treated as if it were in a malloc_chunk. (This way, the fd/bk offsets for linking bin heads and chunks are the same). Bins for sizes < 512 bytes contain chunks of all the same size, spaced 8 bytes apart. Larger bins are approximately logarithmically spaced. (See the table below.) The `av_' array is never mentioned directly in the code, but instead via bin access macros. Bin layout: 64 bins of size 8 32 bins of size 64 16 bins of size 512 8 bins of size 4096 4 bins of size 32768 2 bins of size 262144 1 bin of size what's left There is actually a little bit of slop in the numbers in bin_index for the sake of speed. This makes no difference elsewhere. The special chunks `top' and `last_remainder' get their own bins, (this is implemented via yet more trickery with the av_ array), although `top' is never properly linked to its bin since it is always handled specially. */ #define NAV 128 /* number of bins */ typedef struct malloc_chunk* mbinptr; /* access macros */ #define bin_at(i) ((mbinptr)((char*)&(av_[2*(i) + 2]) - 2*SIZE_SZ)) #define next_bin(b) ((mbinptr)((char*)(b) + 2 * sizeof(mbinptr))) #define prev_bin(b) ((mbinptr)((char*)(b) - 2 * sizeof(mbinptr))) /* The first 2 bins are never indexed. The corresponding av_ cells are instead used for bookkeeping. This is not to save space, but to simplify indexing, maintain locality, and avoid some initialization tests. */ #define top (bin_at(0)->fd) /* The topmost chunk */ #define last_remainder (bin_at(1)) /* remainder from last split */ /* Because top initially points to its own bin with initial zero size, thus forcing extension on the first malloc request, we avoid having any special code in malloc to check whether it even exists yet. But we still need to in malloc_extend_top. */ #define initial_top ((mchunkptr)(bin_at(0))) /* Helper macro to initialize bins */ #define IAV(i) bin_at(i), bin_at(i) static mbinptr av_[NAV * 2 + 2] = { 0, 0, IAV(0), IAV(1), IAV(2), IAV(3), IAV(4), IAV(5), IAV(6), IAV(7), IAV(8), IAV(9), IAV(10), IAV(11), IAV(12), IAV(13), IAV(14), IAV(15), IAV(16), IAV(17), IAV(18), IAV(19), IAV(20), IAV(21), IAV(22), IAV(23), IAV(24), IAV(25), IAV(26), IAV(27), IAV(28), IAV(29), IAV(30), IAV(31), IAV(32), IAV(33), IAV(34), IAV(35), IAV(36), IAV(37), IAV(38), IAV(39), IAV(40), IAV(41), IAV(42), IAV(43), IAV(44), IAV(45), IAV(46), IAV(47), IAV(48), IAV(49), IAV(50), IAV(51), IAV(52), IAV(53), IAV(54), IAV(55), IAV(56), IAV(57), IAV(58), IAV(59), IAV(60), IAV(61), IAV(62), IAV(63), IAV(64), IAV(65), IAV(66), IAV(67), IAV(68), IAV(69), IAV(70), IAV(71), IAV(72), IAV(73), IAV(74), IAV(75), IAV(76), IAV(77), IAV(78), IAV(79), IAV(80), IAV(81), IAV(82), IAV(83), IAV(84), IAV(85), IAV(86), IAV(87), IAV(88), IAV(89), IAV(90), IAV(91), IAV(92), IAV(93), IAV(94), IAV(95), IAV(96), IAV(97), IAV(98), IAV(99), IAV(100), IAV(101), IAV(102), IAV(103), IAV(104), IAV(105), IAV(106), IAV(107), IAV(108), IAV(109), IAV(110), IAV(111), IAV(112), IAV(113), IAV(114), IAV(115), IAV(116), IAV(117), IAV(118), IAV(119), IAV(120), IAV(121), IAV(122), IAV(123), IAV(124), IAV(125), IAV(126), IAV(127) }; /* field-extraction macros */ #define first(b) ((b)->fd) #define last(b) ((b)->bk) /* Indexing into bins */ #define bin_index(sz) \ (((((unsigned long)(sz)) >> 9) == 0) ? (((unsigned long)(sz)) >> 3): \ ((((unsigned long)(sz)) >> 9) <= 4) ? 56 + (((unsigned long)(sz)) >> 6): \ ((((unsigned long)(sz)) >> 9) <= 20) ? 91 + (((unsigned long)(sz)) >> 9): \ ((((unsigned long)(sz)) >> 9) <= 84) ? 110 + (((unsigned long)(sz)) >> 12): \ ((((unsigned long)(sz)) >> 9) <= 340) ? 119 + (((unsigned long)(sz)) >> 15): \ ((((unsigned long)(sz)) >> 9) <= 1364) ? 124 + (((unsigned long)(sz)) >> 18): \ 126) /* bins for chunks < 512 are all spaced 8 bytes apart, and hold identically sized chunks. This is exploited in malloc. */ #define MAX_SMALLBIN 63 #define MAX_SMALLBIN_SIZE 512 #define SMALLBIN_WIDTH 8 #define smallbin_index(sz) (((unsigned long)(sz)) >> 3) /* Requests are `small' if both the corresponding and the next bin are small */ #define is_small_request(nb) (nb < MAX_SMALLBIN_SIZE - SMALLBIN_WIDTH) /* To help compensate for the large number of bins, a one-level index structure is used for bin-by-bin searching. `binblocks' is a one-word bitvector recording whether groups of BINBLOCKWIDTH bins have any (possibly) non-empty bins, so they can be skipped over all at once during during traversals. The bits are NOT always cleared as soon as all bins in a block are empty, but instead only when all are noticed to be empty during traversal in malloc. */ #define BINBLOCKWIDTH 4 /* bins per block */ #define binblocks (bin_at(0)->size) /* bitvector of nonempty blocks */ /* bin<->block macros */ #define idx2binblock(ix) ((unsigned)1 << (ix / BINBLOCKWIDTH)) #define mark_binblock(ii) (binblocks |= idx2binblock(ii)) #define clear_binblock(ii) (binblocks &= ~(idx2binblock(ii))) /* Other static bookkeeping data */ /* variables holding tunable values */ static unsigned long trim_threshold = DEFAULT_TRIM_THRESHOLD; static unsigned long top_pad = DEFAULT_TOP_PAD; static unsigned int n_mmaps_max = DEFAULT_MMAP_MAX; static unsigned long mmap_threshold = DEFAULT_MMAP_THRESHOLD; /* The first value returned from sbrk */ static char* sbrk_base = (char*)(-1); /* The maximum memory obtained from system via sbrk */ static unsigned long max_sbrked_mem = 0; /* The maximum via either sbrk or mmap */ static unsigned long max_total_mem = 0; /* internal working copy of mallinfo */ static struct mallinfo current_mallinfo = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; /* The total memory obtained from system via sbrk */ #define sbrked_mem (current_mallinfo.arena) /* Tracking mmaps */ static unsigned int n_mmaps = 0; static unsigned int max_n_mmaps = 0; static unsigned long mmapped_mem = 0; static unsigned long max_mmapped_mem = 0; /* Debugging support */ #if DEBUG /* These routines make a number of assertions about the states of data structures that should be true at all times. If any are not true, it's very likely that a user program has somehow trashed memory. (It's also possible that there is a coding error in malloc. In which case, please report it!) */ #if __STD_C static void do_check_chunk(mchunkptr p) #else static void do_check_chunk(p) mchunkptr p; #endif { INTERNAL_SIZE_T sz = p->size & ~PREV_INUSE; /* No checkable chunk is mmapped */ assert(!chunk_is_mmapped(p)); /* Check for legal address ... */ assert((char*)p >= sbrk_base); if (p != top) assert((char*)p + sz <= (char*)top); else assert((char*)p + sz <= sbrk_base + sbrked_mem); } #if __STD_C static void do_check_free_chunk(mchunkptr p) #else static void do_check_free_chunk(p) mchunkptr p; #endif { INTERNAL_SIZE_T sz = p->size & ~PREV_INUSE; mchunkptr next = chunk_at_offset(p, sz); do_check_chunk(p); /* Check whether it claims to be free ... */ assert(!inuse(p)); /* Unless a special marker, must have OK fields */ if ((long)sz >= (long)MINSIZE) { assert((sz & MALLOC_ALIGN_MASK) == 0); assert(aligned_OK(chunk2mem(p))); /* ... matching footer field */ assert(next->prev_size == sz); /* ... and is fully consolidated */ assert(prev_inuse(p)); assert (next == top || inuse(next)); /* ... and has minimally sane links */ assert(p->fd->bk == p); assert(p->bk->fd == p); } else /* markers are always of size SIZE_SZ */ assert(sz == SIZE_SZ); } #if __STD_C static void do_check_inuse_chunk(mchunkptr p) #else static void do_check_inuse_chunk(p) mchunkptr p; #endif { mchunkptr next = next_chunk(p); do_check_chunk(p); /* Check whether it claims to be in use ... */ assert(inuse(p)); /* ... and is surrounded by OK chunks. Since more things can be checked with free chunks than inuse ones, if an inuse chunk borders them and debug is on, it's worth doing them. */ if (!prev_inuse(p)) { mchunkptr prv = prev_chunk(p); assert(next_chunk(prv) == p); do_check_free_chunk(prv); } if (next == top) { assert(prev_inuse(next)); assert(chunksize(next) >= MINSIZE); } else if (!inuse(next)) do_check_free_chunk(next); } #if __STD_C static void do_check_malloced_chunk(mchunkptr p, INTERNAL_SIZE_T s) #else static void do_check_malloced_chunk(p, s) mchunkptr p; INTERNAL_SIZE_T s; #endif { INTERNAL_SIZE_T sz = p->size & ~PREV_INUSE; long room = sz - s; do_check_inuse_chunk(p); /* Legal size ... */ assert((long)sz >= (long)MINSIZE); assert((sz & MALLOC_ALIGN_MASK) == 0); assert(room >= 0); assert(room < (long)MINSIZE); /* ... and alignment */ assert(aligned_OK(chunk2mem(p))); /* ... and was allocated at front of an available chunk */ assert(prev_inuse(p)); } #define check_free_chunk(P) do_check_free_chunk(P) #define check_inuse_chunk(P) do_check_inuse_chunk(P) #define check_chunk(P) do_check_chunk(P) #define check_malloced_chunk(P,N) do_check_malloced_chunk(P,N) #else #define check_free_chunk(P) #define check_inuse_chunk(P) #define check_chunk(P) #define check_malloced_chunk(P,N) #endif /* Macro-based internal utilities */ /* Linking chunks in bin lists. Call these only with variables, not arbitrary expressions, as arguments. */ /* Place chunk p of size s in its bin, in size order, putting it ahead of others of same size. */ #define frontlink(P, S, IDX, BK, FD) \ { \ if (S < MAX_SMALLBIN_SIZE) \ { \ IDX = smallbin_index(S); \ mark_binblock(IDX); \ BK = bin_at(IDX); \ FD = BK->fd; \ P->bk = BK; \ P->fd = FD; \ FD->bk = BK->fd = P; \ } \ else \ { \ IDX = bin_index(S); \ BK = bin_at(IDX); \ FD = BK->fd; \ if (FD == BK) mark_binblock(IDX); \ else \ { \ while (FD != BK && S < chunksize(FD)) FD = FD->fd; \ BK = FD->bk; \ } \ P->bk = BK; \ P->fd = FD; \ FD->bk = BK->fd = P; \ } \ } /* take a chunk off a list */ #define unlink(P, BK, FD) \ { \ BK = P->bk; \ FD = P->fd; \ FD->bk = BK; \ BK->fd = FD; \ } \ /* Place p as the last remainder */ #define link_last_remainder(P) \ { \ last_remainder->fd = last_remainder->bk = P; \ P->fd = P->bk = last_remainder; \ } /* Clear the last_remainder bin */ #define clear_last_remainder \ (last_remainder->fd = last_remainder->bk = last_remainder) /* Routines dealing with mmap(). */ #if HAVE_MMAP #if __STD_C static mchunkptr mmap_chunk(size_t size) #else static mchunkptr mmap_chunk(size) size_t size; #endif { size_t page_mask = malloc_getpagesize - 1; mchunkptr p; #ifndef MAP_ANONYMOUS static int fd = -1; #endif if(n_mmaps >= n_mmaps_max) return 0; /* too many regions */ /* For mmapped chunks, the overhead is one SIZE_SZ unit larger, because * there is no following chunk whose prev_size field could be used. */ size = (size + SIZE_SZ + page_mask) & ~page_mask; #ifdef MAP_ANONYMOUS p = (mchunkptr)mmap(0, size, PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0); #else /* !MAP_ANONYMOUS */ if (fd < 0) { fd = open("/dev/zero", O_RDWR); if(fd < 0) return 0; } p = (mchunkptr)mmap(0, size, PROT_READ|PROT_WRITE, MAP_PRIVATE, fd, 0); #endif if(p == (mchunkptr)-1) return 0; n_mmaps++; if (n_mmaps > max_n_mmaps) max_n_mmaps = n_mmaps; /* We demand that eight bytes into a page must be 8-byte aligned. */ assert(aligned_OK(chunk2mem(p))); /* The offset to the start of the mmapped region is stored * in the prev_size field of the chunk; normally it is zero, * but that can be changed in memalign(). */ p->prev_size = 0; set_head(p, size|IS_MMAPPED); mmapped_mem += size; if ((unsigned long)mmapped_mem > (unsigned long)max_mmapped_mem) max_mmapped_mem = mmapped_mem; if ((unsigned long)(mmapped_mem + sbrked_mem) > (unsigned long)max_total_mem) max_total_mem = mmapped_mem + sbrked_mem; return p; } #if __STD_C static void munmap_chunk(mchunkptr p) #else static void munmap_chunk(p) mchunkptr p; #endif { INTERNAL_SIZE_T size = chunksize(p); int ret; assert (chunk_is_mmapped(p)); assert(! ((char*)p >= sbrk_base && (char*)p < sbrk_base + sbrked_mem)); assert((n_mmaps > 0)); assert(((p->prev_size + size) & (malloc_getpagesize-1)) == 0); n_mmaps--; mmapped_mem -= (size + p->prev_size); ret = munmap((char *)p - p->prev_size, size + p->prev_size); /* munmap returns non-zero on failure */ assert(ret == 0); } #if HAVE_MREMAP #if __STD_C static mchunkptr mremap_chunk(mchunkptr p, size_t new_size) #else static mchunkptr mremap_chunk(p, new_size) mchunkptr p; size_t new_size; #endif { size_t page_mask = malloc_getpagesize - 1; INTERNAL_SIZE_T offset = p->prev_size; INTERNAL_SIZE_T size = chunksize(p); char *cp; assert (chunk_is_mmapped(p)); assert(! ((char*)p >= sbrk_base && (char*)p < sbrk_base + sbrked_mem)); assert((n_mmaps > 0)); assert(((size + offset) & (malloc_getpagesize-1)) == 0); /* Note the extra SIZE_SZ overhead as in mmap_chunk(). */ new_size = (new_size + offset + SIZE_SZ + page_mask) & ~page_mask; cp = (char *)mremap((char *)p - offset, size + offset, new_size, 1); if (cp == (char *)-1) return 0; p = (mchunkptr)(cp + offset); assert(aligned_OK(chunk2mem(p))); assert((p->prev_size == offset)); set_head(p, (new_size - offset)|IS_MMAPPED); mmapped_mem -= size + offset; mmapped_mem += new_size; if ((unsigned long)mmapped_mem > (unsigned long)max_mmapped_mem) max_mmapped_mem = mmapped_mem; if ((unsigned long)(mmapped_mem + sbrked_mem) > (unsigned long)max_total_mem) max_total_mem = mmapped_mem + sbrked_mem; return p; } #endif /* HAVE_MREMAP */ #endif /* HAVE_MMAP */ /* Extend the top-most chunk by obtaining memory from system. Main interface to sbrk (but see also malloc_trim). */ #if __STD_C static void malloc_extend_top(INTERNAL_SIZE_T nb) #else static void malloc_extend_top(nb) INTERNAL_SIZE_T nb; #endif { char* brk; /* return value from sbrk */ INTERNAL_SIZE_T front_misalign; /* unusable bytes at front of sbrked space */ INTERNAL_SIZE_T correction; /* bytes for 2nd sbrk call */ char* new_brk; /* return of 2nd sbrk call */ INTERNAL_SIZE_T top_size; /* new size of top chunk */ mchunkptr old_top = top; /* Record state of old top */ INTERNAL_SIZE_T old_top_size = chunksize(old_top); char* old_end = (char*)(chunk_at_offset(old_top, old_top_size)); /* Pad request with top_pad plus minimal overhead */ INTERNAL_SIZE_T sbrk_size = nb + top_pad + MINSIZE; unsigned long pagesz = malloc_getpagesize; /* If not the first time through, round to preserve page boundary */ /* Otherwise, we need to correct to a page size below anyway. */ /* (We also correct below if an intervening foreign sbrk call.) */ if (sbrk_base != (char*)(-1)) sbrk_size = (sbrk_size + (pagesz - 1)) & ~(pagesz - 1); brk = (char*)(MORECORE (sbrk_size)); /* Fail if sbrk failed or if a foreign sbrk call killed our space */ if (brk == (char*)(MORECORE_FAILURE) || (brk < old_end && old_top != initial_top)) return; sbrked_mem += sbrk_size; if (brk == old_end) /* can just add bytes to current top */ { top_size = sbrk_size + old_top_size; set_head(top, top_size | PREV_INUSE); } else { if (sbrk_base == (char*)(-1)) /* First time through. Record base */ sbrk_base = brk; else /* Someone else called sbrk(). Count those bytes as sbrked_mem. */ sbrked_mem += brk - (char*)old_end; /* Guarantee alignment of first new chunk made from this space */ front_misalign = (unsigned long)chunk2mem(brk) & MALLOC_ALIGN_MASK; if (front_misalign > 0) { correction = (MALLOC_ALIGNMENT) - front_misalign; brk += correction; } else correction = 0; /* Guarantee the next brk will be at a page boundary */ correction += pagesz - ((unsigned long)(brk + sbrk_size) & (pagesz - 1)); /* Allocate correction */ new_brk = (char*)(MORECORE (correction)); if (new_brk == (char*)(MORECORE_FAILURE)) return; sbrked_mem += correction; top = (mchunkptr)brk; top_size = new_brk - brk + correction; set_head(top, top_size | PREV_INUSE); if (old_top != initial_top) { /* There must have been an intervening foreign sbrk call. */ /* A double fencepost is necessary to prevent consolidation */ /* If not enough space to do this, then user did something very wrong */ if (old_top_size < MINSIZE) { set_head(top, PREV_INUSE); /* will force null return from malloc */ return; } /* Also keep size a multiple of MALLOC_ALIGNMENT */ old_top_size = (old_top_size - 3*SIZE_SZ) & ~MALLOC_ALIGN_MASK; set_head_size(old_top, old_top_size); chunk_at_offset(old_top, old_top_size )->size = SIZE_SZ|PREV_INUSE; chunk_at_offset(old_top, old_top_size + SIZE_SZ)->size = SIZE_SZ|PREV_INUSE; /* If possible, release the rest. */ if (old_top_size >= MINSIZE) fREe(chunk2mem(old_top)); } } if ((unsigned long)sbrked_mem > (unsigned long)max_sbrked_mem) max_sbrked_mem = sbrked_mem; if ((unsigned long)(mmapped_mem + sbrked_mem) > (unsigned long)max_total_mem) max_total_mem = mmapped_mem + sbrked_mem; /* We always land on a page boundary */ assert(((unsigned long)((char*)top + top_size) & (pagesz - 1)) == 0); } /* Main public routines */ /* Malloc Algorthim: The requested size is first converted into a usable form, `nb'. This currently means to add 4 bytes overhead plus possibly more to obtain 8-byte alignment and/or to obtain a size of at least MINSIZE (currently 16 bytes), the smallest allocatable size. (All fits are considered `exact' if they are within MINSIZE bytes.) From there, the first successful of the following steps is taken: 1. The bin corresponding to the request size is scanned, and if a chunk of exactly the right size is found, it is taken. 2. The most recently remaindered chunk is used if it is big enough. This is a form of (roving) first fit, used only in the absence of exact fits. Runs of consecutive requests use the remainder of the chunk used for the previous such request whenever possible. This limited use of a first-fit style allocation strategy tends to give contiguous chunks coextensive lifetimes, which improves locality and can reduce fragmentation in the long run. 3. Other bins are scanned in increasing size order, using a chunk big enough to fulfill the request, and splitting off any remainder. This search is strictly by best-fit; i.e., the smallest (with ties going to approximately the least recently used) chunk that fits is selected. 4. If large enough, the chunk bordering the end of memory (`top') is split off. (This use of `top' is in accord with the best-fit search rule. In effect, `top' is treated as larger (and thus less well fitting) than any other available chunk since it can be extended to be as large as necessary (up to system limitations). 5. If the request size meets the mmap threshold and the system supports mmap, and there are few enough currently allocated mmapped regions, and a call to mmap succeeds, the request is allocated via direct memory mapping. 6. Otherwise, the top of memory is extended by obtaining more space from the system (normally using sbrk, but definable to anything else via the MORECORE macro). Memory is gathered from the system (in system page-sized units) in a way that allows chunks obtained across different sbrk calls to be consolidated, but does not require contiguous memory. Thus, it should be safe to intersperse mallocs with other sbrk calls. All allocations are made from the the `lowest' part of any found chunk. (The implementation invariant is that prev_inuse is always true of any allocated chunk; i.e., that each allocated chunk borders either a previously allocated and still in-use chunk, or the base of its memory arena.) */ #if __STD_C Void_t* mALLOc(size_t bytes) #else Void_t* mALLOc(bytes) size_t bytes; #endif { mchunkptr victim; /* inspected/selected chunk */ INTERNAL_SIZE_T victim_size; /* its size */ int idx; /* index for bin traversal */ mbinptr bin; /* associated bin */ mchunkptr remainder; /* remainder from a split */ long remainder_size; /* its size */ int remainder_index; /* its bin index */ unsigned long block; /* block traverser bit */ int startidx; /* first bin of a traversed block */ mchunkptr fwd; /* misc temp for linking */ mchunkptr bck; /* misc temp for linking */ mbinptr q; /* misc temp */ INTERNAL_SIZE_T nb = request2size(bytes); /* padded request size; */ /* Check for exact match in a bin */ if (is_small_request(nb)) /* Faster version for small requests */ { idx = smallbin_index(nb); /* No traversal or size check necessary for small bins. */ q = bin_at(idx); victim = last(q); /* Also scan the next one, since it would have a remainder < MINSIZE */ if (victim == q) { q = next_bin(q); victim = last(q); } if (victim != q) { victim_size = chunksize(victim); unlink(victim, bck, fwd); set_inuse_bit_at_offset(victim, victim_size); check_malloced_chunk(victim, nb); return chunk2mem(victim); } idx += 2; /* Set for bin scan below. We've already scanned 2 bins. */ } else { idx = bin_index(nb); bin = bin_at(idx); for (victim = last(bin); victim != bin; victim = victim->bk) { victim_size = chunksize(victim); remainder_size = victim_size - nb; if (remainder_size >= (long)MINSIZE) /* too big */ { --idx; /* adjust to rescan below after checking last remainder */ break; } else if (remainder_size >= 0) /* exact fit */ { unlink(victim, bck, fwd); set_inuse_bit_at_offset(victim, victim_size); check_malloced_chunk(victim, nb); return chunk2mem(victim); } } ++idx; } /* Try to use the last split-off remainder */ if ( (victim = last_remainder->fd) != last_remainder) { victim_size = chunksize(victim); remainder_size = victim_size - nb; if (remainder_size >= (long)MINSIZE) /* re-split */ { remainder = chunk_at_offset(victim, nb); set_head(victim, nb | PREV_INUSE); link_last_remainder(remainder); set_head(remainder, remainder_size | PREV_INUSE); set_foot(remainder, remainder_size); check_malloced_chunk(victim, nb); return chunk2mem(victim); } clear_last_remainder; if (remainder_size >= 0) /* exhaust */ { set_inuse_bit_at_offset(victim, victim_size); check_malloced_chunk(victim, nb); return chunk2mem(victim); } /* Else place in bin */ frontlink(victim, victim_size, remainder_index, bck, fwd); } /* If there are any possibly nonempty big-enough blocks, search for best fitting chunk by scanning bins in blockwidth units. */ if ( (block = idx2binblock(idx)) <= binblocks) { /* Get to the first marked block */ if ( (block & binblocks) == 0) { /* force to an even block boundary */ idx = (idx & ~(BINBLOCKWIDTH - 1)) + BINBLOCKWIDTH; block <<= 1; while ((block & binblocks) == 0) { idx += BINBLOCKWIDTH; block <<= 1; } } /* For each possibly nonempty block ... */ for (;;) { startidx = idx; /* (track incomplete blocks) */ q = bin = bin_at(idx); /* For each bin in this block ... */ do { /* Find and use first big enough chunk ... */ for (victim = last(bin); victim != bin; victim = victim->bk) { victim_size = chunksize(victim); remainder_size = victim_size - nb; if (remainder_size >= (long)MINSIZE) /* split */ { remainder = chunk_at_offset(victim, nb); set_head(victim, nb | PREV_INUSE); unlink(victim, bck, fwd); link_last_remainder(remainder); set_head(remainder, remainder_size | PREV_INUSE); set_foot(remainder, remainder_size); check_malloced_chunk(victim, nb); return chunk2mem(victim); } else if (remainder_size >= 0) /* take */ { set_inuse_bit_at_offset(victim, victim_size); unlink(victim, bck, fwd); check_malloced_chunk(victim, nb); return chunk2mem(victim); } } bin = next_bin(bin); } while ((++idx & (BINBLOCKWIDTH - 1)) != 0); /* Clear out the block bit. */ do /* Possibly backtrack to try to clear a partial block */ { if ((startidx & (BINBLOCKWIDTH - 1)) == 0) { binblocks &= ~block; break; } --startidx; q = prev_bin(q); } while (first(q) == q); /* Get to the next possibly nonempty block */ if ( (block <<= 1) <= binblocks && (block != 0) ) { while ((block & binblocks) == 0) { idx += BINBLOCKWIDTH; block <<= 1; } } else break; } } /* Try to use top chunk */ /* Require that there be a remainder, ensuring top always exists */ if ( (remainder_size = chunksize(top) - nb) < (long)MINSIZE) { #if HAVE_MMAP /* If big and would otherwise need to extend, try to use mmap instead */ if ((unsigned long)nb >= (unsigned long)mmap_threshold && (victim = mmap_chunk(nb)) != 0) return chunk2mem(victim); #endif /* Try to extend */ malloc_extend_top(nb); if ( (remainder_size = chunksize(top) - nb) < (long)MINSIZE) return 0; /* propagate failure */ } victim = top; set_head(victim, nb | PREV_INUSE); top = chunk_at_offset(victim, nb); set_head(top, remainder_size | PREV_INUSE); check_malloced_chunk(victim, nb); return chunk2mem(victim); } /* free() algorithm : cases: 1. free(0) has no effect. 2. If the chunk was allocated via mmap, it is release via munmap(). 3. If a returned chunk borders the current high end of memory, it is consolidated into the top, and if the total unused topmost memory exceeds the trim threshold, malloc_trim is called. 4. Other chunks are consolidated as they arrive, and placed in corresponding bins. (This includes the case of consolidating with the current `last_remainder'). */ #if __STD_C void fREe(Void_t* mem) #else void fREe(mem) Void_t* mem; #endif { mchunkptr p; /* chunk corresponding to mem */ INTERNAL_SIZE_T hd; /* its head field */ INTERNAL_SIZE_T sz; /* its size */ int idx; /* its bin index */ mchunkptr next; /* next contiguous chunk */ INTERNAL_SIZE_T nextsz; /* its size */ INTERNAL_SIZE_T prevsz; /* size of previous contiguous chunk */ mchunkptr bck; /* misc temp for linking */ mchunkptr fwd; /* misc temp for linking */ int islr; /* track whether merging with last_remainder */ if (mem == 0) /* free(0) has no effect */ return; p = mem2chunk(mem); hd = p->size; #if HAVE_MMAP if (hd & IS_MMAPPED) /* release mmapped memory. */ { munmap_chunk(p); return; } #endif check_inuse_chunk(p); sz = hd & ~PREV_INUSE; next = chunk_at_offset(p, sz); nextsz = chunksize(next); if (next == top) /* merge with top */ { sz += nextsz; if (!(hd & PREV_INUSE)) /* consolidate backward */ { prevsz = p->prev_size; p = chunk_at_offset(p, -prevsz); sz += prevsz; unlink(p, bck, fwd); } set_head(p, sz | PREV_INUSE); top = p; if ((unsigned long)(sz) >= (unsigned long)trim_threshold) malloc_trim(top_pad); return; } set_head(next, nextsz); /* clear inuse bit */ islr = 0; if (!(hd & PREV_INUSE)) /* consolidate backward */ { prevsz = p->prev_size; p = chunk_at_offset(p, -prevsz); sz += prevsz; if (p->fd == last_remainder) /* keep as last_remainder */ islr = 1; else unlink(p, bck, fwd); } if (!(inuse_bit_at_offset(next, nextsz))) /* consolidate forward */ { sz += nextsz; if (!islr && next->fd == last_remainder) /* re-insert last_remainder */ { islr = 1; link_last_remainder(p); } else unlink(next, bck, fwd); } set_head(p, sz | PREV_INUSE); set_foot(p, sz); if (!islr) frontlink(p, sz, idx, bck, fwd); } /* Realloc algorithm: Chunks that were obtained via mmap cannot be extended or shrunk unless HAVE_MREMAP is defined, in which case mremap is used. Otherwise, if their reallocation is for additional space, they are copied. If for less, they are just left alone. Otherwise, if the reallocation is for additional space, and the chunk can be extended, it is, else a malloc-copy-free sequence is taken. There are several different ways that a chunk could be extended. All are tried: * Extending forward into following adjacent free chunk. * Shifting backwards, joining preceding adjacent space * Both shifting backwards and extending forward. * Extending into newly sbrked space Unless the #define REALLOC_ZERO_BYTES_FREES is set, realloc with a size argument of zero (re)allocates a minimum-sized chunk. If the reallocation is for less space, and the new request is for a `small' (<512 bytes) size, then the newly unused space is lopped off and freed. The old unix realloc convention of allowing the last-free'd chunk to be used as an argument to realloc is no longer supported. I don't know of any programs still relying on this feature, and allowing it would also allow too many other incorrect usages of realloc to be sensible. */ #if __STD_C Void_t* rEALLOc(Void_t* oldmem, size_t bytes) #else Void_t* rEALLOc(oldmem, bytes) Void_t* oldmem; size_t bytes; #endif { INTERNAL_SIZE_T nb; /* padded request size */ mchunkptr oldp; /* chunk corresponding to oldmem */ INTERNAL_SIZE_T oldsize; /* its size */ mchunkptr newp; /* chunk to return */ INTERNAL_SIZE_T newsize; /* its size */ Void_t* newmem; /* corresponding user mem */ mchunkptr next; /* next contiguous chunk after oldp */ INTERNAL_SIZE_T nextsize; /* its size */ mchunkptr prev; /* previous contiguous chunk before oldp */ INTERNAL_SIZE_T prevsize; /* its size */ mchunkptr remainder; /* holds split off extra space from newp */ INTERNAL_SIZE_T remainder_size; /* its size */ mchunkptr bck; /* misc temp for linking */ mchunkptr fwd; /* misc temp for linking */ #ifdef REALLOC_ZERO_BYTES_FREES if (bytes == 0) { fREe(oldmem); return 0; } #endif /* realloc of null is supposed to be same as malloc */ if (oldmem == 0) return mALLOc(bytes); newp = oldp = mem2chunk(oldmem); newsize = oldsize = chunksize(oldp); nb = request2size(bytes); #if HAVE_MMAP if (chunk_is_mmapped(oldp)) { #if HAVE_MREMAP newp = mremap_chunk(oldp, nb); if(newp) return chunk2mem(newp); #endif /* Note the extra SIZE_SZ overhead. */ if(oldsize - SIZE_SZ >= nb) return oldmem; /* do nothing */ /* Must alloc, copy, free. */ newmem = mALLOc(bytes); if (newmem == 0) return 0; /* propagate failure */ MALLOC_COPY(newmem, oldmem, oldsize - 2*SIZE_SZ); munmap_chunk(oldp); return newmem; } #endif check_inuse_chunk(oldp); if ((long)(oldsize) < (long)(nb)) { /* Try expanding forward */ next = chunk_at_offset(oldp, oldsize); if (next == top || !inuse(next)) { nextsize = chunksize(next); /* Forward into top only if a remainder */ if (next == top) { if ((long)(nextsize + newsize) >= (long)(nb + MINSIZE)) { newsize += nextsize; top = chunk_at_offset(oldp, nb); set_head(top, (newsize - nb) | PREV_INUSE); set_head_size(oldp, nb); return chunk2mem(oldp); } } /* Forward into next chunk */ else if (((long)(nextsize + newsize) >= (long)(nb))) { unlink(next, bck, fwd); newsize += nextsize; goto split; } } else { next = 0; nextsize = 0; } /* Try shifting backwards. */ if (!prev_inuse(oldp)) { prev = prev_chunk(oldp); prevsize = chunksize(prev); /* try forward + backward first to save a later consolidation */ if (next != 0) { /* into top */ if (next == top) { if ((long)(nextsize + prevsize + newsize) >= (long)(nb + MINSIZE)) { unlink(prev, bck, fwd); newp = prev; newsize += prevsize + nextsize; newmem = chunk2mem(newp); MALLOC_COPY(newmem, oldmem, oldsize - SIZE_SZ); top = chunk_at_offset(newp, nb); set_head(top, (newsize - nb) | PREV_INUSE); set_head_size(newp, nb); return newmem; } } /* into next chunk */ else if (((long)(nextsize + prevsize + newsize) >= (long)(nb))) { unlink(next, bck, fwd); unlink(prev, bck, fwd); newp = prev; newsize += nextsize + prevsize; newmem = chunk2mem(newp); MALLOC_COPY(newmem, oldmem, oldsize - SIZE_SZ); goto split; } } /* backward only */ if (prev != 0 && (long)(prevsize + newsize) >= (long)nb) { unlink(prev, bck, fwd); newp = prev; newsize += prevsize; newmem = chunk2mem(newp); MALLOC_COPY(newmem, oldmem, oldsize - SIZE_SZ); goto split; } } /* Must allocate */ newmem = mALLOc (bytes); if (newmem == 0) /* propagate failure */ return 0; /* Avoid copy if newp is next chunk after oldp. */ /* (This can only happen when new chunk is sbrk'ed.) */ if ( (newp = mem2chunk(newmem)) == next_chunk(oldp)) { newsize += chunksize(newp); newp = oldp; goto split; } /* Otherwise copy, free, and exit */ MALLOC_COPY(newmem, oldmem, oldsize - SIZE_SZ); fREe(oldmem); return newmem; } split: /* split off extra room in old or expanded chunk */ if (newsize - nb >= MINSIZE) /* split off remainder */ { remainder = chunk_at_offset(newp, nb); remainder_size = newsize - nb; set_head_size(newp, nb); set_head(remainder, remainder_size | PREV_INUSE); set_inuse_bit_at_offset(remainder, remainder_size); fREe(chunk2mem(remainder)); /* let free() deal with it */ } else { set_head_size(newp, newsize); set_inuse_bit_at_offset(newp, newsize); } check_inuse_chunk(newp); return chunk2mem(newp); } /* memalign algorithm: memalign requests more than enough space from malloc, finds a spot within that chunk that meets the alignment request, and then possibly frees the leading and trailing space. The alignment argument must be a power of two. This property is not checked by memalign, so misuse may result in random runtime errors. 8-byte alignment is guaranteed by normal malloc calls, so don't bother calling memalign with an argument of 8 or less. Overreliance on memalign is a sure way to fragment space. */ #if __STD_C Void_t* mEMALIGn(size_t alignment, size_t bytes) #else Void_t* mEMALIGn(alignment, bytes) size_t alignment; size_t bytes; #endif { INTERNAL_SIZE_T nb; /* padded request size */ char* m; /* memory returned by malloc call */ mchunkptr p; /* corresponding chunk */ char* brk; /* alignment point within p */ mchunkptr newp; /* chunk to return */ INTERNAL_SIZE_T newsize; /* its size */ INTERNAL_SIZE_T leadsize; /* leading space befor alignment point */ mchunkptr remainder; /* spare room at end to split off */ long remainder_size; /* its size */ /* If need less alignment than we give anyway, just relay to malloc */ if (alignment <= MALLOC_ALIGNMENT) return mALLOc(bytes); /* Otherwise, ensure that it is at least a minimum chunk size */ if (alignment < MINSIZE) alignment = MINSIZE; /* Call malloc with worst case padding to hit alignment. */ nb = request2size(bytes); m = (char*)(mALLOc(nb + alignment + MINSIZE)); if (m == 0) return 0; /* propagate failure */ p = mem2chunk(m); if ((((unsigned long)(m)) % alignment) == 0) /* aligned */ { #if HAVE_MMAP if(chunk_is_mmapped(p)) return chunk2mem(p); /* nothing more to do */ #endif } else /* misaligned */ { /* Find an aligned spot inside chunk. Since we need to give back leading space in a chunk of at least MINSIZE, if the first calculation places us at a spot with less than MINSIZE leader, we can move to the next aligned spot -- we've allocated enough total room so that this is always possible. */ brk = (char*)mem2chunk(((unsigned long)(m + alignment - 1)) & -alignment); if ((long)(brk - (char*)(p)) < MINSIZE) brk = brk + alignment; newp = (mchunkptr)brk; leadsize = brk - (char*)(p); newsize = chunksize(p) - leadsize; #if HAVE_MMAP if(chunk_is_mmapped(p)) { newp->prev_size = p->prev_size + leadsize; set_head(newp, newsize|IS_MMAPPED); return chunk2mem(newp); } #endif /* give back leader, use the rest */ set_head(newp, newsize | PREV_INUSE); set_inuse_bit_at_offset(newp, newsize); set_head_size(p, leadsize); fREe(chunk2mem(p)); p = newp; assert (newsize >= nb && (((unsigned long)(chunk2mem(p))) % alignment) == 0); } /* Also give back spare room at the end */ remainder_size = chunksize(p) - nb; if (remainder_size >= (long)MINSIZE) { remainder = chunk_at_offset(p, nb); set_head(remainder, remainder_size | PREV_INUSE); set_head_size(p, nb); fREe(chunk2mem(remainder)); } check_inuse_chunk(p); return chunk2mem(p); } /* valloc just invokes memalign with alignment argument equal to the page size of the system (or as near to this as can be figured out from all the includes/defines above.) */ #if __STD_C Void_t* vALLOc(size_t bytes) #else Void_t* vALLOc(bytes) size_t bytes; #endif { return mEMALIGn (malloc_getpagesize, bytes); } /* pvalloc just invokes valloc for the nearest pagesize that will accommodate request */ #if __STD_C Void_t* pvALLOc(size_t bytes) #else Void_t* pvALLOc(bytes) size_t bytes; #endif { size_t pagesize = malloc_getpagesize; return mEMALIGn (pagesize, (bytes + pagesize - 1) & ~(pagesize - 1)); } /* calloc calls malloc, then zeroes out the allocated chunk. */ #if __STD_C Void_t* cALLOc(size_t n, size_t elem_size) #else Void_t* cALLOc(n, elem_size) size_t n; size_t elem_size; #endif { mchunkptr p; INTERNAL_SIZE_T csz; INTERNAL_SIZE_T sz = n * elem_size; /* check if expand_top called, in which case don't need to clear */ #if MORECORE_CLEARS mchunkptr oldtop = top; INTERNAL_SIZE_T oldtopsize = chunksize(top); #endif Void_t* mem = mALLOc (sz); if (mem == 0) return 0; else { p = mem2chunk(mem); /* Two optional cases in which clearing not necessary */ #if HAVE_MMAP if (chunk_is_mmapped(p)) return mem; #endif csz = chunksize(p); #if MORECORE_CLEARS if (p == oldtop && csz > oldtopsize) { /* clear only the bytes from non-freshly-sbrked memory */ csz = oldtopsize; } #endif MALLOC_ZERO(mem, csz - SIZE_SZ); return mem; } } /* cfree just calls free. It is needed/defined on some systems that pair it with calloc, presumably for odd historical reasons. */ #if !defined(INTERNAL_LINUX_C_LIB) || !defined(__ELF__) #if __STD_C void cfree(Void_t *mem) #else void cfree(mem) Void_t *mem; #endif { free(mem); } #endif /* Malloc_trim gives memory back to the system (via negative arguments to sbrk) if there is unused memory at the `high' end of the malloc pool. You can call this after freeing large blocks of memory to potentially reduce the system-level memory requirements of a program. However, it cannot guarantee to reduce memory. Under some allocation patterns, some large free blocks of memory will be locked between two used chunks, so they cannot be given back to the system. The `pad' argument to malloc_trim represents the amount of free trailing space to leave untrimmed. If this argument is zero, only the minimum amount of memory to maintain internal data structures will be left (one page or less). Non-zero arguments can be supplied to maintain enough trailing space to service future expected allocations without having to re-obtain memory from the system. Malloc_trim returns 1 if it actually released any memory, else 0. */ #if __STD_C int malloc_trim(size_t pad) #else int malloc_trim(pad) size_t pad; #endif { long top_size; /* Amount of top-most memory */ long extra; /* Amount to release */ char* current_brk; /* address returned by pre-check sbrk call */ char* new_brk; /* address returned by negative sbrk call */ unsigned long pagesz = malloc_getpagesize; top_size = chunksize(top); extra = ((top_size - pad - MINSIZE + (pagesz-1)) / pagesz - 1) * pagesz; if (extra < (long)pagesz) /* Not enough memory to release */ return 0; else { /* Test to make sure no one else called sbrk */ current_brk = (char*)(MORECORE (0)); if (current_brk != (char*)(top) + top_size) return 0; /* Apparently we don't own memory; must fail */ else { new_brk = (char*)(MORECORE (-extra)); if (new_brk == (char*)(MORECORE_FAILURE)) /* sbrk failed? */ { /* Try to figure out what we have */ current_brk = (char*)(MORECORE (0)); top_size = current_brk - (char*)top; if (top_size >= (long)MINSIZE) /* if not, we are very very dead! */ { sbrked_mem = current_brk - sbrk_base; set_head(top, top_size | PREV_INUSE); } check_chunk(top); return 0; } else { /* Success. Adjust top accordingly. */ set_head(top, (top_size - extra) | PREV_INUSE); sbrked_mem -= extra; check_chunk(top); return 1; } } } } /* malloc_usable_size: This routine tells you how many bytes you can actually use in an allocated chunk, which may be more than you requested (although often not). You can use this many bytes without worrying about overwriting other allocated objects. Not a particularly great programming practice, but still sometimes useful. */ #if __STD_C size_t malloc_usable_size(Void_t* mem) #else size_t malloc_usable_size(mem) Void_t* mem; #endif { mchunkptr p; if (mem == 0) return 0; else { p = mem2chunk(mem); if(!chunk_is_mmapped(p)) { if (!inuse(p)) return 0; check_inuse_chunk(p); return chunksize(p) - SIZE_SZ; } return chunksize(p) - 2*SIZE_SZ; } } /* Utility to update current_mallinfo for malloc_stats and mallinfo() */ static void malloc_update_mallinfo() { int i; mbinptr b; mchunkptr p; #if DEBUG mchunkptr q; #endif INTERNAL_SIZE_T avail = chunksize(top); int navail = ((long)(avail) >= (long)MINSIZE)? 1 : 0; for (i = 1; i < NAV; ++i) { b = bin_at(i); for (p = last(b); p != b; p = p->bk) { #if DEBUG check_free_chunk(p); for (q = next_chunk(p); q < top && inuse(q) && (long)(chunksize(q)) >= (long)MINSIZE; q = next_chunk(q)) check_inuse_chunk(q); #endif avail += chunksize(p); navail++; } } current_mallinfo.ordblks = navail; current_mallinfo.uordblks = sbrked_mem - avail; current_mallinfo.fordblks = avail; current_mallinfo.hblks = n_mmaps; current_mallinfo.hblkhd = mmapped_mem; current_mallinfo.keepcost = chunksize(top); } /* malloc_stats: Prints on stderr the amount of space obtain from the system (both via sbrk and mmap), the maximum amount (which may be more than current if malloc_trim and/or munmap got called), the maximum number of simultaneous mmap regions used, and the current number of bytes allocated via malloc (or realloc, etc) but not yet freed. (Note that this is the number of bytes allocated, not the number requested. It will be larger than the number requested because of alignment and bookkeeping overhead.) */ void malloc_stats() { malloc_update_mallinfo(); fprintf(stderr, "max system bytes = %10u\n", (unsigned int)(max_total_mem)); fprintf(stderr, "system bytes = %10u\n", (unsigned int)(sbrked_mem + mmapped_mem)); fprintf(stderr, "in use bytes = %10u\n", (unsigned int)(current_mallinfo.uordblks + mmapped_mem)); #if HAVE_MMAP fprintf(stderr, "max mmap regions = %10u\n", (unsigned int)max_n_mmaps); #endif } /* mallinfo returns a copy of updated current mallinfo. */ struct mallinfo mALLINFo() { malloc_update_mallinfo(); return current_mallinfo; } /* mallopt: mallopt is the general SVID/XPG interface to tunable parameters. The format is to provide a (parameter-number, parameter-value) pair. mallopt then sets the corresponding parameter to the argument value if it can (i.e., so long as the value is meaningful), and returns 1 if successful else 0. See descriptions of tunable parameters above. */ #if __STD_C int mALLOPt(int param_number, int value) #else int mALLOPt(param_number, value) int param_number; int value; #endif { switch(param_number) { case M_TRIM_THRESHOLD: trim_threshold = value; return 1; case M_TOP_PAD: top_pad = value; return 1; case M_MMAP_THRESHOLD: mmap_threshold = value; return 1; case M_MMAP_MAX: #if HAVE_MMAP n_mmaps_max = value; return 1; #else if (value != 0) return 0; else n_mmaps_max = value; return 1; #endif default: return 0; } } /* History: V2.6.5 Wed Jun 17 15:57:31 1998 Doug Lea (dl at gee) * Fixed ordering problem with boundary-stamping V2.6.3 Sun May 19 08:17:58 1996 Doug Lea (dl at gee) * Added pvalloc, as recommended by H.J. Liu * Added 64bit pointer support mainly from Wolfram Gloger * Added anonymously donated WIN32 sbrk emulation * Malloc, calloc, getpagesize: add optimizations from Raymond Nijssen * malloc_extend_top: fix mask error that caused wastage after foreign sbrks * Add linux mremap support code from HJ Liu V2.6.2 Tue Dec 5 06:52:55 1995 Doug Lea (dl at gee) * Integrated most documentation with the code. * Add support for mmap, with help from Wolfram Gloger (Gloger@lrz.uni-muenchen.de). * Use last_remainder in more cases. * Pack bins using idea from colin@nyx10.cs.du.edu * Use ordered bins instead of best-fit threshhold * Eliminate block-local decls to simplify tracing and debugging. * Support another case of realloc via move into top * Fix error occuring when initial sbrk_base not word-aligned. * Rely on page size for units instead of SBRK_UNIT to avoid surprises about sbrk alignment conventions. * Add mallinfo, mallopt. Thanks to Raymond Nijssen (raymond@es.ele.tue.nl) for the suggestion. * Add `pad' argument to malloc_trim and top_pad mallopt parameter. * More precautions for cases where other routines call sbrk, courtesy of Wolfram Gloger (Gloger@lrz.uni-muenchen.de). * Added macros etc., allowing use in linux libc from H.J. Lu (hjl@gnu.ai.mit.edu) * Inverted this history list V2.6.1 Sat Dec 2 14:10:57 1995 Doug Lea (dl at gee) * Re-tuned and fixed to behave more nicely with V2.6.0 changes. * Removed all preallocation code since under current scheme the work required to undo bad preallocations exceeds the work saved in good cases for most test programs. * No longer use return list or unconsolidated bins since no scheme using them consistently outperforms those that don't given above changes. * Use best fit for very large chunks to prevent some worst-cases. * Added some support for debugging V2.6.0 Sat Nov 4 07:05:23 1995 Doug Lea (dl at gee) * Removed footers when chunks are in use. Thanks to Paul Wilson (wilson@cs.texas.edu) for the suggestion. V2.5.4 Wed Nov 1 07:54:51 1995 Doug Lea (dl at gee) * Added malloc_trim, with help from Wolfram Gloger (wmglo@Dent.MED.Uni-Muenchen.DE). V2.5.3 Tue Apr 26 10:16:01 1994 Doug Lea (dl at g) V2.5.2 Tue Apr 5 16:20:40 1994 Doug Lea (dl at g) * realloc: try to expand in both directions * malloc: swap order of clean-bin strategy; * realloc: only conditionally expand backwards * Try not to scavenge used bins * Use bin counts as a guide to preallocation * Occasionally bin return list chunks in first scan * Add a few optimizations from colin@nyx10.cs.du.edu V2.5.1 Sat Aug 14 15:40:43 1993 Doug Lea (dl at g) * faster bin computation & slightly different binning * merged all consolidations to one part of malloc proper (eliminating old malloc_find_space & malloc_clean_bin) * Scan 2 returns chunks (not just 1) * Propagate failure in realloc if malloc returns 0 * Add stuff to allow compilation on non-ANSI compilers from kpv@research.att.com V2.5 Sat Aug 7 07:41:59 1993 Doug Lea (dl at g.oswego.edu) * removed potential for odd address access in prev_chunk * removed dependency on getpagesize.h * misc cosmetics and a bit more internal documentation * anticosmetics: mangled names in macros to evade debugger strangeness * tested on sparc, hp-700, dec-mips, rs6000 with gcc & native cc (hp, dec only) allowing Detlefs & Zorn comparison study (in SIGPLAN Notices.) Trial version Fri Aug 28 13:14:29 1992 Doug Lea (dl at g.oswego.edu) * Based loosely on libg++-1.2X malloc. (It retains some of the overall structure of old version, but most details differ.) */ librep-0.90.2/src/debug-buffer.c0000644000175200017520000001137311245011153015353 0ustar chrischris/* debug-buffer.c -- Trace recording Copyright (C) 1997 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #include #include #include #ifdef NEED_MEMORY_H # include #endif struct debug_buf { struct debug_buf *next; char *name; int size, ptr; rep_bool wrapped; char data[1]; }; #define DB_SIZE(n) (sizeof(struct debug_buf) + (n) - 1) static struct debug_buf *db_chain; void * rep_db_alloc(char *name, int size) { struct debug_buf *db = rep_alloc(DB_SIZE(size)); if(db == NULL) { perror("create_debug_buf"); abort(); } db->name = name; db->size = size; db->ptr = 0; db->wrapped = rep_FALSE; db->next = db_chain; db_chain = db; return db; } void rep_db_free(void *_db) { struct debug_buf *db = _db; struct debug_buf **x = &db_chain; while(*x != NULL) { if(*x == db) { *x = db->next; break; } x = &((*x)->next); } rep_free(db); } void rep_db_vprintf(void *_db, char *fmt, va_list args) { char buf[256]; int length; struct debug_buf *db = _db; #ifdef HAVE_SNPRINTF vsnprintf(buf, sizeof(buf), fmt, args); #else vsprintf(buf, fmt, args); #endif length = strlen(buf); if(length > db->size - db->ptr) { int before = db->size - db->ptr; int after = MIN(length - before, db->size - before); memcpy(db->data + db->ptr, buf, before); memcpy(db->data, buf + before, after); db->ptr = after; db->wrapped = rep_TRUE; } else { memcpy(db->data + db->ptr, buf, length); db->ptr += length; } } void rep_db_printf(void *_db, char *fmt, ...) { va_list args; va_start(args, fmt); rep_db_vprintf(_db, fmt, args); va_end(args); } void rep_db_print_backtrace(void *_db, char *fun) { #if defined(__GNUC__) && ! defined(BROKEN_ALPHA_GCC) #define BT_BASE 1 #define BT_DEPTH 8 void *stack[BT_BASE+BT_DEPTH]; int i; /* It seems that in Linux/egcs-1.1 __builtin_return_address() will segfault when reaching the top of the stack frame. The work-around is to see if we can get the frame address, if so it should be safe to go for the return address. */ # define STACK_PROBE(i) \ do { \ if(i == BT_BASE || stack[i-1] != 0) \ { \ void *frame = __builtin_frame_address(i); \ if(frame != 0) \ stack[i] = __builtin_return_address(i); \ else \ stack[i] = 0; \ } \ else \ stack[i] = 0; \ } while(0) /* Should be from BT_BASE to BT_BASE+BT_DEPTH-1 */ STACK_PROBE(1); STACK_PROBE(2); STACK_PROBE(3); STACK_PROBE(4); STACK_PROBE(5); STACK_PROBE(6); STACK_PROBE(7); STACK_PROBE(8); rep_db_printf(_db, "\nBacktrace in `%s':\n", fun); for(i = BT_BASE; i < BT_BASE+BT_DEPTH && stack[i] != 0; i++) { #ifdef DB_RESOLVE_SYMBOLS if(stack[i] == 0) rep_db_printf(_db, "\t(nil)\n"); else { char *name; void *addr; if(rep_find_c_symbol(stack[i], &name, &addr)) { rep_db_printf(_db, "\t<%s+%d>\n", name, ((char *)stack[i]) - ((char *)addr)); } else rep_db_printf(_db, "\t0x%08lx\n", stack[i]); } #else rep_db_printf(_db, "\t0x%08lx\n", stack[i]); #endif } #endif } void * rep_db_return_address(void) { #if defined(__GNUC__) && ! defined(BROKEN_ALPHA_GCC) return __builtin_return_address(1); #else return 0; #endif } void rep_db_spew(void *_db) { struct debug_buf *db = _db; if(db->wrapped || db->ptr > 0) { fprintf(stderr, "\nstruct debug_buf %s:\n", db->name); if(db->wrapped) { fwrite(db->data + db->ptr, 1, db->size - db->ptr, stderr); fwrite(db->data, 1, db->ptr, stderr); } else fwrite(db->data, 1, db->ptr, stderr); } } void rep_db_spew_all(void) { struct debug_buf *db = db_chain; while(db != NULL) { rep_db_spew(db); db = db->next; } } void rep_db_kill(void) { struct debug_buf *db = db_chain; rep_db_spew_all(); db_chain = NULL; while(db != NULL) { struct debug_buf *next = db->next; rep_free(db); db = next; } } librep-0.90.2/src/datums.c0000644000175200017520000001201311245011153014303 0ustar chrischris/* datums.c -- user-defined opaque types Copyright (C) 2000 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* Commentary: These were inspired by Rees' The Scheme of Things column: ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/opaque.ps.gz */ #define _GNU_SOURCE #define rep_DEFINE_QNIL 1 #include "repint.h" static int datum_type; /* List of (ID . PRINTER) */ static repv printer_alist; #define DATUMP(x) rep_CELL16_TYPEP(x, datum_type) #define DATUM(x) ((datum *) rep_PTR (x)) #define DATUM_ID(x) (rep_TUPLE(x)->a) #define DATUM_VALUE(x) (rep_TUPLE(x)->b) /* This is what Qnil points to */ rep_tuple rep_eol_datum; /* type hooks */ static int datum_cmp (repv d1, repv d2) { if (DATUMP (d1) && DATUMP (d2) && DATUM_ID (d1) == DATUM_ID (d2)) return rep_value_cmp (DATUM_VALUE (d1), DATUM_VALUE (d2)); else return 1; } static void datum_print (repv stream, repv arg) { if (arg == Qnil) { DEFSTRING (eol, "()"); rep_stream_puts (stream, rep_PTR (rep_VAL (&eol)), 2, rep_TRUE); } else { repv printer = Fassq (DATUM_ID (arg), printer_alist); if (printer && rep_CONSP (printer) && rep_CDR (printer) != Qnil) rep_call_lisp2 (rep_CDR (printer), arg, stream); else if (rep_SYMBOLP (DATUM_ID (arg))) { rep_stream_puts (stream, "#name), -1, rep_TRUE); rep_stream_putc (stream, '>'); } else rep_stream_puts (stream, "#", -1, rep_FALSE); } } /* lisp functions */ DEFUN ("make-datum", Fmake_datum, Smake_datum, (repv value, repv id), rep_Subr2) /* ::doc:rep.data.datums#make-datum:: make-datum VALUE ID Create and return a new data object of type ID (an arbitrary value), it will have object VALUE associated with it. ::end:: */ { return rep_make_tuple (datum_type, id, value); } DEFUN ("define-datum-printer", Fdefine_datum_printer, Sdefine_datum_printer, (repv id, repv printer), rep_Subr2) /* ::doc:rep.data.datums#define-datum-printer:: define-datum-printer ID PRINTER Register a custom printer for all datums with type ID. When these objects printed are, the function PRINTER will be called with two arguments, the datum and the stream to print to. ::end:: */ { repv cell = Fassq (id, printer_alist); if (cell && rep_CONSP (cell)) rep_CDR (cell) = printer; else printer_alist = Fcons (Fcons (id, printer), printer_alist); return printer; } DEFUN ("datum-ref", Fdatum_ref, Sdatum_ref, (repv obj, repv id), rep_Subr2) /* ::doc:rep.data.datums#datum-ref:: datum-ref DATUM ID If data object DATUM has type ID, return its associated value, else signal an error. ::end:: */ { rep_DECLARE (1, obj, DATUMP (obj) && DATUM_ID (obj) == id); return DATUM_VALUE (obj); } DEFUN ("datum-set", Fdatum_set, Sdatum_set, (repv obj, repv id, repv value), rep_Subr3) /* ::doc:rep.data.datums#datum-set:: datum-set DATUM ID VALUE If data object DATUM has type ID, modify its associated value to be VALUE, else signal an error. ::end:: */ { rep_DECLARE (1, obj, DATUMP (obj) && DATUM_ID (obj) == id); DATUM_VALUE (obj) = value; return value; } DEFUN ("has-type-p", Fhas_type_p, Shas_type_p, (repv arg, repv id), rep_Subr2) /* ::doc:rep.data.datums#has-type-p:: has-type-p ARG ID Return `t' if object ARG has data type ID (and thus was initially created using the `make-datum' function). ::end:: */ { return (DATUMP (arg) && DATUM_ID (arg) == id) ? Qt : Qnil; } /* dl hooks */ void rep_pre_datums_init (void) { datum_type = rep_register_new_type ("datum", datum_cmp, datum_print, datum_print, 0, rep_mark_tuple, 0, 0, 0, 0, 0, 0, 0); /* Including CELL_MARK_BIT means we don't have to worry about GC; the cell will never get remarked, and it's not on any allocation lists to get swept up from. */ rep_eol_datum.car = datum_type | rep_CELL_STATIC_BIT | rep_CELL_MARK_BIT; rep_eol_datum.a = rep_VAL (&rep_eol_datum); rep_eol_datum.b = rep_VAL (&rep_eol_datum); } void rep_datums_init (void) { repv tem = rep_push_structure ("rep.data.datums"); rep_ADD_SUBR (Smake_datum); rep_ADD_SUBR (Sdefine_datum_printer); rep_ADD_SUBR (Sdatum_ref); rep_ADD_SUBR (Sdatum_set); rep_ADD_SUBR (Shas_type_p); printer_alist = Qnil; rep_mark_static (&printer_alist); rep_pop_structure (tem); } librep-0.90.2/src/continuations.c0000644000175200017520000013732111245011153015715 0ustar chrischris/* continuations.c -- continuations, much stack hackery.. Copyright (C) 2000 John Harper $Id$ This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* notes: The basic idea is to copy the entire active stack into the continuation, together with a jmpbuf and the pointers into the stack stored lisp histories (lisp call stack, gc roots, blocked file operations, saved regexp data, etc..) When the continuation is activated, the stack is built up so that it's large enough to contain the saved stack in the continuation. The saved version is then copied over the current stack, and the jmpbuf is called Marking a continuation involves marking all the lisp histories, but remembering to relocate into the copied stack data Some of the ideas here were inspired by the SCM/Guile implementation of continuations. We also use continuation `barriers'. A barrier marks a (possibly saved) stack position, and can be either `open' or `closed'. There is a tree of barriers, branches of which may be stored in continuations, or on the current stack. When invoking a continuation it is forbidden to cross any closed barriers. Each barrier has two functions `in' and `out' associated with it, one of these may be invoked when a continuation is invoked and the barrier is crossed. These functions are normally used for setting and unsetting global state. Note that continuations only save and restore variable bindings (both lexical and dynamic). It doesn't make sense to save other dynamic state (i.e. catch/throw, unwind-protect, etc..), though it could be done using open barriers.. Hopefully this will be reasonably portable, I _think_ it only depends on having a linear stack that completely encapsulates the current process state, and a setjmp/longjmp implementation.. Continuations are also used to provide a basic threading implementation. Threads are local to each enclosing closed barrier (dynamic root). Each barrier has two thread queues, runnable and suspended. Each thread is just a (primitive) continuation, the lexical environment, and a forbid-preemption count. The dynamic root acts as a serialization point, it will only be crossed when the last thread has exited or been deleted. To avoid having to consider preemption throughout the interpreter, there are only (currently) two preemption points, in funcall and the bytecode interpreter. The rep_test_int_counter is used to decide when to try to preempt the current thread. In non-threaded mode (i.e. thread_invoke () hasn't been called in the current root), these are all no-ops. The rep_TEST_INT_SLOW macro is also allowed to preempt. Finally, here's an example of using threads: (defvar *counter* nil) (defun thread-fun (id) (let ((*counter* (* id 1000))) (while t (format standard-output "thread-%s: %8d\n" id *counter*) (setq *counter* (1+ *counter*))))) (setq thread-1 (make-thread (lambda () (thread-fun 1)) "thread-1")) (setq thread-2 (make-thread (lambda () (thread-fun 2)) "thread-2")) [ the dynamic root is a serialization point, it won't be exited until _all_ threads it contains have exited / been deleted, or it's been thrown threw (which deletes all running threads) ] The lisp debugger runs in it's own dynamic root, so debugging threads works for free! */ #define _GNU_SOURCE #undef DEBUG /* AIX requires this to be the first thing in the file. */ #include #ifdef __GNUC__ # define alloca __builtin_alloca #else # if HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ char *alloca (); # endif # endif # endif #endif #include "repint.h" #include #include #include #include #include #ifdef NEED_MEMORY_H # include #endif #ifdef HAVE_SYS_TIME_H # include #endif #if defined (DEBUG) # define DB(x) printf x #else # define DB(x) #endif /* Threads only preempted when this is zero. */ int rep_thread_lock = 0; /* True when the current thread should be preempted soon */ rep_bool rep_pending_thread_yield; #ifdef WITH_CONTINUATIONS #if STACK_DIRECTION == 0 # error "stack growth direction unknown" #elif STACK_DIRECTION > 0 # warning "upward growing stacks are untested" #endif #if STACK_DIRECTION < 0 /* was address B1 put on the stack _before_ address B2? */ # define SP_OLDER_P(b1, b2) ((b1) > (b2)) /* was address B1 put on the stack _after_ address B2? */ # define SP_NEWER_P(b1, b2) ((b1) < (b2)) #else # define SP_OLDER_P(b1, b2) ((b1) < (b2)) # define SP_NEWER_P(b1, b2) ((b1) > (b2)) #endif /* copied from guile 1.3.2 */ #if !defined (FLUSH_REGISTER_WINDOWS) # if defined (sparc) # define FLUSH_REGISTER_WINDOWS asm ("ta 3") # else # define FLUSH_REGISTER_WINDOWS # endif #endif typedef struct rep_barrier_struct rep_barrier; typedef struct rep_continuation_struct rep_continuation; typedef struct rep_thread_struct rep_thread; /* Continuations can only be invoked if there's no closed barriers between the current stack address and the address contained in the continuation. Open barriers are simply used for context switching globally-stored state Barriers also allow us to be selective about how much of the stack is saved for each continuation. Only the portion more recent than the most recent closed barrier is saved. */ struct rep_barrier_struct { rep_barrier *next; rep_barrier *root; /* upwards closed barrier */ char *point; void (*in)(void *data); void (*out)(void *data); void *data; rep_thread *active; rep_thread *head, *tail; rep_thread *susp_head, *susp_tail; short depth; unsigned int closed : 1; unsigned int targeted : 1; /* may contain continuations */ }; /* List of all currently active barriers (on the current stack) */ static rep_barrier *barriers; /* The outermost active closed barrier (the dynamic root in guile terms?) */ static rep_barrier *root_barrier; /* Put in rep_throw_value when the enclosing closed barrier needs to exit */ static repv exit_barrier_cell; /* The data saved for a continuation */ struct rep_continuation_struct { repv car; rep_continuation *next; jmp_buf jmpbuf; char *stack_copy, *stack_top, *stack_bottom; size_t stack_size, real_size; rep_barrier *barriers; rep_barrier *root; struct rep_Call *call_stack; repv special_bindings; rep_GC_root *gc_roots; rep_GC_n_roots *gc_n_roots; struct rep_saved_regexp_data *regexp_data; struct blocked_op *blocked_ops[op_MAX]; repv throw_value; rep_bool single_step; int lisp_depth; }; #define rep_CONTIN(v) ((rep_continuation *)rep_PTR(v)) #define rep_CONTINP(v) rep_CELL16_TYPEP(v, continuation_type ()) #define CF_INVALID (1 << rep_CELL16_TYPE_BITS) #define CONTIN_MAX_SLOP 4096 /* returns the cell16 typecode allocated for continuation objects */ static int continuation_type (void); /* list of all allocated continuations */ static rep_continuation *continuations; struct rep_thread_struct { repv car; rep_thread *next_alloc; rep_thread *next, *pred; repv name; rep_continuation *cont; repv env, structure; int lock; struct timeval run_at; rep_bool (*poll)(rep_thread *t, void *arg); void *poll_arg; repv exit_val; }; #define XTHREADP(v) rep_CELL16_TYPEP(v, thread_type ()) #define THREADP(v) (XTHREADP (v) && !(THREAD (v)->car & TF_EXITED)) #define THREAD(v) ((rep_thread *) rep_PTR (v)) #define TF_EXITED (1 << (rep_CELL16_TYPE_BITS + 0)) #define TF_SUSPENDED (1 << (rep_CELL16_TYPE_BITS + 1)) static int thread_type (void); static rep_thread *threads; #define TV_LATER_P(t1, t2) \ (((t1)->tv_sec > (t2)->tv_sec) \ || (((t1)->tv_sec == (t2)->tv_sec) \ && ((t1)->tv_usec > (t2)->tv_usec))) DEFSYM(continuation, "continuation"); /* used while longjmp'ing to save accessing a local variable */ static rep_continuation *invoked_continuation; static repv invoked_continuation_ret; static rep_barrier *invoked_continuation_ancestor; /* Approx. number of extra bytes of stack per recursion */ #define STACK_GROWTH 512 static inline char * fixup (char *addr, rep_continuation *c) { #if STACK_DIRECTION < 0 if (addr < c->stack_bottom) return (addr - c->stack_top) + c->stack_copy; else return addr; #else if (addr > c->stack_bottom) return (addr - c->stack_bottom) + c->stack_copy; else return addr; #endif } #define FIXUP(t,c,addr) ((t) (fixup ((char *) (addr), (c)))) static void thread_delete (rep_thread *t); /* barriers */ /* Create a barrier (closed if CLOSED is true, open otherwise), then call CALLBACK with ARG as its argument. The barrier will be in place for the duration of the call to CALLBACK. If either of IN or OUT aren't null pointers then they will be called when the barrier is crossed (while invoking a continuation). Closed barriers are never crossed. DATA is passed to both IN and OUT functions when they are called. The IN function is called when control passes from above barrier on the stack to below; OUT when control passes from below to above. */ repv rep_call_with_barrier (repv (*callback)(repv), repv arg, rep_bool closed, void (*in)(void *), void (*out)(void *), void *data) { repv ret; rep_barrier b; memset (&b, 0, sizeof (b)); b.point = (char *) &b; #if STACK_DIRECTION > 0 b.point += sizeof (rep_barrier); /* don't want to save barrier */ #endif b.root = root_barrier; b.in = in; b.out = out; b.data = data; b.closed = closed; b.depth = barriers ? barriers->depth + 1 : 1; b.next = barriers; barriers = &b; if (closed) root_barrier = &b; DB(("with-barrier[%s]: in %p (%d)\n", closed ? "closed" : "open", &b, b.depth)); ret = callback (arg); if (closed) { rep_thread *ptr; again: if (rep_throw_value == exit_barrier_cell) { DB (("caught barrier exit throw\n")); rep_throw_value = rep_CDR (exit_barrier_cell); ret = (rep_throw_value == rep_NULL) ? Qnil : rep_NULL; rep_CDR (exit_barrier_cell) = Qnil; } if (rep_throw_value == rep_NULL && b.active != 0) { /* An active thread exited. Calling thread_delete () on the active thread will call thread_invoke (). That will exit if there are no more runnable threads. */ DB (("deleting active thread %p\n", b.active)); thread_delete (b.active); goto again; } if (b.targeted) { /* Invalidate any continuations that require this barrier */ rep_continuation *c; for (c = continuations; c != 0; c = c->next) { if (c->root == &b) c->car |= CF_INVALID; } } for (ptr = b.head; ptr != 0; ptr = ptr->next) ptr->car |= TF_EXITED; for (ptr = b.susp_head; ptr != 0; ptr = ptr->next) ptr->car |= TF_EXITED; if (b.active != 0) b.active->car |= TF_EXITED; } DB(("with-barrier[%s]: out %p (%d)\n", closed ? "closed" : "open", &b, b.depth)); barriers = b.next; root_barrier = b.root; return ret; } static rep_barrier * get_dynamic_root (int depth) { rep_barrier *root = root_barrier; while (depth-- > 0 && root != 0) root = root->root; return root; } /* Record all barriers from continuation C's outermost barrier into the array HIST, stopping at the first closed barrier encountered. Returns the total number of barrier placed in HIST. */ static int trace_barriers (rep_continuation *c, rep_barrier **hist) { int i; rep_barrier *ptr = FIXUP (rep_barrier *, c, c->barriers); for (i = 0; ptr != 0; ptr = FIXUP (rep_barrier *, c, ptr->next)) { hist[i++] = ptr; if (ptr->closed) break; } return i; } /* Find the most recent common ancestor of barrier CURRENT, and the list of barriers in DEST-HIST (containing DEST-DEPTH pointers). Returns a null pointer if no such barrier can be found. */ static rep_barrier * common_ancestor (rep_barrier *current, rep_barrier **dest_hist, int dest_depth) { rep_barrier *ptr; int first_dest = 0; for (ptr = current; ptr != 0; ptr = ptr->next) { int i; for (i = first_dest; i < dest_depth; i++) { if (dest_hist[i]->point == ptr->point) return ptr; else if (SP_NEWER_P (dest_hist[i]->point, ptr->point)) first_dest = i + 1; } if (ptr->closed) break; } return 0; } /* continuations */ /* save the original stack for continuation C */ static void save_stack (rep_continuation *c) { size_t size; FLUSH_REGISTER_WINDOWS; /* __builtin_frame_address doesn't give the right thing on athlon64 */ #if defined (__GNUC__) && !defined (BROKEN_ALPHA_GCC) && !defined (__x86_64) c->stack_top = __builtin_frame_address (0); #else c->stack_top = (char *) &size; #endif #if STACK_DIRECTION < 0 size = c->stack_bottom - c->stack_top; #else size = c->stack_top - c->stack_bottom; #endif if (c->stack_copy != 0) { if (c->stack_size < size || (c->stack_size - size) > CONTIN_MAX_SLOP) { rep_free (c->stack_copy); rep_data_after_gc -= c->stack_size; c->stack_copy = 0; } } if (c->stack_copy == 0) { c->stack_size = size; c->stack_copy = rep_alloc (size); rep_data_after_gc += size; } c->real_size = size; #if STACK_DIRECTION < 0 memcpy (c->stack_copy, c->stack_top, c->real_size); #else memcpy (c->stack_copy, c->stack_bottom, c->real_size); #endif } /* Make sure that the current frame has enough space under it to hold the saved copy in C, then invoke the continuation */ static void grow_stack_and_invoke (rep_continuation *c, char *water_mark) { volatile char growth[STACK_GROWTH]; /* if stack isn't large enough, recurse again */ #if STACK_DIRECTION < 0 if (water_mark >= c->stack_top) grow_stack_and_invoke (c, (char *) growth + STACK_GROWTH); #else if (water_mark <= c->stack_top) grow_stack_and_invoke (c, (char *) growth); #endif FLUSH_REGISTER_WINDOWS; /* stack's big enough now, so reload the saved copy somewhere below the current position. */ #if STACK_DIRECTION < 0 memcpy (c->stack_top, c->stack_copy, c->real_size); #else memcpy (c->stack_bottom, c->stack_copy, c->real_size); #endif longjmp (c->jmpbuf, 1); } static void primitive_invoke_continuation (rep_continuation *c, repv ret) { char water_mark; rep_barrier **dest_hist = 0, *dest_root = 0, *anc, *ptr; int depth; /* try to find a route from the current root barrier to the root barrier of the continuation, without crossing any closed barriers */ dest_root = FIXUP (rep_barrier *, c, c->barriers); dest_hist = alloca (sizeof (rep_barrier *) * dest_root->depth); depth = trace_barriers (c, dest_hist); anc = common_ancestor (barriers, dest_hist, depth); if (anc == 0) { DEFSTRING (unreachable, "unreachable continuation"); Fsignal (Qerror, rep_LIST_1 (rep_VAL (&unreachable))); return; } /* Handle any `out' barrier functions */ for (ptr = barriers; ptr != anc; ptr = ptr->next) { DB (("invoke: outwards through %p (%d)\n", ptr, ptr->depth)); if (ptr->out != 0) { repv cont = rep_VAL (c); rep_GC_root gc_cont, gc_ret; rep_PUSHGC (gc_cont, cont); rep_PUSHGC (gc_ret, ret); ptr->out (ptr->data); rep_POPGC; rep_POPGC; } } /* save the return value and recurse up the stack until there's room to invoke the continuation. Note that invoking this subr will already have restored the original environment since the call to Fmake_closure () will have saved its old state.. */ invoked_continuation = c; invoked_continuation_ret = ret; invoked_continuation_ancestor = anc; DB (("invoke: calling continuation %p\n", c)); grow_stack_and_invoke (c, &water_mark); } /* The continuations passed in from Fcall_cc () are actually closures around this subr. They have Qcontinuation bound to the primitive continuation object in their lexical environment */ DEFUN("primitive-invoke-continuation", Fprimitive_invoke_continuation, Sprimitive_invoke_continuation, (repv ret), rep_Subr1) { repv cont = Fsymbol_value (Qcontinuation, Qnil); if (cont == rep_NULL || !rep_CONTINP(cont) || (rep_CONTIN(cont)->car & CF_INVALID)) { DEFSTRING (invalid, "invalid continuation"); return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&invalid))); } primitive_invoke_continuation (rep_CONTIN (cont), ret); return rep_NULL; } static repv get_cont (repv arg) { return Fsymbol_value (Qcontinuation, Qnil); } DEFUN("continuation-callable-p", Fcontinuation_callable_p, Scontinuation_callable_p, (repv cont), rep_Subr1) /* ::doc:rep.lang.interpreter#continuation-callable-p:: continuation-callable-p CONTINUATION Returns `t' if the continuation object CONTINUATION from the current execution point of the interpreter. ::end:: */ { rep_continuation *c; rep_barrier **dest_hist = 0, *dest_root = 0, *anc; int depth; rep_DECLARE1(cont, rep_FUNARGP); cont = rep_call_with_closure (cont, get_cont, Qnil); if (cont == rep_NULL) return rep_NULL; rep_DECLARE1(cont, rep_CONTINP); c = rep_CONTIN (cont); if (c->car & CF_INVALID) return Qnil; /* copied from above function */ dest_root = FIXUP (rep_barrier *, c, c->barriers); dest_hist = alloca (sizeof (rep_barrier *) * dest_root->depth); depth = trace_barriers (c, dest_hist); anc = common_ancestor (barriers, dest_hist, depth); return anc == 0 ? Qnil : Qt; } static repv primitive_call_cc (repv (*callback)(rep_continuation *, void *), void *data, rep_continuation *c) { struct rep_saved_regexp_data re_data; repv ret; if (root_barrier == 0) { DEFSTRING (no_root, "no dynamic root"); return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&no_root))); } if (c == 0) { c = rep_ALLOC_CELL (sizeof (rep_continuation)); rep_data_after_gc += sizeof (rep_continuation); c->next = continuations; continuations = c; c->stack_copy = 0; } c->car = continuation_type (); if (setjmp (c->jmpbuf)) { /* back from call/cc */ rep_barrier *ancestor; /* fish out the continuation (variable `c' may have been lost) */ c = invoked_continuation; invoked_continuation = 0; rep_lisp_depth = c->lisp_depth; rep_single_step_flag = c->single_step; rep_throw_value = c->throw_value; memcpy (rep_blocked_ops, c->blocked_ops, sizeof (rep_blocked_ops)); rep_saved_matches = c->regexp_data; rep_gc_n_roots_stack = c->gc_n_roots; rep_gc_root_stack = c->gc_roots; rep_special_bindings = c->special_bindings; rep_call_stack = c->call_stack; root_barrier = c->root; barriers = c->barriers; ret = invoked_continuation_ret; invoked_continuation_ret = rep_NULL; ancestor = invoked_continuation_ancestor; invoked_continuation_ancestor = 0; /* handle any `in' barrier functions */ if (barriers != 0) { int count = barriers->depth - (ancestor ? ancestor->depth : 0); rep_barrier **hist = alloca (sizeof (rep_barrier *) * count); rep_barrier *ptr; int i = 0; for (ptr = barriers; ptr != ancestor; ptr = ptr->next) hist[i++] = ptr; for (i = count - 1; i >= 0; i--) { ptr = hist[i]; DB (("invoke: inwards through %p (%d)\n", ptr, ptr->depth)); if (ptr->in != 0) { rep_GC_root gc_ret; rep_PUSHGC (gc_ret, ret); ptr->in (ptr->data); rep_POPGC; } } } rep_pop_regexp_data (); } else { /* into call/cc */ rep_push_regexp_data (&re_data); c->barriers = barriers; c->root = root_barrier; root_barrier->targeted = 1; c->call_stack = rep_call_stack; c->special_bindings = rep_special_bindings; c->gc_roots = rep_gc_root_stack; c->gc_n_roots = rep_gc_n_roots_stack; c->regexp_data = rep_saved_matches; memcpy (c->blocked_ops, rep_blocked_ops, sizeof (c->blocked_ops)); c->throw_value = rep_throw_value; c->single_step = rep_single_step_flag; c->lisp_depth = rep_lisp_depth; c->stack_bottom = c->root->point; save_stack (c); DB (("call/cc: saved %p; real_size=%lu (%u)\n", c, (unsigned long) c->real_size, rep_stack_bottom - c->stack_top)); ret = callback (c, data); rep_pop_regexp_data (); } return ret; } static repv inner_call_cc (rep_continuation *c, void *data) { repv proxy; proxy = Fmake_closure (rep_VAL(&Sprimitive_invoke_continuation), Qnil); rep_FUNARG(proxy)->env = rep_add_binding_to_env (rep_FUNARG(proxy)->env, Qcontinuation, rep_VAL(c)); return rep_call_lisp1 ((repv) data, proxy); } DEFUN("call/cc", Fcall_cc, Scall_cc, (repv fun), rep_Subr1) /* ::doc:rep.lang.interpreter#call/cc:: call/cc FUNCTION Invoke FUNCTION with a single parameter, the continuation function of the current state of the interpreter. Subsequently calling the continuation function (with an optional single argument) will pass control immediately back to the statement following the call to the `call/cc' function (even if that stack frame has since been exited). ::end:: */ { return primitive_call_cc (inner_call_cc, (void *) fun, 0); } /* threads */ static inline void thread_save_environ (rep_thread *t) { t->env = rep_env; t->structure = rep_structure; } static inline void thread_load_environ (rep_thread *t) { rep_env = t->env; rep_structure = t->structure; } static void enqueue_thread (rep_thread *t, rep_barrier *root) { assert (!(t->car & TF_EXITED)); if (!(t->car & TF_SUSPENDED)) { t->pred = root->tail; if (t->pred != 0) t->pred->next = t; if (root->head == 0) root->head = t; root->tail = t; } else { rep_thread *ptr = root->susp_head; while (ptr != 0 && TV_LATER_P (&t->run_at, &ptr->run_at)) ptr = ptr->next; if (ptr != 0) { t->pred = ptr->pred; if (ptr->pred != 0) ptr->pred->next = t; else root->susp_head = t; ptr->pred = t; t->next = ptr; } else { t->pred = root->susp_tail; if (t->pred != 0) t->pred->next = t; if (root->susp_head == 0) root->susp_head = t; root->susp_tail = t; } } } static void unlink_thread (rep_thread *t) { rep_barrier *root = t->cont->root; if (t->pred != 0) t->pred->next = t->next; if (t->next != 0) t->next->pred = t->pred; if (!(t->car & TF_SUSPENDED)) { if (root->head == t) root->head = t->next; if (root->tail == t) root->tail = t->pred; } else { if (root->susp_head == t) root->susp_head = t->next; if (root->susp_tail == t) root->susp_tail = t->pred; } t->next = t->pred = 0; } static void thread_wake (rep_thread *t) { rep_barrier *root = t->cont->root; assert (t->car & TF_SUSPENDED); assert (!(t->car & TF_EXITED)); unlink_thread (t); t->car &= ~TF_SUSPENDED; enqueue_thread (t, root); } static rep_bool poll_threads (rep_barrier *root) { rep_bool woke_any = rep_FALSE; rep_thread *t, *next; for (t = root->susp_head; t != 0; t = next) { next = t->next; if (t->poll && t->poll (t, t->poll_arg)) { thread_wake (t); woke_any = rep_TRUE; } } return woke_any; } static repv inner_thread_invoke (rep_continuation *c, void *data) { rep_thread *t = data; t->cont = c; rep_thread_lock = root_barrier->head->lock; DB (("invoking thread %p\n", root_barrier->head)); thread_load_environ (root_barrier->head); primitive_invoke_continuation (root_barrier->head->cont, Qnil); return rep_NULL; } static void thread_invoke (void) { again: if (root_barrier == 0) return; if (root_barrier->head != 0) { rep_thread *active = root_barrier->active; assert (root_barrier->head != 0); root_barrier->active = root_barrier->head; if (active != 0) { /* save the continuation of this thread, then invoke the next thread */ active->lock = rep_thread_lock; thread_save_environ (active); primitive_call_cc (inner_thread_invoke, active, active->cont); } else { rep_thread_lock = root_barrier->head->lock; DB (("invoking thread %p\n", root_barrier->head)); thread_load_environ (root_barrier->head); primitive_invoke_continuation (root_barrier->head->cont, Qnil); } } else { /* No thread to run. If no suspended threads return from the root barrier. Else sleep.. */ if (root_barrier->susp_head == 0) { root_barrier->active = 0; assert (rep_throw_value != exit_barrier_cell); rep_CDR (exit_barrier_cell) = rep_throw_value; rep_throw_value = exit_barrier_cell; DB (("no more threads, throwing to root..\n")); return; } else if (poll_threads (root_barrier)) { /* something woke */ goto again; } else { rep_thread *b = root_barrier->susp_head; struct timeval now; gettimeofday (&now, 0); DB (("no more threads, sleeping..\n")); if (TV_LATER_P (&b->run_at, &now)) { struct timeval delta; delta.tv_sec = b->run_at.tv_sec - now.tv_sec; delta.tv_usec = b->run_at.tv_usec - now.tv_usec; while (delta.tv_usec < 0) { delta.tv_usec += 1000000; delta.tv_sec--; } rep_sleep_for (delta.tv_sec, delta.tv_usec / 1000); } DB (("..waking thread %p\n", b)); thread_wake (b); goto again; } } } static void thread_delete (rep_thread *t) { rep_barrier *root = t->cont->root; rep_thread *active = root->head; unlink_thread (t); t->car |= TF_EXITED; if (active == t) thread_invoke (); } static repv inner_make_thread (rep_continuation *c, void *data) { rep_thread *t = data; t->cont = c; enqueue_thread (t, t->cont->root); return -1; } static rep_thread * new_thread (repv name) { rep_thread *t = rep_ALLOC_CELL (sizeof (rep_thread)); rep_data_after_gc += sizeof (rep_thread); memset (t, 0, sizeof (rep_thread)); t->car = thread_type (); t->name = name; t->poll = 0; t->poll_arg = 0; t->exit_val = rep_NULL; t->next_alloc = threads; threads = t; return t; } static void ensure_default_thread (void) { if (root_barrier->active == 0) { /* entering threaded execution. make the default thread */ rep_thread *x = new_thread (Qnil); thread_save_environ (x); /* this continuation will never get called, but it simplifies things.. */ if (primitive_call_cc (inner_make_thread, x, 0) != -1) abort (); root_barrier->active = x; } } static rep_thread * make_thread (repv thunk, repv name, rep_bool suspended) { repv ret; rep_GC_root gc_thunk; rep_thread *t; if (root_barrier == 0) return 0; t = new_thread (name); if (suspended) t->car |= TF_SUSPENDED; thread_save_environ (t); ensure_default_thread (); rep_PUSHGC (gc_thunk, thunk); ret = primitive_call_cc (inner_make_thread, t, 0); rep_POPGC; if (ret == -1) return t; else { ret = rep_call_lisp0 (thunk); t->car |= TF_EXITED; if (ret != rep_NULL) { t->exit_val = ret; thread_delete (t); assert (rep_throw_value == exit_barrier_cell); } else { /* exited with a throw, throw out of the dynamic root */ rep_CDR (exit_barrier_cell) = rep_throw_value; rep_throw_value = exit_barrier_cell; } return 0; } } static rep_bool thread_yield (void) { struct timeval now; rep_thread *ptr, *next; rep_thread *old_head; if (root_barrier == 0) return rep_FALSE; old_head = root_barrier->head; rep_pending_thread_yield = rep_FALSE; if (root_barrier->head && root_barrier->head->next) { rep_thread *old = root_barrier->head; if (old->pred != 0) old->pred->next = old->next; if (old->next != 0) old->next->pred = old->pred; root_barrier->head = old->next; old->next = 0; old->pred = root_barrier->tail; old->pred->next = old; root_barrier->tail = old; } /* check suspend queue for threads that need waking */ if (root_barrier->susp_head != 0) gettimeofday (&now, 0); for (ptr = root_barrier->susp_head; ptr != 0; ptr = next) { next = ptr->next; if (TV_LATER_P (&now, &ptr->run_at) || (ptr->poll && ptr->poll (ptr, ptr->poll_arg))) { thread_wake (ptr); } } if (root_barrier->head != old_head) { thread_invoke (); return rep_TRUE; } else return rep_FALSE; } static void thread_suspend (rep_thread *t, unsigned long msecs, rep_bool (*poll)(rep_thread *t, void *arg), void *poll_arg) { rep_barrier *root = t->cont->root; assert (!(t->car & TF_SUSPENDED)); assert (!(t->car & TF_EXITED)); unlink_thread (t); t->car |= TF_SUSPENDED; if (msecs == 0) { /* XXX assumes twos-complement representation.. but Solaris XXX has a weird struct timeval.. */ t->run_at.tv_sec = ~0UL >> 1; t->run_at.tv_usec = ~0UL >> 1; } else { gettimeofday (&t->run_at, 0); t->run_at.tv_sec += (msecs / 1000); t->run_at.tv_usec += (msecs % 1000) * 1000; if (t->run_at.tv_usec > 1000000) { t->run_at.tv_sec += t->run_at.tv_usec / 1000000; t->run_at.tv_usec = t->run_at.tv_usec % 1000000; } } t->poll = poll; t->poll_arg = poll_arg; t->exit_val = Qnil; enqueue_thread (t, root); if (root_barrier->active == t) thread_invoke (); } unsigned long rep_max_sleep_for (void) { rep_barrier *root = root_barrier; if (root == 0 || root->active == 0) { /* not using threads, sleep as long as you like.. XXX grr.. using ULONG_MAX doesn't work on solaris*/ return UINT_MAX; } else if (root->head != 0 && root->head->next != 0) { /* other threads ready to run, don't sleep */ return 0; } else if (root->susp_head != 0) { /* other threads sleeping, how long until the first wakes? */ /* XXX ignores polling */ struct timeval now; long msecs; gettimeofday (&now, 0); msecs = ((root->susp_head->run_at.tv_sec - now.tv_sec) * 1000 + (root->susp_head->run_at.tv_usec - now.tv_usec) / 1000); return MAX (msecs, 0); } else { /* whatever.. */ return UINT_MAX; } } /* type hooks */ static void mark_cont (repv obj) { rep_GC_root *roots; rep_GC_n_roots *nroots; struct rep_Call *calls; struct rep_saved_regexp_data *matches; rep_barrier *barrier; rep_continuation *c = rep_CONTIN (obj); rep_MARKVAL (c->throw_value); rep_MARKVAL (c->special_bindings); for (barrier = c->barriers; barrier != 0 && !SP_OLDER_P ((char *) barrier, c->stack_bottom); barrier = FIXUP(rep_barrier *, c, barrier)->next) { rep_barrier *ptr = FIXUP (rep_barrier *, c, barrier); rep_thread *t; for (t = ptr->head; t != 0; t = t->next) rep_MARKVAL (rep_VAL (t)); for (t = ptr->susp_head; t != 0; t = t->next) rep_MARKVAL (rep_VAL (t)); rep_MARKVAL (rep_VAL (ptr->active)); } for (roots = c->gc_roots; roots != 0 && !SP_OLDER_P ((char *) roots, c->stack_bottom); roots = FIXUP(rep_GC_root *, c, roots)->next) { repv *ptr = FIXUP(rep_GC_root *, c, roots)->ptr; rep_MARKVAL (*FIXUP(repv *, c, ptr)); } for (nroots = c->gc_n_roots; nroots != 0 && !SP_OLDER_P ((char *) roots, c->stack_bottom); nroots = FIXUP(rep_GC_n_roots *, c, nroots)->next) { repv *ptr = FIXUP(repv *, c, FIXUP(rep_GC_n_roots *, c, nroots)->first); int n = FIXUP(rep_GC_n_roots *, c, nroots)->count, i; for (i = 0; i < n; i++) rep_MARKVAL (ptr[i]); } for (calls = c->call_stack; calls != 0 && !SP_OLDER_P ((char *) calls, c->stack_bottom); calls = FIXUP(struct rep_Call *, c, calls)->next) { struct rep_Call *lc = FIXUP(struct rep_Call *, c, calls); rep_MARKVAL(lc->fun); rep_MARKVAL(lc->args); rep_MARKVAL(lc->current_form); rep_MARKVAL(lc->saved_env); rep_MARKVAL(lc->saved_structure); } for (matches = c->regexp_data; matches != 0 && !SP_OLDER_P ((char *) matches, c->stack_bottom); matches = FIXUP(struct rep_saved_regexp_data *, c, matches)->next) { struct rep_saved_regexp_data *sd = FIXUP(struct rep_saved_regexp_data *, c, matches); assert (sd->type == rep_reg_obj || sd->type == rep_reg_string); if(sd->type == rep_reg_obj) { int i; for(i = 0; i < rep_NSUBEXP; i++) { rep_MARKVAL(sd->matches.obj.startp[i]); rep_MARKVAL(sd->matches.obj.endp[i]); } } rep_MARKVAL(sd->data); } } static void mark_all (void) { rep_barrier *ptr; for (ptr = barriers; ptr != 0; ptr = ptr->next) { rep_thread *t; for (t = ptr->head; t != 0; t = t->next) rep_MARKVAL (rep_VAL (t)); for (t = ptr->susp_head; t != 0; t = t->next) rep_MARKVAL (rep_VAL (t)); rep_MARKVAL (rep_VAL (ptr->active)); } } static void sweep_cont (void) { rep_continuation *c = continuations; continuations = 0; while (c) { rep_continuation *next = c->next; if (!rep_GC_CELL_MARKEDP (rep_VAL (c))) { rep_free (c->stack_copy); rep_FREE_CELL (c); } else { rep_GC_CLR_CELL (rep_VAL (c)); c->next = continuations; continuations = c; } c = next; } } static void print_cont (repv stream, repv obj) { rep_stream_puts (stream, "#", -1, rep_FALSE); } static int continuation_type (void) { static int type; if (type == 0) { type = rep_register_new_type ("continuation", rep_ptr_cmp, print_cont, print_cont, sweep_cont, mark_cont, mark_all, 0, 0, 0, 0, 0, 0); } return type; } static void mark_thread (repv obj) { rep_MARKVAL (rep_VAL (THREAD (obj)->cont)); rep_MARKVAL (THREAD (obj)->env); rep_MARKVAL (THREAD (obj)->structure); rep_MARKVAL (THREAD (obj)->name); rep_MARKVAL (THREAD (obj)->exit_val); } static void sweep_thread (void) { rep_thread *t = threads; threads = 0; while (t) { rep_thread *next = t->next_alloc; if (!rep_GC_CELL_MARKEDP (rep_VAL (t))) rep_FREE_CELL (t); else { rep_GC_CLR_CELL (rep_VAL (t)); t->next_alloc = threads; threads = t; } t = next; } } static void print_thread (repv stream, repv obj) { rep_stream_puts (stream, "#name)) { rep_stream_putc (stream, ' '); rep_stream_puts (stream, rep_STR (THREAD (obj)->name), -1, rep_FALSE); } rep_stream_putc (stream, '>'); } static int thread_type (void) { static int type; if (type == 0) { type = rep_register_new_type ("thread", rep_ptr_cmp, print_thread, print_thread, sweep_thread, mark_thread, 0, 0, 0, 0, 0, 0, 0); } return type; } #else /* WITH_CONTINUATIONS */ repv rep_call_with_barrier (repv (*callback)(repv), repv arg, rep_bool closed, void (*in)(void *), void (*out)(void *), void *data) { return callback (arg); } DEFSTRING (ccc_missing, "call/cc was not included in this system"); static repv call_cc_missing (void) { return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&ccc_missing))); } DEFUN ("call/cc", Fcall_cc, Scall_cc, (repv fun), rep_Subr1) { return call_cc_missing (); } DEFUN("continuation-callable-p", Fcontinuation_callable_p, Scontinuation_callable_p, (repv cont), rep_Subr1) { return rep_signal_arg_error (cont, 1); } unsigned long rep_max_sleep_for (void) { return UINT_MAX; } #endif /* !WITH_CONTINUATIONS */ /* misc lisp functions */ /* Bind one object, returning the handle to later unbind by. */ static repv bind_object(repv obj) { rep_type *t = rep_get_data_type(rep_TYPE(obj)); if (t->bind != 0) return t->bind(obj); else return Qnil; } static void unbind_object (repv handle) { repv obj; rep_type *t; if (handle == Qnil) return; else if (rep_CONSP (handle)) obj = rep_CAR (handle); else obj = handle; t = rep_get_data_type (rep_TYPE (obj)); if (t->unbind != 0) t->unbind(handle); } static void call_with_inwards (void *data_) { repv *data = data_; if (data[0] != rep_NULL) data[1] = bind_object (data[0]); else data[1] = rep_NULL; } static void call_with_outwards (void *data_) { repv *data = data_; if (data[1] != rep_NULL) { unbind_object (data[1]); data[1] = rep_NULL; } } DEFUN("call-with-object", Fcall_with_object, Scall_with_object, (repv arg, repv thunk), rep_Subr2) /* ::doc:rep.lang.interpreter#call-with-object:: call-with-object ARG THUNK Call the zero-parameter function THUNK, with object ARG temporarily `bound' (a type-specific operation, usually to make ARG `active' in some way). When THUNK returns ARG is unbound. The value returned by THUNK is then returned. If THUNK is ever left due to a continuation being invoked, ARG will be unbound. If THUNK is subsequently reentered, ARG will be rebound. ::end:: */ { repv data[2]; /* { ARG, HANDLE } */ data[0] = arg; data[1] = bind_object(data[0]); if (data[1] != rep_NULL) { repv ret; rep_GC_n_roots gc_data; rep_PUSHGCN (gc_data, data, 2); ret = rep_call_with_barrier (rep_call_lisp0, thunk, rep_FALSE, call_with_inwards, call_with_outwards, data); unbind_object (data[1]); rep_POPGCN; return ret; } else return rep_NULL; } DEFUN("call-with-dynamic-root", Fcall_with_dynamic_root, Scall_with_dynamic_root, (repv thunk), rep_Subr1) /* ::doc:rep.lang.interpreter#call-with-dynamic-root:: call-with-dynamic-root THUNK Call the zero-parameter function THUNK, as the root of a new execution environment. This means that the continuation of THUNK will always be reached once, and once only. Any continuations above the new root may not be invoked from inside the root. ::end:: */ { return rep_call_with_barrier (rep_call_lisp0, thunk, rep_TRUE, 0, 0, 0); } static void call_in (void *data_) { repv *data = data_; if (data[0] != Qnil) rep_call_lisp0 (data[0]); } static void call_out (void *data_) { repv *data = data_; if (data[1] != Qnil) rep_call_lisp0 (data[1]); } DEFUN("call-with-barrier", Fcall_with_barrier, Scall_with_barrier, (repv thunk, repv closed, repv in, repv out), rep_Subr4) /* ::doc:rep.lang.interpreter#call-with-barrier:: call-with-barrier THUNK CLOSED [IN-THUNK] [OUT-THUNK] Call THUNK inside a new execution environment. If CLOSED is non-`nil' then the new environment will be exited exactly once (i.e. continuations may not pass through it). Alternatively, if CLOSED is `nil' then the environment is said to be `open' and continuations may cause control to flow into and out of the new environment. As this happens one of IN-THUNK or OUT-THUNK will be called (if defined). The value of this function is the value returned by THUNK. ::end:: */ { repv thunks[2], ret; rep_GC_n_roots gc_thunks; thunks[0] = in; thunks[1] = out; rep_PUSHGCN (gc_thunks, thunks, 2); ret = rep_call_with_barrier (rep_call_lisp0, thunk, closed == Qnil ? rep_FALSE : rep_TRUE, call_in, call_out, thunks); rep_POPGCN; return ret; } DEFUN("make-thread", Fmake_thread, Smake_thread, (repv thunk, repv name), rep_Subr2) /* ::doc:rep.threads#make-thread:: make-thread THUNK [NAME] Create and return an object representing a new thread of execution. The new thread will begin by calling THUNK, a function with zero parameters. ::end:: */ { #ifdef WITH_CONTINUATIONS return rep_VAL (make_thread (thunk, name, rep_FALSE)); #else return call_cc_missing (); #endif } DEFUN("make-suspended-thread", Fmake_suspended_thread, Smake_suspended_thread, (repv thunk, repv name), rep_Subr2) /* ::doc:rep.threads#make-suspended-thread:: make-suspended-thread THUNK [NAME] Identical to `make-thread', except that the created thread will be immediately put in the suspended state. ::end:: */ { #ifdef WITH_CONTINUATIONS return rep_VAL (make_thread (thunk, name, rep_TRUE)); #else return call_cc_missing (); #endif } DEFUN("thread-yield", Fthread_yield, Sthread_yield, (void), rep_Subr0) /* ::doc:rep.threads#thread-yield:: thread-yield Pass control away from the current thread if other threads are waiting to run. ::end:: */ { #ifdef WITH_CONTINUATIONS return thread_yield () ? Qt : Qnil; #else return Qnil; #endif } DEFUN("thread-delete", Fthread_delete, Sthread_delete, (repv th), rep_Subr1) /* ::doc:rep.threads#thread-delete:: thread-delete [THREAD] Mark THREAD (or the current thread), as being deleted. It will not be switched to in the future. If the current thread is deleted, control will be passed to the next runnable thread. Deleting the last runnable thread results forces the containing dynamic root to be closed. ::end:: */ { #ifdef WITH_CONTINUATIONS if (th == Qnil) th = Fcurrent_thread (Qnil); rep_DECLARE1 (th, THREADP); thread_delete (THREAD (th)); return Qnil; #else return rep_signal_arg_error (th, 1); #endif } DEFUN("thread-suspend", Fthread_suspend, Sthread_suspend, (repv th, repv msecs), rep_Subr2) /* ::doc:rep.threads#thread-suspend:: thread-suspend [THREAD] [MSECS] Mark THREAD (or the current thread) as being suspended. It will not be selected until it has this status removed. Suspending the current thread will pass control to the next runnable thread. If there are no runnable threads, then sleep until the next thread becomes runnable. Returns true if the timeout was reached. ::end:: */ { #ifdef WITH_CONTINUATIONS long timeout; repv no_timeout; if (th == Qnil) th = Fcurrent_thread (Qnil); rep_DECLARE1 (th, THREADP); rep_DECLARE2_OPT (msecs, rep_NUMERICP); timeout = (msecs == Qnil) ? 1 : rep_get_long_int (msecs); thread_suspend (THREAD (th), timeout, 0, 0); no_timeout = THREAD (th)->exit_val; THREAD (th)->exit_val = rep_NULL; return no_timeout == Qnil ? Qt : Qnil; #else return rep_signal_arg_error (th, 1); #endif } #ifdef WITH_CONTINUATIONS static rep_bool thread_join_poller (rep_thread *t, void *arg) { rep_thread *th = arg; return (th->car & TF_EXITED) ? rep_TRUE : rep_FALSE; } #endif DEFUN("thread-join", Fthread_join, Sthread_join, (repv th, repv msecs, repv def), rep_Subr3) /* ::doc:rep.threads#thread-join:: thread-join THREAD [MSECS] [DEFAULT-VALUE] Suspend the current thread until THREAD has exited, or MSECS milliseconds have passed. If THREAD exits normally, return the value of the last form it evaluated, else return DEFAULT-VALUE. It is an error to call thread-join on a THREAD that is not a member of current dynamic root. ::end:: */ { #ifdef WITH_CONTINUATIONS repv self = Fcurrent_thread (Qnil); rep_DECLARE (1, th, XTHREADP (th) && th != self && THREAD (th)->cont->root == root_barrier); if (THREADP (self)) { rep_GC_root gc_th; rep_PUSHGC (gc_th, th); rep_DECLARE2_OPT (msecs, rep_NUMERICP); thread_suspend (THREAD (self), rep_get_long_int (msecs), thread_join_poller, THREAD (th)); THREAD (self)->exit_val = rep_NULL; rep_POPGC; if ((THREAD (th)->car & TF_EXITED) && THREAD (th)->exit_val) return THREAD (th)->exit_val; } return def; #else return rep_signal_arg_error (th, 1); #endif } DEFUN("thread-wake", Fthread_wake, Sthread_wake, (repv th), rep_Subr1) /* ::doc:rep.threads#thread-wake:: thread-wake [THREAD] If THREAD (or the current thread) is currently suspended, mark it as being runnable once more. ::end:: */ { #ifdef WITH_CONTINUATIONS if (th == Qnil) th = Fcurrent_thread (Qnil); rep_DECLARE1 (th, THREADP); THREAD (th)->exit_val = Qt; /* signals timeout not reached */ thread_wake (THREAD (th)); return Qnil; #else return rep_signal_arg_error (th, 1); #endif } DEFUN("threadp", Fthreadp, Sthreadp, (repv arg), rep_Subr1) /* ::doc:rep.threads#threadp:: threadp ARG Return `t' if ARG is a thread object. ::end:: */ { #ifdef WITH_CONTINUATIONS return XTHREADP (arg) ? Qt : Qnil; #else return Qnil; #endif } DEFUN("thread-suspended-p", Fthread_suspended_p, Sthread_suspended_p, (repv th), rep_Subr1) /* ::doc:rep.threads#thread-suspended-p:: thread-suspended-p THREAD Return `t' if THREAD is currently suspended from running. ::end:: */ { #ifdef WITH_CONTINUATIONS rep_DECLARE1 (th, THREADP); return (THREAD (th)->car & TF_SUSPENDED) ? Qt : Qnil; #else return rep_signal_arg_error (th, 1); #endif } DEFUN("thread-exited-p", Fthread_exited_p, Sthread_exited_p, (repv th), rep_Subr1) /* ::doc:rep.threads#thread-exited-p:: thread-exited-p THREAD Return `t' if THREAD has exited. ::end:: */ { #ifdef WITH_CONTINUATIONS rep_DECLARE1 (th, XTHREADP); return (THREAD (th)->car & TF_EXITED) ? Qt : Qnil; #else return rep_signal_arg_error (th, 1); #endif } DEFUN("current-thread", Fcurrent_thread, Scurrent_thread, (repv depth), rep_Subr1) /* ::doc:rep.threads#current-thread:: current-thread [DEPTH] Return the currently executing thread. ::end:: */ { #ifdef WITH_CONTINUATIONS rep_barrier *root; rep_DECLARE1_OPT (depth, rep_INTP); if (depth == Qnil) depth = rep_MAKE_INT (0); if (depth == rep_MAKE_INT (0)) ensure_default_thread (); root = get_dynamic_root (rep_INT (depth)); if (root == 0) return Qnil; else return (root->active) ? rep_VAL (root->active) : Qnil; #else return Qnil; #endif } DEFUN("all-threads", Fall_threads, Sall_threads, (repv depth), rep_Subr1) /* ::doc:rep.threads#all-threads:: all-threads [DEPTH] Return a list of all threads. ::end:: */ { #ifdef WITH_CONTINUATIONS rep_barrier *root; rep_DECLARE1_OPT (depth, rep_INTP); if (depth == Qnil) depth = rep_MAKE_INT (0); if (depth == rep_MAKE_INT (0)) ensure_default_thread (); root = get_dynamic_root (rep_INT (depth)); if (root == 0) return Qnil; else { repv out = Qnil; rep_thread *ptr; for (ptr = root->susp_tail; ptr != 0; ptr = ptr->pred) out = Fcons (rep_VAL (ptr), out); for (ptr = root->tail; ptr != 0; ptr = ptr->pred) out = Fcons (rep_VAL (ptr), out); return out; } #else return Qnil; #endif } DEFUN("thread-forbid", Fthread_forbid, Sthread_forbid, (void), rep_Subr0) /* ::doc:rep.threads#thread-forbid:: thread-forbid Increment the thread preemption lock. When greather than zero all preemption of threads is disabled. Returns `t' if preemption is blocked as this function returns. ::end:: */ { rep_FORBID; return rep_PREEMPTABLE_P ? Qnil : Qt; } DEFUN("thread-permit", Fthread_permit, Sthread_permit, (void), rep_Subr0) /* ::doc:rep.threads#thread-permit:: thread-permit Decrement the thread preemption lock. When greather than zero all preemption of threads is disabled. Returns `t' if preemption is blocked as this function returns. ::end:: */ { rep_PERMIT; return rep_PREEMPTABLE_P ? Qnil : Qt; } DEFUN("thread-name", Fthread_name, Sthread_name, (repv th), rep_Subr1) /* ::doc:rep.threads#thread-name: thread-name THREAD Return the name of the thread THREAD. ::end:: */ { #ifdef WITH_CONTINUATIONS rep_DECLARE1 (th, XTHREADP); return THREAD (th)->name; #else return rep_signal_arg_error (th, 1); #endif } /* dl hooks */ void rep_continuations_init (void) { repv tem = rep_push_structure ("rep.lang.interpreter"); #ifdef WITH_CONTINUATIONS exit_barrier_cell = Fcons (Qnil, Qnil); rep_mark_static (&exit_barrier_cell); rep_INTERN(continuation); rep_ADD_INTERNAL_SUBR(Sprimitive_invoke_continuation); #endif rep_ADD_SUBR(Scall_cc); rep_ADD_SUBR(Scontinuation_callable_p); rep_ADD_SUBR(Scall_with_object); rep_ADD_SUBR(Scall_with_dynamic_root); rep_ADD_SUBR(Scall_with_barrier); rep_pop_structure (tem); tem = rep_push_structure ("rep.threads"); rep_ADD_SUBR(Smake_thread); rep_ADD_SUBR(Smake_suspended_thread); rep_ADD_SUBR(Sthread_yield); rep_ADD_SUBR(Sthread_delete); rep_ADD_SUBR(Sthread_suspend); rep_ADD_SUBR(Sthread_join); rep_ADD_SUBR(Sthread_wake); rep_ADD_SUBR(Sthreadp); rep_ADD_SUBR(Sthread_suspended_p); rep_ADD_SUBR(Sthread_exited_p); rep_ADD_SUBR(Scurrent_thread); rep_ADD_SUBR(Sall_threads); rep_ADD_SUBR(Sthread_forbid); rep_ADD_SUBR(Sthread_permit); rep_ADD_SUBR(Sthread_name); rep_pop_structure (tem); } librep-0.90.2/src/bytecodes.h0000644000175200017520000002262711245011153015010 0ustar chrischris/* bytecodes.h -- Constant definitions of lispmach byte-codes Copyright (C) 1993, 1994 John Harper $Id$ This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #ifndef BYTECODES_H #define BYTECODES_H #define BYTECODE_MAJOR_VERSION 11 #define BYTECODE_MINOR_VERSION 0 /* Number of bits encoded in each extra opcode forming the argument. */ #define ARG_SHIFT 8 /* The bits in the opcode used to encode the argument. */ #define OP_ARG_MASK 0x07 /* The inverse of the above. */ #define OP_OP_MASK 0xf8 /* Special arg specifying that the next opcode is actually an 8-bit argument. */ #define OP_ARG_1BYTE 6 /* Special arg meaning following two opcodes are a 16-bit argument. The first opcode is the high bits, the second the low bits. */ #define OP_ARG_2BYTE 7 /* Opcodes which have an argument encoded in them */ #define OP_SLOT_REF 0x00 #define OP_SLOT_REF_0 0x00 #define OP_SLOT_REF_1 0x01 #define OP_SLOT_REF_2 0x02 #define OP_SLOT_REF_3 0x03 #define OP_SLOT_REF_4 0x04 #define OP_SLOT_REF_5 0x05 #define OP_SLOT_REF_6 0x06 #define OP_SLOT_REF_7 0x07 /* Call function on top of stack with following ARG parameters. Leave result on stack. */ #define OP_CALL 0x08 /* Push const[ARG] onto the stack. */ #define OP_PUSH 0x10 /* Push the value of the symbol const[ARG] onto the stack. */ #define OP_REFG 0x18 /* Set the value of symbol const[ARG] to the value on the stack. Pops the value off the stack. */ #define OP_SETG 0x20 /* Sets the ARG'th value in the lexical environment. Pops value */ #define OP_SETN 0x28 #define OP_SLOT_SET 0x30 #define OP_SLOT_SET_0 0x30 #define OP_SLOT_SET_1 0x31 #define OP_SLOT_SET_2 0x32 #define OP_SLOT_SET_3 0x33 #define OP_SLOT_SET_4 0x34 #define OP_SLOT_SET_5 0x35 #define OP_SLOT_SET_6 0x36 #define OP_SLOT_SET_7 0x37 /* Pushes the ARG'th value in the lexical environment */ #define OP_REFN 0x38 #define OP_REFN_0 0x38 #define OP_REFN_1 0x39 #define OP_REFN_2 0x3a #define OP_REFN_3 0x3b #define OP_REFN_4 0x3c #define OP_REFN_5 0x3d #define OP_REFN_6 0x3e #define OP_REFN_7 0x3f #define OP_LAST_WITH_ARGS 0x3f /* Opcodes without arguments. */ #define OP_REF 0x40 /* push (symbol-value pop) */ #define OP__SET 0x41 /* (set stk[1] stk[0]); pop; pop */ #define OP_FLUID_REF 0x42 /* call-1 fluid-ref */ #define OP_ENCLOSE 0x43 /* push (make-closure pop[1] nil) */ #define OP_INIT_BIND 0x44 /* new-binding-set */ #define OP_UNBIND 0x45 /* rewind-binding-set */ #define OP_DUP 0x46 /* push stk[0] */ #define OP_SWAP 0x47 /* stk[0] = stk[1], stk[1] = stk[0] */ #define OP_POP 0x48 /* pop[1] */ #define OP_NIL 0x49 /* push nil */ #define OP_T 0x4a /* push t */ #define OP_CONS 0x4b /* push (cons pop[1] pop[2]) */ #define OP_CAR 0x4c /* push (car pop[1]) */ #define OP_CDR 0x4d /* push (cdr pop[2]) */ #define OP_RPLACA 0x4e /* call-2 rplaca */ #define OP_RPLACD 0x4f /* call-2 rplacd */ #define OP_NTH 0x50 /* call-2 nth */ #define OP_NTHCDR 0x51 /* call-2 nthcdr */ #define OP_ASET 0x52 /* call-3 aset */ #define OP_AREF 0x53 /* call-2 aref */ #define OP_LENGTH 0x54 /* call-1 length */ #define OP_BIND 0x55 #define OP_ADD 0x56 /* push (+ pop[1] pop[2]) */ #define OP_NEG 0x57 /* push (- pop[1]) */ #define OP_SUB 0x58 /* push (- pop[1] pop[2]) */ #define OP_MUL 0x59 /* push (* pop[1] pop[2]) */ #define OP_DIV 0x5a /* push (/ pop[1] pop[2]) */ #define OP_REM 0x5b /* push (% pop[1] pop[2]) */ #define OP_LNOT 0x5c /* push (lognot pop[1]) */ #define OP_NOT 0x5d /* push (not pop[1]) */ #define OP_LOR 0x5e /* push (logior pop[1] pop[2]) */ #define OP_LAND 0x5f /* push (logand pop[1] pop[2]) */ #define OP_EQUAL 0x60 /* push (equal pop[1] pop[2]) */ #define OP_EQ 0x61 /* push (eq pop[1] pop[2]) */ #define OP_STRUCT_REF 0x62 /* push (structure-ref pop[1] pop[2])*/ #define OP_SCM_TEST 0x63 #define OP_GT 0x64 /* push (> pop[1] pop[2]) */ #define OP_GE 0x65 /* push (>= pop[1] pop[2]) */ #define OP_LT 0x66 /* push (< pop[1] pop[2]) */ #define OP_LE 0x67 /* push (<= pop[1] pop[2]) */ #define OP_INC 0x68 /* push (1+ pop[1]) */ #define OP_DEC 0x69 /* push (1- pop[1]) */ #define OP_ASH 0x6a /* push (ash pop[1] pop[2]) */ #define OP_ZEROP 0x6b /* push (zerop pop[1]) */ #define OP_NULL 0x6c /* push (null pop[1]) */ #define OP_ATOM 0x6d /* push (atom pop[1]) */ #define OP_CONSP 0x6e /* push (consp pop[1]) */ #define OP_LISTP 0x6f /* push (listp pop[1]) */ #define OP_NUMBERP 0x70 /* push (numberp pop[1]) */ #define OP_STRINGP 0x71 /* push (stringp pop[1]) */ #define OP_VECTORP 0x72 /* push (vectorp pop[1]) */ #define OP_CATCH 0x73 /* if stk[0] == (car stk[1]) then stk[0] := nil, stk[1] = (cdr stk[1]) */ #define OP_THROW 0x74 /* throw_val = (cons pop[1] pop[2]), goto error-handler */ #define OP_BINDERR 0x75 /* bind (cons pop[1] SP) */ #define OP_RETURN 0x76 #define OP_UNBINDALL 0x77 #define OP_BOUNDP 0x78 /* call-1 boundp */ #define OP_SYMBOLP 0x79 /* push (symbolp pop[1]) */ #define OP_GET 0x7a /* call-2 get */ #define OP_PUT 0x7b /* call-3 put */ #define OP_ERRORPRO 0x7c /* cond = pop[1]; if match_error(stk[0], cond) then bindsym (stk[1], cdr stk[0]), stk[0] = nil */ #define OP_SIGNAL 0x7d /* call-2 signal */ #define OP_QUOTIENT 0x7e #define OP_REVERSE 0x7f /* call-1 reverse */ #define OP_NREVERSE 0x80 /* call-1 nreverse */ #define OP_ASSOC 0x81 /* call-2 assoc */ #define OP_ASSQ 0x82 /* call-2 assq */ #define OP_RASSOC 0x83 /* call-2 rassoc */ #define OP_RASSQ 0x84 /* call-2 rassq */ #define OP_LAST 0x85 /* call-1 last */ #define OP_MAPCAR 0x86 /* call-2 mapcar */ #define OP_MAPC 0x87 /* call-1 mapc */ #define OP_MEMBER 0x88 /* call-2 member */ #define OP_MEMQ 0x89 /* call-2 memq */ #define OP_DELETE 0x8a /* call-2 delete */ #define OP_DELQ 0x8b /* call-2 delq */ #define OP_DELETE_IF 0x8c /* call-2 delete-if */ #define OP_DELETE_IF_NOT 0x8d /* call-2 delete-if-not */ #define OP_COPY_SEQUENCE 0x8e /* call-1 copy-sequence */ #define OP_SEQUENCEP 0x8f /* call-1 sequencep */ #define OP_FUNCTIONP 0x90 /* call-1 functionp */ #define OP_SPECIAL_FORM_P 0x91 /* call-1 special-form-p */ #define OP_SUBRP 0x92 /* call-1 subrp */ #define OP_EQL 0x93 /* push (eql pop[1] pop[2]) */ #define OP_LXOR 0x94 /* push (logxor pop[1] pop[2] */ #define OP_MAX 0x95 /* push (max pop[1] pop[2]) */ #define OP_MIN 0x96 /* push (min pop[1] pop[2]) */ #define OP_FILTER 0x97 /* call-2 filter */ #define OP_MACROP 0x98 /* call-1 macrop */ #define OP_BYTECODEP 0x99 /* call-1 bytecodep */ #define OP_PUSHI0 0x9a /* push #0 */ #define OP_PUSHI1 0x9b /* push #1 */ #define OP_PUSHI2 0x9c /* push #2 */ #define OP_PUSHIM1 0x9d /* push #-1 */ #define OP_PUSHIM2 0x9e /* push #-2 */ #define OP_PUSHI 0x9f /* push (signed) pc[0] */ #define OP_PUSHIWN 0xa0 /* push (- pc[0,1]) */ #define OP_PUSHIWP 0xa1 /* push (+ pc[0,1]) */ #define OP_CAAR 0xa2 /* push (car (car pop[1])) */ #define OP_CADR 0xa3 /* push (car (cdr pop[1])) */ #define OP_CDAR 0xa4 /* push (cdr (car pop[1])) */ #define OP_CDDR 0xa5 /* push (cdr (cdr pop[1])) */ #define OP_CADDR 0xa6 #define OP_CADDDR 0xa7 #define OP_CADDDDR 0xa8 #define OP_CADDDDDR 0xa9 #define OP_CADDDDDDR 0xaa #define OP_CADDDDDDDR 0xab #define OP_FLOOR 0xac #define OP_CEILING 0xad #define OP_TRUNCATE 0xae #define OP_ROUND 0xaf #define OP_APPLY 0xb0 #define OP_FORBID 0xb1 #define OP_PERMIT 0xb2 #define OP_EXP 0xb3 #define OP_LOG 0xb4 #define OP_SIN 0xb5 #define OP_COS 0xb6 #define OP_TAN 0xb7 #define OP_SQRT 0xb8 #define OP_EXPT 0xb9 #define OP_SWAP2 0xba /* stk[0] = stk[1], stk[1] = stk[2], stk[2] = stk[0]. */ #define OP_MOD 0xbb /* push (mod pop[1] pop[2]) */ #define OP_MAKE_CLOSURE 0xbc /* push (make-closure pop[1] pop[2]) */ #define OP_UNBINDALL_0 0xbd #define OP_CLOSUREP 0xbe /* push (closurep pop[1]) */ #define OP_POP_ALL 0xbf #define OP_FLUID_SET 0xc0 #define OP_FLUID_BIND 0xc1 #define OP_MEMQL 0xc2 /* call-2 memql */ #define OP_NUM_EQ 0xc3 #define OP_TEST_SCM 0xc4 #define OP_TEST_SCM_F 0xc5 #define OP__DEFINE 0xc6 #define OP_SPEC_BIND 0xc7 #define OP_SET 0xc8 #define OP_REQUIRED_ARG 0xc9 #define OP_OPTIONAL_ARG 0xca #define OP_REST_ARG 0xcb #define OP_NOT_ZERO_P 0xcc #define OP_KEYWORD_ARG 0xcd #define OP_OPTIONAL_ARG_ 0xce #define OP_KEYWORD_ARG_ 0xcf /* Jump opcodes */ #define OP_LAST_BEFORE_JMPS 0xf7 #define OP_EJMP 0xf8 /* if (not pop[1]) jmp pc[0,1] else throw_val = arg, goto error-handler */ #define OP_JPN 0xf9 /* if (not stk[0]) pop; jmp pc[0,1] */ #define OP_JPT 0xfa /* if stk[0] pop; jmp pc[0,1] */ #define OP_JMP 0xfb /* jmp pc[0,1] */ #define OP_JN 0xfc /* if (not pop[1]) jmp pc[0,1] */ #define OP_JT 0xfd /* if pop[1] jmp pc[0,1] */ #define OP_JNP 0xfe /* if (not stk[0]) jmp else pop */ #define OP_JTP 0xff /* if stk[0] jmp else pop */ #endif /* BYTECODES_H */ librep-0.90.2/src/alloca.c0000644000175200017520000003340511245011153014251 0ustar chrischris/* alloca.c -- allocate automatically reclaimed memory (Mostly) portable public-domain implementation -- D A Gwyn This implementation of the PWB library alloca function, which is used to allocate space off the run-time stack so that it is automatically reclaimed upon procedure exit, was inspired by discussions with J. Q. Johnson of Cornell. J.Otto Tennant contributed the Cray support. There are some preprocessor constants that can be defined when compiling for your specific system, for improved efficiency; however, the defaults should be okay. The general concept of this implementation is to keep track of all alloca-allocated blocks, and reclaim any that are found to be deeper in the stack than the current invocation. This heuristic does not reclaim storage as soon as it becomes invalid, but it will do so eventually. As a special case, alloca(0) reclaims storage without allocating any. It is a good idea to use alloca(0) in your main control loop, etc. to force garbage collection. */ #ifdef HAVE_CONFIG_H #include #endif #ifdef emacs #include "blockinput.h" #endif /* If compiling with GCC 2, this file's not needed. */ #if !defined (__GNUC__) || __GNUC__ < 2 /* If someone has defined alloca as a macro, there must be some other way alloca is supposed to work. */ #ifndef alloca #ifdef emacs #ifdef static /* actually, only want this if static is defined as "" -- this is for usg, in which emacs must undefine static in order to make unexec workable */ #ifndef STACK_DIRECTION you lose -- must know STACK_DIRECTION at compile-time #endif /* STACK_DIRECTION undefined */ #endif /* static */ #endif /* emacs */ /* If your stack is a linked list of frames, you have to provide an "address metric" ADDRESS_FUNCTION macro. */ #if defined (CRAY) && defined (CRAY_STACKSEG_END) long i00afunc (); #define ADDRESS_FUNCTION(arg) (char *) i00afunc (&(arg)) #else #define ADDRESS_FUNCTION(arg) &(arg) #endif #if __STDC__ typedef void *pointer; #else typedef char *pointer; #endif #define NULL 0 /* Different portions of Emacs need to call different versions of malloc. The Emacs executable needs alloca to call xmalloc, because ordinary malloc isn't protected from input signals. On the other hand, the utilities in lib-src need alloca to call malloc; some of them are very simple, and don't have an xmalloc routine. Non-Emacs programs expect this to call use xmalloc. Callers below should use malloc. */ #ifndef emacs #define malloc xmalloc #endif extern pointer malloc (); /* Define STACK_DIRECTION if you know the direction of stack growth for your system; otherwise it will be automatically deduced at run-time. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown */ #ifndef STACK_DIRECTION #define STACK_DIRECTION 0 /* Direction unknown. */ #endif #if STACK_DIRECTION != 0 #define STACK_DIR STACK_DIRECTION /* Known at compile-time. */ #else /* STACK_DIRECTION == 0; need run-time code. */ static int stack_dir; /* 1 or -1 once known. */ #define STACK_DIR stack_dir static void find_stack_direction () { static char *addr = NULL; /* Address of first `dummy', once known. */ auto char dummy; /* To get stack address. */ if (addr == NULL) { /* Initial entry. */ addr = ADDRESS_FUNCTION (dummy); find_stack_direction (); /* Recurse once. */ } else { /* Second entry. */ if (ADDRESS_FUNCTION (dummy) > addr) stack_dir = 1; /* Stack grew upward. */ else stack_dir = -1; /* Stack grew downward. */ } } #endif /* STACK_DIRECTION == 0 */ /* An "alloca header" is used to: (a) chain together all alloca'ed blocks; (b) keep track of stack depth. It is very important that sizeof(header) agree with malloc alignment chunk size. The following default should work okay. */ #ifndef ALIGN_SIZE #define ALIGN_SIZE sizeof(double) #endif typedef union hdr { char align[ALIGN_SIZE]; /* To force sizeof(header). */ struct { union hdr *next; /* For chaining headers. */ char *deep; /* For stack depth measure. */ } h; } header; static header *last_alloca_header = NULL; /* -> last alloca header. */ /* Return a pointer to at least SIZE bytes of storage, which will be automatically reclaimed upon exit from the procedure that called alloca. Originally, this space was supposed to be taken from the current stack frame of the caller, but that method cannot be made to work for some implementations of C, for example under Gould's UTX/32. */ pointer alloca (size) unsigned size; { auto char probe; /* Probes stack depth: */ register char *depth = ADDRESS_FUNCTION (probe); #if STACK_DIRECTION == 0 if (STACK_DIR == 0) /* Unknown growth direction. */ find_stack_direction (); #endif /* Reclaim garbage, defined as all alloca'd storage that was allocated from deeper in the stack than currently. */ { register header *hp; /* Traverses linked list. */ #ifdef emacs BLOCK_INPUT; #endif for (hp = last_alloca_header; hp != NULL;) if ((STACK_DIR > 0 && hp->h.deep > depth) || (STACK_DIR < 0 && hp->h.deep < depth)) { register header *np = hp->h.next; free ((pointer) hp); /* Collect garbage. */ hp = np; /* -> next header. */ } else break; /* Rest are not deeper. */ last_alloca_header = hp; /* -> last valid storage. */ #ifdef emacs UNBLOCK_INPUT; #endif } if (size == 0) return NULL; /* No allocation required. */ /* Allocate combined header + user data storage. */ { register pointer new = malloc (sizeof (header) + size); /* Address of header. */ ((header *) new)->h.next = last_alloca_header; ((header *) new)->h.deep = depth; last_alloca_header = (header *) new; /* User storage begins just after header. */ return (pointer) ((char *) new + sizeof (header)); } } #if defined (CRAY) && defined (CRAY_STACKSEG_END) #ifdef DEBUG_I00AFUNC #include #endif #ifndef CRAY_STACK #define CRAY_STACK #ifndef CRAY2 /* Stack structures for CRAY-1, CRAY X-MP, and CRAY Y-MP */ struct stack_control_header { long shgrow:32; /* Number of times stack has grown. */ long shaseg:32; /* Size of increments to stack. */ long shhwm:32; /* High water mark of stack. */ long shsize:32; /* Current size of stack (all segments). */ }; /* The stack segment linkage control information occurs at the high-address end of a stack segment. (The stack grows from low addresses to high addresses.) The initial part of the stack segment linkage control information is 0200 (octal) words. This provides for register storage for the routine which overflows the stack. */ struct stack_segment_linkage { long ss[0200]; /* 0200 overflow words. */ long sssize:32; /* Number of words in this segment. */ long ssbase:32; /* Offset to stack base. */ long:32; long sspseg:32; /* Offset to linkage control of previous segment of stack. */ long:32; long sstcpt:32; /* Pointer to task common address block. */ long sscsnm; /* Private control structure number for microtasking. */ long ssusr1; /* Reserved for user. */ long ssusr2; /* Reserved for user. */ long sstpid; /* Process ID for pid based multi-tasking. */ long ssgvup; /* Pointer to multitasking thread giveup. */ long sscray[7]; /* Reserved for Cray Research. */ long ssa0; long ssa1; long ssa2; long ssa3; long ssa4; long ssa5; long ssa6; long ssa7; long sss0; long sss1; long sss2; long sss3; long sss4; long sss5; long sss6; long sss7; }; #else /* CRAY2 */ /* The following structure defines the vector of words returned by the STKSTAT library routine. */ struct stk_stat { long now; /* Current total stack size. */ long maxc; /* Amount of contiguous space which would be required to satisfy the maximum stack demand to date. */ long high_water; /* Stack high-water mark. */ long overflows; /* Number of stack overflow ($STKOFEN) calls. */ long hits; /* Number of internal buffer hits. */ long extends; /* Number of block extensions. */ long stko_mallocs; /* Block allocations by $STKOFEN. */ long underflows; /* Number of stack underflow calls ($STKRETN). */ long stko_free; /* Number of deallocations by $STKRETN. */ long stkm_free; /* Number of deallocations by $STKMRET. */ long segments; /* Current number of stack segments. */ long maxs; /* Maximum number of stack segments so far. */ long pad_size; /* Stack pad size. */ long current_address; /* Current stack segment address. */ long current_size; /* Current stack segment size. This number is actually corrupted by STKSTAT to include the fifteen word trailer area. */ long initial_address; /* Address of initial segment. */ long initial_size; /* Size of initial segment. */ }; /* The following structure describes the data structure which trails any stack segment. I think that the description in 'asdef' is out of date. I only describe the parts that I am sure about. */ struct stk_trailer { long this_address; /* Address of this block. */ long this_size; /* Size of this block (does not include this trailer). */ long unknown2; long unknown3; long link; /* Address of trailer block of previous segment. */ long unknown5; long unknown6; long unknown7; long unknown8; long unknown9; long unknown10; long unknown11; long unknown12; long unknown13; long unknown14; }; #endif /* CRAY2 */ #endif /* not CRAY_STACK */ #ifdef CRAY2 /* Determine a "stack measure" for an arbitrary ADDRESS. I doubt that "lint" will like this much. */ static long i00afunc (long *address) { struct stk_stat status; struct stk_trailer *trailer; long *block, size; long result = 0; /* We want to iterate through all of the segments. The first step is to get the stack status structure. We could do this more quickly and more directly, perhaps, by referencing the $LM00 common block, but I know that this works. */ STKSTAT (&status); /* Set up the iteration. */ trailer = (struct stk_trailer *) (status.current_address + status.current_size - 15); /* There must be at least one stack segment. Therefore it is a fatal error if "trailer" is null. */ if (trailer == 0) abort (); /* Discard segments that do not contain our argument address. */ while (trailer != 0) { block = (long *) trailer->this_address; size = trailer->this_size; if (block == 0 || size == 0) abort (); trailer = (struct stk_trailer *) trailer->link; if ((block <= address) && (address < (block + size))) break; } /* Set the result to the offset in this segment and add the sizes of all predecessor segments. */ result = address - block; if (trailer == 0) { return result; } do { if (trailer->this_size <= 0) abort (); result += trailer->this_size; trailer = (struct stk_trailer *) trailer->link; } while (trailer != 0); /* We are done. Note that if you present a bogus address (one not in any segment), you will get a different number back, formed from subtracting the address of the first block. This is probably not what you want. */ return (result); } #else /* not CRAY2 */ /* Stack address function for a CRAY-1, CRAY X-MP, or CRAY Y-MP. Determine the number of the cell within the stack, given the address of the cell. The purpose of this routine is to linearize, in some sense, stack addresses for alloca. */ static long i00afunc (long address) { long stkl = 0; long size, pseg, this_segment, stack; long result = 0; struct stack_segment_linkage *ssptr; /* Register B67 contains the address of the end of the current stack segment. If you (as a subprogram) store your registers on the stack and find that you are past the contents of B67, you have overflowed the segment. B67 also points to the stack segment linkage control area, which is what we are really interested in. */ stkl = CRAY_STACKSEG_END (); ssptr = (struct stack_segment_linkage *) stkl; /* If one subtracts 'size' from the end of the segment, one has the address of the first word of the segment. If this is not the first segment, 'pseg' will be nonzero. */ pseg = ssptr->sspseg; size = ssptr->sssize; this_segment = stkl - size; /* It is possible that calling this routine itself caused a stack overflow. Discard stack segments which do not contain the target address. */ while (!(this_segment <= address && address <= stkl)) { #ifdef DEBUG_I00AFUNC fprintf (stderr, "%011o %011o %011o\n", this_segment, address, stkl); #endif if (pseg == 0) break; stkl = stkl - pseg; ssptr = (struct stack_segment_linkage *) stkl; size = ssptr->sssize; pseg = ssptr->sspseg; this_segment = stkl - size; } result = address - this_segment; /* If you subtract pseg from the current end of the stack, you get the address of the previous stack segment's end. This seems a little convoluted to me, but I'll bet you save a cycle somewhere. */ while (pseg != 0) { #ifdef DEBUG_I00AFUNC fprintf (stderr, "%011o %011o\n", pseg, size); #endif stkl = stkl - pseg; ssptr = (struct stack_segment_linkage *) stkl; size = ssptr->sssize; pseg = ssptr->sspseg; result += size; } return (result); } #endif /* not CRAY2 */ #endif /* CRAY */ #endif /* no alloca */ #endif /* not GCC version 2 */ librep-0.90.2/src/README.sdbm0000644000175200017520000002630111245011153014453 0ustar chrischris sdbm - Substitute DBM or Berkeley ndbm for Every UN*X[1] Made Simple Ozan (oz) Yigit The Guild of PD Software Toolmakers Toronto - Canada oz@nexus.yorku.ca Implementation is the sincerest form of flattery. - L. Peter Deutsch A The Clone of the ndbm library The sources accompanying this notice - sdbm - consti- tute the first public release (Dec. 1990) of a complete clone of the Berkeley UN*X ndbm library. The sdbm library is meant to clone the proven functionality of ndbm as closely as possible, including a few improvements. It is practical, easy to understand, and compatible. The sdbm library is not derived from any licensed, proprietary or copyrighted software. The sdbm implementation is based on a 1978 algorithm [Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''. In the course of searching for a substitute for ndbm, I pro- totyped three different external-hashing algorithms [Lar78, Fag79, Lit80] and ultimately chose Larson's algorithm as a basis of the sdbm implementation. The Bell Labs dbm (and therefore ndbm) is based on an algorithm invented by Ken Thompson, [Tho90, Tor87] and predates Larson's work. The sdbm programming interface is totally compatible with ndbm and includes a slight improvement in database ini- tialization. It is also expected to be binary-compatible under most UN*X versions that support the ndbm library. The sdbm implementation shares the shortcomings of the ndbm library, as a side effect of various simplifications to the original Larson algorithm. It does produce holes in the page file as it writes pages past the end of file. (Larson's paper include a clever solution to this problem that is a result of using the hash value directly as a block address.) On the other hand, extensive tests seem to indicate that sdbm creates fewer holes in general, and the resulting page- files are smaller. The sdbm implementation is also faster than ndbm in database creation. Unlike the ndbm, the sdbm _________________________ [1] UN*X is not a trademark of any (dis)organization. - 2 - store operation will not ``wander away'' trying to split its data pages to insert a datum that cannot (due to elaborate worst-case situations) be inserted. (It will fail after a pre-defined number of attempts.) Important Compatibility Warning The sdbm and ndbm libraries cannot share databases: one cannot read the (dir/pag) database created by the other. This is due to the differences between the ndbm and sdbm algorithms[2], and the hash functions used. It is easy to convert between the dbm/ndbm databases and sdbm by ignoring the index completely: see dbd, dbu etc. Notice of Intellectual Property The entire sdbm library package, as authored by me, Ozan S. Yigit, is hereby placed in the public domain. As such, the author is not responsible for the consequences of use of this software, no matter how awful, even if they arise from defects in it. There is no expressed or implied warranty for the sdbm library. Since the sdbm library package is in the public domain, this original release or any additional public-domain releases of the modified original cannot possibly (by defin- ition) be withheld from you. Also by definition, You (singu- lar) have all the rights to this code (including the right to sell without permission, the right to hoard[3] and the right to do other icky things as you see fit) but those rights are also granted to everyone else. Please note that all previous distributions of this software contained a copyright (which is now dropped) to protect its origins and its current public domain status against any possible claims and/or challenges. Acknowledgments Many people have been very helpful and supportive. A partial list would necessarily include Rayan Zacherissen (who contributed the man page, and also hacked a MMAP _________________________ [2] Torek's discussion [Tor87] indicates that dbm/ndbm implementations use the hash value to traverse the radix trie differently than sdbm and as a result, the page indexes are generated in different order. For more information, send e-mail to the author. [3] You cannot really hoard something that is avail- able to the public at large, but try if it makes you feel any better. - 3 - version of sdbm), Arnold Robbins, Chris Lewis, Bill David- sen, Henry Spencer, Geoff Collyer, Rich Salz (who got me started in the first place), Johannes Ruschein (who did the minix port) and David Tilbrook. I thank you all. Distribution Manifest and Notes This distribution of sdbm includes (at least) the following: CHANGES change log README this file. biblio a small bibliography on external hashing dba.c a crude (n/s)dbm page file analyzer dbd.c a crude (n/s)dbm page file dumper (for conversion) dbe.1 man page for dbe.c dbe.c Janick's database editor dbm.c a dbm library emulation wrapper for ndbm/sdbm dbm.h header file for the above dbu.c a crude db management utility hash.c hashing function makefile guess. pair.c page-level routines (posted earlier) pair.h header file for the above readme.ms troff source for the README file sdbm.3 man page sdbm.c the real thing sdbm.h header file for the above tune.h place for tuning & portability thingies util.c miscellaneous dbu is a simple database manipulation program[4] that tries to look like Bell Labs' cbt utility. It is currently incomplete in functionality. I use dbu to test out the rou- tines: it takes (from stdin) tab separated key/value pairs for commands like build or insert or takes keys for commands like delete or look. dbu dbmfile dba is a crude analyzer of dbm/sdbm/ndbm page files. It scans the entire page file, reporting page level statistics, and totals at the end. dbd is a crude dump program for dbm/ndbm/sdbm data- bases. It ignores the bitmap, and dumps the data pages in sequence. It can be used to create input for the dbu util- ity. Note that dbd will skip any NULLs in the key and data fields, thus is unsuitable to convert some peculiar _________________________ [4] The dbd, dba, dbu utilities are quick hacks and are not fit for production use. They were developed late one night, just to test out sdbm, and convert some databases. - 4 - databases that insist in including the terminating null. I have also included a copy of the dbe (ndbm DataBase Editor) by Janick Bergeron [janick@bnr.ca] for your pleas- ure. You may find it more useful than the little dbu util- ity. dbm.[ch] is a dbm library emulation on top of ndbm (and hence suitable for sdbm). Written by Robert Elz. The sdbm library has been around in beta test for quite a long time, and from whatever little feedback I received (maybe no news is good news), I believe it has been func- tioning without any significant problems. I would, of course, appreciate all fixes and/or improvements. Portabil- ity enhancements would especially be useful. Implementation Issues Hash functions: The algorithm behind sdbm implementa- tion needs a good bit-scrambling hash function to be effec- tive. I ran into a set of constants for a simple hash func- tion that seem to help sdbm perform better than ndbm for various inputs: /* * polynomial conversion ignoring overflows * 65599 nice. 65587 even better. */ long dbm_hash(char *str, int len) { register unsigned long n = 0; while (len--) n = n * 65599 + *str++; return n; } There may be better hash functions for the purposes of dynamic hashing. Try your favorite, and check the pagefile. If it contains too many pages with too many holes, (in rela- tion to this one for example) or if sdbm simply stops work- ing (fails after SPLTMAX attempts to split) when you feed your NEWS history file to it, you probably do not have a good hashing function. If you do better (for different types of input), I would like to know about the function you use. Block sizes: It seems (from various tests on a few machines) that a page file block size PBLKSIZ of 1024 is by far the best for performance, but this also happens to limit the size of a key/value pair. Depending on your needs, you may wish to increase the page size, and also adjust PAIRMAX (the maximum size of a key/value pair allowed: should always - 5 - be at least three words smaller than PBLKSIZ.) accordingly. The system-wide version of the library should probably be configured with 1024 (distribution default), as this appears to be sufficient for most common uses of sdbm. Portability This package has been tested in many different UN*Xes even including minix, and appears to be reasonably portable. This does not mean it will port easily to non-UN*X systems. Notes and Miscellaneous The sdbm is not a very complicated package, at least not after you familiarize yourself with the literature on external hashing. There are other interesting algorithms in existence that ensure (approximately) single-read access to a data value associated with any key. These are directory- less schemes such as linear hashing [Lit80] (+ Larson varia- tions), spiral storage [Mar79] or directory schemes such as extensible hashing [Fag79] by Fagin et al. I do hope these sources provide a reasonable playground for experimentation with other algorithms. See the June 1988 issue of ACM Com- puting Surveys [Enb88] for an excellent overview of the field. References [Lar78] P.-A. Larson, ``Dynamic Hashing'', BIT, vol. 18, pp. 184-201, 1978. [Tho90] Ken Thompson, private communication, Nov. 1990 [Lit80] W. Litwin, `` Linear Hashing: A new tool for file and table addressing'', Proceedings of the 6th Conference on Very Large Dabatases (Montreal), pp. 212-223, Very Large Database Foundation, Saratoga, Calif., 1980. [Fag79] R. Fagin, J. Nievergelt, N. Pippinger, and H. R. Strong, ``Extendible Hashing - A Fast Access Method for Dynamic Files'', ACM Trans. Database Syst., vol. 4, no.3, pp. 315-344, Sept. 1979. [Wal84] Rich Wales, ``Discussion of "dbm" data base system'', USENET newsgroup unix.wizards, Jan. 1984. [Tor87] Chris Torek, ``Re: dbm.a and ndbm.a archives'', - 6 - USENET newsgroup comp.unix, 1987. [Mar79] G. N. Martin, ``Spiral Storage: Incrementally Augment- able Hash Addressed Storage'', Technical Report #27, University of Varwick, Coventry, U.K., 1979. [Enb88] R. J. Enbody and H. C. Du, ``Dynamic Hashing Schemes'',ACM Computing Surveys, vol. 20, no. 2, pp. 85-113, June 1988. librep-0.90.2/src/README.regexp0000644000175200017520000001273411245011153015025 0ustar chrischris This is a version of Henry Spencer's famous regexp implementation. I've modified it to meet my needs, this is what I've done: 2) added a new function regsublen(), this performs a dry run of the regsub() function returning the length of the string needed to hold the output from regsub(). 3) changed regexec(prog,str) to regexec2(prog,str,eflags) with macro for regexec(). This is so I can have the flag REG_NOTBOL which signifies that the string passed to regexec[2]() is not actually the start of a line. 4) support for case-insignificant matching (with the flag REG_NOCASE) 5) split the definition of a compiled regexp from regexp.c into a new file regprog.h 6) created a new file regjade.c which uses the regexec() structure to match regexp against editor buffers in place. 7) Altered the regexp structure to allow storing of subexpressions as positions in a Jade buffer. Also altered calling conventions of regsub() and regsublen() to support this. 8) support \w, \W, \s, \S, \d, \D, \b, \B, *?, +?, ?? syntax (as in Perl) And probably some other things as well. Obviously all errors are my responsibility. The original README follows, John -- This is a nearly-public-domain reimplementation of the V8 regexp(3) package. It gives C programs the ability to use egrep-style regular expressions, and does it in a much cleaner fashion than the analogous routines in SysV. Copyright (c) 1986 by University of Toronto. Written by Henry Spencer. Not derived from licensed software. Permission is granted to anyone to use this software for any purpose on any computer system, and to redistribute it freely, subject to the following restrictions: 1. The author is not responsible for the consequences of use of this software, no matter how awful, even if they arise from defects in it. 2. The origin of this software must not be misrepresented, either by explicit claim or by omission. 3. Altered versions must be plainly marked as such, and must not be misrepresented as being the original software. Barring a couple of small items in the BUGS list, this implementation is believed 100% compatible with V8. It should even be binary-compatible, sort of, since the only fields in a "struct regexp" that other people have any business touching are declared in exactly the same way at the same location in the struct (the beginning). This implementation is *NOT* AT&T/Bell code, and is not derived from licensed software. Even though U of T is a V8 licensee. This software is based on a V8 manual page sent to me by Dennis Ritchie (the manual page enclosed here is a complete rewrite and hence is not covered by AT&T copyright). The software was nearly complete at the time of arrival of our V8 tape. I haven't even looked at V8 yet, although a friend elsewhere at U of T has been kind enough to run a few test programs using the V8 regexp(3) to resolve a few fine points. I admit to some familiarity with regular-expression implementations of the past, but the only one that this code traces any ancestry to is the one published in Kernighan & Plauger (from which this one draws ideas but not code). Simplistically: put this stuff into a source directory, copy regexp.h into /usr/include, inspect Makefile for compilation options that need changing to suit your local environment, and then do "make r". This compiles the regexp(3) functions, compiles a test program, and runs a large set of regression tests. If there are no complaints, then put regexp.o, regsub.o, and regerror.o into your C library, and regexp.3 into your manual-pages directory. Note that if you don't put regexp.h into /usr/include *before* compiling, you'll have to add "-I." to CFLAGS before compiling. The files are: Makefile instructions to make everything regexp.3 manual page regexp.h header file, for /usr/include regexp.c source for regcomp() and regexec() regsub.c source for regsub() regerror.c source for default regerror() regmagic.h internal header file try.c source for test program timer.c source for timing program tests test list for try and timer This implementation uses nondeterministic automata rather than the deterministic ones found in some other implementations, which makes it simpler, smaller, and faster at compiling regular expressions, but slower at executing them. In theory, anyway. This implementation does employ some special-case optimizations to make the simpler cases (which do make up the bulk of regular expressions actually used) run quickly. In general, if you want blazing speed you're in the wrong place. Replacing the insides of egrep with this stuff is probably a mistake; if you want your own egrep you're going to have to do a lot more work. But if you want to use regular expressions a little bit in something else, you're in luck. Note that many existing text editors use nondeterministic regular-expression implementations, so you're in good company. This stuff should be pretty portable, given appropriate option settings. If your chars have less than 8 bits, you're going to have to change the internal representation of the automaton, although knowledge of the details of this is fairly localized. There are no "reserved" char values except for NUL, and no special significance is attached to the top bit of chars. The string(3) functions are used a fair bit, on the grounds that they are probably faster than coding the operations in line. Some attempts at code tuning have been made, but this is invariably a bit machine-specific. librep-0.90.2/src/Makefile.in0000644000175200017520000001410311245011153014711 0ustar chrischris# Makefile.in -- input for the src directory's Makefile # Copyright (C) 1998 John Harper # $Id: Makefile.in,v 1.79 2003/12/06 18:23:31 jsh Exp $ # # This file is part of Jade. # # Jade is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # Jade is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Jade; see the file COPYING. If not, write to # the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. top_builddir=.. VPATH=@srcdir@:@top_srcdir@ COMMON_SRCS = continuations.c datums.c debug-buffer.c files.c find.c \ fluids.c gh.c lisp.c lispcmds.c lispmach.c macros.c main.c \ message.c misc.c numbers.c origin.c regexp.c regsub.c \ streams.c structures.c symbols.c tuples.c values.c weak-refs.c UNIX_SRCS = unix_dl.c unix_files.c unix_main.c unix_processes.c INSTALL_HDRS = rep.h rep_lisp.h rep_regexp.h rep_subrs.h rep_gh.h SRCS = $(COMMON_SRCS) $(UNIX_SRCS) OBJS = $(SRCS:.c=.lo) SDBM_SRCS = sdbm.c sdbm_pair.c sdbm_hash.c SDBM_OBJS = $(SDBM_SRCS:.c=.o) SDBM_LOBJS = $(SDBM_SRCS:.c=.lo) DL_SRCS = repsdbm.c timers.c gettext.c readline.c tables.c repgdbm.c \ record-profile.c safemach.c sockets.c md5.c ffi.c utf8.c DL_OBJS = sdbm.la timers.la gettext.la readline.la tables.la gdbm.la \ record-profile.la safe-interpreter.la sockets.la md5.la ffi.la \ utf8.la DL_DSTS = rep/io/db/sdbm.la rep/io/timers.la rep/i18n/gettext.la \ rep/io/readline.la rep/data/tables.la rep/io/db/gdbm.la \ rep/lang/record-profile.la rep/vm/safe-interpreter.la \ rep/io/sockets.la rep/util/md5.la rep/ffi.la rep/util/utf8.la DL_DIRS = rep rep/io rep/io/db rep/i18n rep/data rep/lang rep/vm rep/util REP_SRCS = rep.c REP_OBJS = $(REP_SRCS:.c=.o) INTL_OBJS_yes=../intl/*.lo INTL_OBJS_no= INTL_OBJS=$(INTL_OBJS_@USE_INCLUDED_LIBINTL@) all : librep.la $(DL_OBJS) check-dl rep rep-config rep-remote rep-xgettext .libexec librep.la : $(OBJS) $(LIBOBJS) $(ALLOCA) $(LIBTOOL) --mode=link --tag=CC $(CC) $(LDFLAGS) \ -version-info $(libversion) -export-symbols $(srcdir)/librep.sym \ -o $@ $^ -rpath $(libdir) $(LIBS) $(GMP_LIBS) rep : $(REP_OBJS) $(EXTRA_LIBOBJS) librep.la $(LIBTOOL) --mode=link --tag=CC $(CC) -export-dynamic $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) -o $@ \ $(REP_OBJS) librep.la $(EXTRA_LIBOBJS) $(LIBS) $(GMP_LIBS) srep : $(REP_OBJS) $(EXTRA_LIBOBJS) librep.la $(LIBTOOL) --mode=link --tag=CC $(CC) -static -export-dynamic $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) -o $@ \ $(REP_OBJS) librep.la $(EXTRA_LIBOBJS) $(LIBS) $(GMP_LIBS) rep-remote : rep-remote.c rep-xgettext : rep-xgettext.jl rep .libexec $(COMPILE_ENV) $(rep_prog) --batch -l rep.vm.compiler \ -f compile-batch $< \ && mv $/dev/null; then \ echo; echo "** Error: $$f has no associated shared library;"; \ deps=`grep '^dependency_libs=' $$f \ | sed -e "s/.*='\(.*\)'.*/\1/" \ | sed -e "s/-l//g"`; \ echo "** You may be missing a shared library from: $$deps"; echo; \ exit 1; \ fi; \ done install : all installdirs $(LIBTOOL) --mode=install $(INSTALL_PROGRAM) librep.la $(DESTDIR)${libdir} $(LIBTOOL) -n --finish $(DESTDIR)${libdir} $(LIBTOOL) --mode=install $(INSTALL_PROGRAM) -m 755 rep $(DESTDIR)${bindir} $(LIBTOOL) --mode=install $(INSTALL_PROGRAM) -m 755 repdoc $(DESTDIR)${bindir} $(INSTALL_SCRIPT) -m 755 rep-config $(DESTDIR)${bindir} $(INSTALL_SCRIPT) -m 755 rep-xgettext $(DESTDIR)${bindir} $(INSTALL_PROGRAM) -m 755 rep-remote $(DESTDIR)${bindir} $(foreach x,$(DL_DSTS),\ $(LIBTOOL) --mode=install $(INSTALL_PROGRAM) \ $(notdir $(x)) $(DESTDIR)$(repexecdir)/$(dir $(x));) printf "\nrep_open_globally=yes\n" \ >>$(DESTDIR)${repexecdir}/rep/i18n/gettext.la for i in $(INSTALL_HDRS); do \ $(INSTALL_DATA) $(srcdir)/$$i $(DESTDIR)$(includedir); \ done $(INSTALL_DATA) rep_config.h $(DESTDIR)$(repcommonexecdir) $(SHELL) $(top_srcdir)/install-aliases -c . $(DESTDIR)$(repexecdir) installdirs : mkinstalldirs $(SHELL) $< $(DESTDIR)$(libdir) $(DESTDIR)$(bindir) \ $(foreach x,$(DL_DIRS),$(DESTDIR)$(repexecdir)/$(x)) \ $(DESTDIR)$(includedir) uninstall : $(LIBTOOL) rm $(DESTDIR)${libdir}/librep.la $(LIBTOOL) rm $(DESTDIR)${bindir}/rep $(LIBTOOL) rm $(DESTDIR)${bindir}/repdoc rm -f $(DESTDIR)${bindir}/rep-config rm -f $(DESTDIR)${bindir}/rep-xgettext rm -f $(DESTDIR)${bindir}/rep-remote for dl in $(DL_DSTS); do \ $(LIBTOOL) rm $(DESTDIR)${repexecdir}/$$dl; \ done for i in $(INSTALL_HDRS); do \ rm $(DESTDIR)$(includedir)/$$i; \ done rep-config : rep-config.sh Makefile $(SHELL) $< "${prefix}" "${libdir}" "${version}" \ "${LDFLAGS} ${LIBS} ${GMP_LIBS}" "${repcommonexecdir}" \ "${repdir}/site-lisp" >$@ chmod +x $@ repdoc : repdoc.o $(LIBTOOL) --mode=link --tag=CC $(CC) $(LDFLAGS) -o $@ $^ $(GDBM_LIBS) sdbm.la : $(SDBM_LOBJS) repsdbm.lo $(rep_DL_LD) $(LDFLAGS) -o $@ $^ gdbm.la : repgdbm.lo $(rep_DL_LD) $(LDFLAGS) -o $@ $^ $(GDBM_LIBS) gettext.la : gettext.lo $(rep_DL_LD) $(LDFLAGS) -o $@ $^ $(INTL_OBJS) readline.la : readline.lo $(rep_DL_LD) $(LDFLAGS) -o $@ $^ $(READLINE_LIBS) safe-interpreter.la : safemach.lo $(rep_DL_LD) $(LDFLAGS) -o $@ $^ sockets.la : sockets.lo $(rep_DL_LD) $(LDFLAGS) -o $@ $^ md5.la : md5.lo rep-md5.lo $(rep_DL_LD) $(LDFLAGS) -o $@ $^ utf8.la : utf8.lo $(rep_DL_LD) $(LDFLAGS) -o $@ $^ ffi.la : ffi.lo $(rep_DL_LD) $(LDFLAGS) -o $@ $^ $(LIBFFI_LIBS) .libexec : $(DL_OBJS) $(SHELL) $(srcdir)/fake-libexec clean : rm -f *~ *.o *.lo *.la build.h rm -f repdoc core rep rep-remote srep distclean : clean rm -f .*.d Makefile rep_config.h dump.out dumped.s rep-config rm -rf .libs .libexec realclean : distclean check : -include $(SRCS:%.c=.%.d) $(DL_SRCS:%.c=.%.d) $(REP_SRCS:%.c=.%.d) librep-0.90.2/intl/xopen-msg.sed0000644000175200017520000000537611245011152015450 0ustar chrischris# po2msg.sed - Convert Uniforum style .po file to X/Open style .msg file # Copyright (C) 1995 Free Software Foundation, Inc. # Ulrich Drepper , 1995. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # # The first directive in the .msg should be the definition of the # message set number. We use always set number 1. # 1 { i\ $set 1 # Automatically created by po2msg.sed h s/.*/0/ x } # # We copy all comments into the .msg file. Perhaps they can help. # /^#/ s/^#[ ]*/$ /p # # We copy the original message as a comment into the .msg file. # /^msgid/ { # Does not work now # /"$/! { # s/\\$// # s/$/ ... (more lines following)"/ # } s/^msgid[ ]*"\(.*\)"$/$ Original Message: \1/ p } # # The .msg file contains, other then the .po file, only the translations # but each given a unique ID. Starting from 1 and incrementing by 1 for # each message we assign them to the messages. # It is important that the .po file used to generate the cat-id-tbl.c file # (with po-to-tbl) is the same as the one used here. (At least the order # of declarations must not be changed.) # /^msgstr/ { s/msgstr[ ]*"\(.*\)"/\1/ x # The following nice solution is by # Bruno td # Increment a decimal number in pattern space. # First hide trailing `9' digits. :d s/9\(_*\)$/_\1/ td # Assure at least one digit is available. s/^\(_*\)$/0\1/ # Increment the last digit. s/8\(_*\)$/9\1/ s/7\(_*\)$/8\1/ s/6\(_*\)$/7\1/ s/5\(_*\)$/6\1/ s/4\(_*\)$/5\1/ s/3\(_*\)$/4\1/ s/2\(_*\)$/3\1/ s/1\(_*\)$/2\1/ s/0\(_*\)$/1\1/ # Convert the hidden `9' digits to `0's. s/_/0/g x # Bring the line in the format ` ' G s/^[^\n]*$/& / s/\(.*\)\n\([0-9]*\)/\2 \1/ # Clear flag from last substitution. tb # Append the next line. :b N # Look whether second part is a continuation line. s/\(.*\n\)"\(.*\)"/\1\2/ # Yes, then branch. ta P D # Note that `D' includes a jump to the start!! # We found a continuation line. But before printing insert '\'. :a s/\(.*\)\(\n.*\)/\1\\\2/ P # We cannot use the sed command `D' here s/.*\n\(.*\)/\1/ tb } d librep-0.90.2/intl/textdomain.c0000644000175200017520000000630111245011152015343 0ustar chrischris/* Implementation of the textdomain(3) function. Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. Written by Ulrich Drepper , 1995. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #if defined STDC_HEADERS || defined _LIBC # include #endif #if defined STDC_HEADERS || defined HAVE_STRING_H || defined _LIBC # include #else # include # ifndef memcpy # define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) # endif #endif #ifdef _LIBC # include #else # include "libgettext.h" #endif /* @@ end of prolog @@ */ /* Name of the default text domain. */ extern const char _nl_default_default_domain[]; /* Default text domain in which entries for gettext(3) are to be found. */ extern const char *_nl_current_default_domain; /* Names for the libintl functions are a problem. They must not clash with existing names and they should follow ANSI C. But this source code is also used in GNU C Library where the names have a __ prefix. So we have to make a difference here. */ #ifdef _LIBC # define TEXTDOMAIN __textdomain # ifndef strdup # define strdup(str) __strdup (str) # endif #else # define TEXTDOMAIN textdomain__ #endif /* Set the current default message catalog to DOMAINNAME. If DOMAINNAME is null, return the current default. If DOMAINNAME is "", reset to the default of "messages". */ char * TEXTDOMAIN (domainname) const char *domainname; { char *old; /* A NULL pointer requests the current setting. */ if (domainname == NULL) return (char *) _nl_current_default_domain; old = (char *) _nl_current_default_domain; /* If domain name is the null string set to default domain "messages". */ if (domainname[0] == '\0' || strcmp (domainname, _nl_default_default_domain) == 0) _nl_current_default_domain = _nl_default_default_domain; else { /* If the following malloc fails `_nl_current_default_domain' will be NULL. This value will be returned and so signals we are out of core. */ #if defined _LIBC || defined HAVE_STRDUP _nl_current_default_domain = strdup (domainname); #else size_t len = strlen (domainname) + 1; char *cp = (char *) malloc (len); if (cp != NULL) memcpy (cp, domainname, len); _nl_current_default_domain = cp; #endif } if (old != _nl_default_default_domain) free (old); return (char *) _nl_current_default_domain; } #ifdef _LIBC /* Alias for function name in GNU C Library. */ weak_alias (__textdomain, textdomain); #endif librep-0.90.2/intl/po2tbl.sed.in0000644000175200017520000000456511245011152015341 0ustar chrischris# po2tbl.sed - Convert Uniforum style .po file to lookup table for catgets # Copyright (C) 1995 Free Software Foundation, Inc. # Ulrich Drepper , 1995. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # 1 { i\ /* Automatically generated by po2tbl.sed from @PACKAGE NAME@.pot. */\ \ #if HAVE_CONFIG_H\ # include \ #endif\ \ #include "libgettext.h"\ \ const struct _msg_ent _msg_tbl[] = { h s/.*/0/ x } # # Write msgid entries in C array form. # /^msgid/ { s/msgid[ ]*\(".*"\)/ {\1/ tb # Append the next line :b N # Look whether second part is continuation line. s/\(.*\)"\(\n\)"\(.*"\)/\1\2\3/ # Yes, then branch. ta # Because we assume that the input file correctly formed the line # just read cannot be again be a msgid line. So it's safe to ignore # it. s/\(.*\)\n.*/\1/ bc # We found a continuation line. But before printing insert '\'. :a s/\(.*\)\(\n.*\)/\1\\\2/ P # We cannot use D here. s/.*\n\(.*\)/\1/ # Some buggy seds do not clear the `successful substitution since last ``t''' # flag on `N', so we do a `t' here to clear it. tb # Not reached :c x # The following nice solution is by # Bruno td # Increment a decimal number in pattern space. # First hide trailing `9' digits. :d s/9\(_*\)$/_\1/ td # Assure at least one digit is available. s/^\(_*\)$/0\1/ # Increment the last digit. s/8\(_*\)$/9\1/ s/7\(_*\)$/8\1/ s/6\(_*\)$/7\1/ s/5\(_*\)$/6\1/ s/4\(_*\)$/5\1/ s/3\(_*\)$/4\1/ s/2\(_*\)$/3\1/ s/1\(_*\)$/2\1/ s/0\(_*\)$/1\1/ # Convert the hidden `9' digits to `0's. s/_/0/g x G s/\(.*\)\n\([0-9]*\)/\1, \2},/ s/\(.*\)"$/\1/ p } # # Last line. # $ { i\ };\ g s/0*\(.*\)/int _msg_tbl_length = \1;/p } d librep-0.90.2/intl/localealias.c0000644000175200017520000002355411245011152015451 0ustar chrischris/* Handle aliases for locale names. Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. Written by Ulrich Drepper , 1995. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #include #include #include #ifdef __GNUC__ # define alloca __builtin_alloca # define HAVE_ALLOCA 1 #else # if defined HAVE_ALLOCA_H || defined _LIBC # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca char *alloca (); # endif # endif # endif #endif #if defined STDC_HEADERS || defined _LIBC # include #else char *getenv (); # ifdef HAVE_MALLOC_H # include # else void free (); # endif #endif #if defined HAVE_STRING_H || defined _LIBC # ifndef _GNU_SOURCE # define _GNU_SOURCE 1 # endif # include #else # include # ifndef memcpy # define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) # endif #endif #if !HAVE_STRCHR && !defined _LIBC # ifndef strchr # define strchr index # endif #endif #include "gettext.h" #include "gettextP.h" /* @@ end of prolog @@ */ #ifdef _LIBC /* Rename the non ANSI C functions. This is required by the standard because some ANSI C functions will require linking with this object file and the name space must not be polluted. */ # define strcasecmp __strcasecmp # define mempcpy __mempcpy # define HAVE_MEMPCPY 1 /* We need locking here since we can be called from different places. */ # include __libc_lock_define_initialized (static, lock); #endif /* For those loosing systems which don't have `alloca' we have to add some additional code emulating it. */ #ifdef HAVE_ALLOCA /* Nothing has to be done. */ # define ADD_BLOCK(list, address) /* nothing */ # define FREE_BLOCKS(list) /* nothing */ #else struct block_list { void *address; struct block_list *next; }; # define ADD_BLOCK(list, addr) \ do { \ struct block_list *newp = (struct block_list *) malloc (sizeof (*newp)); \ /* If we cannot get a free block we cannot add the new element to \ the list. */ \ if (newp != NULL) { \ newp->address = (addr); \ newp->next = (list); \ (list) = newp; \ } \ } while (0) # define FREE_BLOCKS(list) \ do { \ while (list != NULL) { \ struct block_list *old = list; \ list = list->next; \ free (old); \ } \ } while (0) # undef alloca # define alloca(size) (malloc (size)) #endif /* have alloca */ struct alias_map { const char *alias; const char *value; }; static char *string_space = NULL; static size_t string_space_act = 0; static size_t string_space_max = 0; static struct alias_map *map; static size_t nmap = 0; static size_t maxmap = 0; /* Prototypes for local functions. */ static size_t read_alias_file PARAMS ((const char *fname, int fname_len)) internal_function; static void extend_alias_table PARAMS ((void)); static int alias_compare PARAMS ((const struct alias_map *map1, const struct alias_map *map2)); const char * _nl_expand_alias (name) const char *name; { static const char *locale_alias_path = LOCALE_ALIAS_PATH; struct alias_map *retval; const char *result = NULL; size_t added; #ifdef _LIBC __libc_lock_lock (lock); #endif do { struct alias_map item; item.alias = name; if (nmap > 0) retval = (struct alias_map *) bsearch (&item, map, nmap, sizeof (struct alias_map), (int (*) PARAMS ((const void *, const void *)) ) alias_compare); else retval = NULL; /* We really found an alias. Return the value. */ if (retval != NULL) { result = retval->value; break; } /* Perhaps we can find another alias file. */ added = 0; while (added == 0 && locale_alias_path[0] != '\0') { const char *start; while (locale_alias_path[0] == ':') ++locale_alias_path; start = locale_alias_path; while (locale_alias_path[0] != '\0' && locale_alias_path[0] != ':') ++locale_alias_path; if (start < locale_alias_path) added = read_alias_file (start, locale_alias_path - start); } } while (added != 0); #ifdef _LIBC __libc_lock_unlock (lock); #endif return result; } static size_t internal_function read_alias_file (fname, fname_len) const char *fname; int fname_len; { #ifndef HAVE_ALLOCA struct block_list *block_list = NULL; #endif FILE *fp; char *full_fname; size_t added; static const char aliasfile[] = "/locale.alias"; full_fname = (char *) alloca (fname_len + sizeof aliasfile); ADD_BLOCK (block_list, full_fname); #ifdef HAVE_MEMPCPY mempcpy (mempcpy (full_fname, fname, fname_len), aliasfile, sizeof aliasfile); #else memcpy (full_fname, fname, fname_len); memcpy (&full_fname[fname_len], aliasfile, sizeof aliasfile); #endif fp = fopen (full_fname, "r"); if (fp == NULL) { FREE_BLOCKS (block_list); return 0; } added = 0; while (!feof (fp)) { /* It is a reasonable approach to use a fix buffer here because a) we are only interested in the first two fields b) these fields must be usable as file names and so must not be that long */ unsigned char buf[BUFSIZ]; unsigned char *alias; unsigned char *value; unsigned char *cp; if (fgets (buf, sizeof buf, fp) == NULL) /* EOF reached. */ break; /* Possibly not the whole line fits into the buffer. Ignore the rest of the line. */ if (strchr (buf, '\n') == NULL) { char altbuf[BUFSIZ]; do if (fgets (altbuf, sizeof altbuf, fp) == NULL) /* Make sure the inner loop will be left. The outer loop will exit at the `feof' test. */ break; while (strchr (altbuf, '\n') == NULL); } cp = buf; /* Ignore leading white space. */ while (isspace (cp[0])) ++cp; /* A leading '#' signals a comment line. */ if (cp[0] != '\0' && cp[0] != '#') { alias = cp++; while (cp[0] != '\0' && !isspace (cp[0])) ++cp; /* Terminate alias name. */ if (cp[0] != '\0') *cp++ = '\0'; /* Now look for the beginning of the value. */ while (isspace (cp[0])) ++cp; if (cp[0] != '\0') { size_t alias_len; size_t value_len; value = cp++; while (cp[0] != '\0' && !isspace (cp[0])) ++cp; /* Terminate value. */ if (cp[0] == '\n') { /* This has to be done to make the following test for the end of line possible. We are looking for the terminating '\n' which do not overwrite here. */ *cp++ = '\0'; *cp = '\n'; } else if (cp[0] != '\0') *cp++ = '\0'; if (nmap >= maxmap) extend_alias_table (); alias_len = strlen (alias) + 1; value_len = strlen (value) + 1; if (string_space_act + alias_len + value_len > string_space_max) { /* Increase size of memory pool. */ size_t new_size = (string_space_max + (alias_len + value_len > 1024 ? alias_len + value_len : 1024)); char *new_pool = (char *) realloc (string_space, new_size); if (new_pool == NULL) { FREE_BLOCKS (block_list); return added; } string_space = new_pool; string_space_max = new_size; } map[nmap].alias = memcpy (&string_space[string_space_act], alias, alias_len); string_space_act += alias_len; map[nmap].value = memcpy (&string_space[string_space_act], value, value_len); string_space_act += value_len; ++nmap; ++added; } } } /* Should we test for ferror()? I think we have to silently ignore errors. --drepper */ fclose (fp); if (added > 0) qsort (map, nmap, sizeof (struct alias_map), (int (*) PARAMS ((const void *, const void *))) alias_compare); FREE_BLOCKS (block_list); return added; } static void extend_alias_table () { size_t new_size; struct alias_map *new_map; new_size = maxmap == 0 ? 100 : 2 * maxmap; new_map = (struct alias_map *) realloc (map, (new_size * sizeof (struct alias_map))); if (new_map == NULL) /* Simply don't extend: we don't have any more core. */ return; map = new_map; maxmap = new_size; } #ifdef _LIBC static void __attribute__ ((unused)) free_mem (void) { if (string_space != NULL) free (string_space); if (map != NULL) free (map); } text_set_element (__libc_subfreeres, free_mem); #endif static int alias_compare (map1, map2) const struct alias_map *map1; const struct alias_map *map2; { #if defined _LIBC || defined HAVE_STRCASECMP return strcasecmp (map1->alias, map2->alias); #else const unsigned char *p1 = (const unsigned char *) map1->alias; const unsigned char *p2 = (const unsigned char *) map2->alias; unsigned char c1, c2; if (p1 == p2) return 0; do { /* I know this seems to be odd but the tolower() function in some systems libc cannot handle nonalpha characters. */ c1 = isupper (*p1) ? tolower (*p1) : *p1; c2 = isupper (*p2) ? tolower (*p2) : *p2; if (c1 == '\0') break; ++p1; ++p2; } while (c1 == c2); return c1 - c2; #endif } librep-0.90.2/intl/loadmsgcat.c0000644000175200017520000001374511245011152015317 0ustar chrischris/* Load needed message catalogs. Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #include #include #include #if defined STDC_HEADERS || defined _LIBC # include #endif #if defined HAVE_UNISTD_H || defined _LIBC # include #endif #if (defined HAVE_MMAP && defined HAVE_MUNMAP) || defined _LIBC # include #endif #include "gettext.h" #include "gettextP.h" /* @@ end of prolog @@ */ #ifdef _LIBC /* Rename the non ISO C functions. This is required by the standard because some ISO C functions will require linking with this object file and the name space must not be polluted. */ # define open __open # define close __close # define read __read # define mmap __mmap # define munmap __munmap #endif /* We need a sign, whether a new catalog was loaded, which can be associated with all translations. This is important if the translations are cached by one of GCC's features. */ int _nl_msg_cat_cntr = 0; /* Load the message catalogs specified by FILENAME. If it is no valid message catalog do nothing. */ void internal_function _nl_load_domain (domain_file) struct loaded_l10nfile *domain_file; { int fd; size_t size; struct stat st; struct mo_file_header *data = (struct mo_file_header *) -1; #if (defined HAVE_MMAP && defined HAVE_MUNMAP && !defined DISALLOW_MMAP) \ || defined _LIBC int use_mmap = 0; #endif struct loaded_domain *domain; domain_file->decided = 1; domain_file->data = NULL; /* If the record does not represent a valid locale the FILENAME might be NULL. This can happen when according to the given specification the locale file name is different for XPG and CEN syntax. */ if (domain_file->filename == NULL) return; /* Try to open the addressed file. */ fd = open (domain_file->filename, O_RDONLY); if (fd == -1) return; /* We must know about the size of the file. */ if (fstat (fd, &st) != 0 || (size = (size_t) st.st_size) != st.st_size || size < sizeof (struct mo_file_header)) { /* Something went wrong. */ close (fd); return; } #if (defined HAVE_MMAP && defined HAVE_MUNMAP && !defined DISALLOW_MMAP) \ || defined _LIBC /* Now we are ready to load the file. If mmap() is available we try this first. If not available or it failed we try to load it. */ data = (struct mo_file_header *) mmap (NULL, size, PROT_READ, MAP_PRIVATE, fd, 0); if (data != (struct mo_file_header *) -1) { /* mmap() call was successful. */ close (fd); use_mmap = 1; } #endif /* If the data is not yet available (i.e. mmap'ed) we try to load it manually. */ if (data == (struct mo_file_header *) -1) { size_t to_read; char *read_ptr; data = (struct mo_file_header *) malloc (size); if (data == NULL) return; to_read = size; read_ptr = (char *) data; do { long int nb = (long int) read (fd, read_ptr, to_read); if (nb == -1) { close (fd); return; } read_ptr += nb; to_read -= nb; } while (to_read > 0); close (fd); } /* Using the magic number we can test whether it really is a message catalog file. */ if (data->magic != _MAGIC && data->magic != _MAGIC_SWAPPED) { /* The magic number is wrong: not a message catalog file. */ #if (defined HAVE_MMAP && defined HAVE_MUNMAP && !defined DISALLOW_MMAP) \ || defined _LIBC if (use_mmap) munmap ((caddr_t) data, size); else #endif free (data); return; } domain_file->data = (struct loaded_domain *) malloc (sizeof (struct loaded_domain)); if (domain_file->data == NULL) return; domain = (struct loaded_domain *) domain_file->data; domain->data = (char *) data; #if (defined HAVE_MMAP && defined HAVE_MUNMAP && !defined DISALLOW_MMAP) \ || defined _LIBC domain->use_mmap = use_mmap; #endif domain->mmap_size = size; domain->must_swap = data->magic != _MAGIC; /* Fill in the information about the available tables. */ switch (W (domain->must_swap, data->revision)) { case 0: domain->nstrings = W (domain->must_swap, data->nstrings); domain->orig_tab = (struct string_desc *) ((char *) data + W (domain->must_swap, data->orig_tab_offset)); domain->trans_tab = (struct string_desc *) ((char *) data + W (domain->must_swap, data->trans_tab_offset)); domain->hash_size = W (domain->must_swap, data->hash_tab_size); domain->hash_tab = (nls_uint32 *) ((char *) data + W (domain->must_swap, data->hash_tab_offset)); break; default: /* This is an illegal revision. */ #if (defined HAVE_MMAP && defined HAVE_MUNMAP && !defined DISALLOW_MMAP) \ || defined _LIBC if (use_mmap) munmap ((caddr_t) data, size); else #endif free (data); free (domain); domain_file->data = NULL; return; } /* Show that one domain is changed. This might make some cached translations invalid. */ ++_nl_msg_cat_cntr; } #ifdef _LIBC void internal_function _nl_unload_domain (domain) struct loaded_domain *domain; { if (domain->use_mmap) munmap ((caddr_t) domain->data, domain->mmap_size); else free ((void *) domain->data); free (domain); } #endif librep-0.90.2/intl/loadinfo.h0000644000175200017520000000455511245011152015000 0ustar chrischris/* Copyright (C) 1996, 1997 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Ulrich Drepper , 1996. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef PARAMS # if __STDC__ # define PARAMS(args) args # else # define PARAMS(args) () # endif #endif /* Encoding of locale name parts. */ #define CEN_REVISION 1 #define CEN_SPONSOR 2 #define CEN_SPECIAL 4 #define XPG_NORM_CODESET 8 #define XPG_CODESET 16 #define TERRITORY 32 #define CEN_AUDIENCE 64 #define XPG_MODIFIER 128 #define CEN_SPECIFIC (CEN_REVISION|CEN_SPONSOR|CEN_SPECIAL|CEN_AUDIENCE) #define XPG_SPECIFIC (XPG_CODESET|XPG_NORM_CODESET|XPG_MODIFIER) struct loaded_l10nfile { const char *filename; int decided; const void *data; struct loaded_l10nfile *next; struct loaded_l10nfile *successor[1]; }; extern const char *_nl_normalize_codeset PARAMS ((const unsigned char *codeset, size_t name_len)); extern struct loaded_l10nfile * _nl_make_l10nflist PARAMS ((struct loaded_l10nfile **l10nfile_list, const char *dirlist, size_t dirlist_len, int mask, const char *language, const char *territory, const char *codeset, const char *normalized_codeset, const char *modifier, const char *special, const char *sponsor, const char *revision, const char *filename, int do_allocate)); extern const char *_nl_expand_alias PARAMS ((const char *name)); extern int _nl_explode_name PARAMS ((char *name, const char **language, const char **modifier, const char **territory, const char **codeset, const char **normalized_codeset, const char **special, const char **sponsor, const char **revision)); librep-0.90.2/intl/linux-msg.sed0000644000175200017520000000520511245011152015445 0ustar chrischris# po2msg.sed - Convert Uniforum style .po file to Linux style .msg file # Copyright (C) 1995 Free Software Foundation, Inc. # Ulrich Drepper , 1995. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # # The first directive in the .msg should be the definition of the # message set number. We use always set number 1. # 1 { i\ $set 1 # Automatically created by po2msg.sed h s/.*/0/ x } # # Mitch's old catalog format does not allow comments. # # We copy the original message as a comment into the .msg file. # /^msgid/ { s/msgid[ ]*"// # # This does not work now with the new format. # /"$/! { # s/\\$// # s/$/ ... (more lines following)"/ # } x # The following nice solution is by # Bruno td # Increment a decimal number in pattern space. # First hide trailing `9' digits. :d s/9\(_*\)$/_\1/ td # Assure at least one digit is available. s/^\(_*\)$/0\1/ # Increment the last digit. s/8\(_*\)$/9\1/ s/7\(_*\)$/8\1/ s/6\(_*\)$/7\1/ s/5\(_*\)$/6\1/ s/4\(_*\)$/5\1/ s/3\(_*\)$/4\1/ s/2\(_*\)$/3\1/ s/1\(_*\)$/2\1/ s/0\(_*\)$/1\1/ # Convert the hidden `9' digits to `0's. s/_/0/g x G s/\(.*\)"\n\([0-9]*\)/$ #\2 Original Message:(\1)/p } # # The .msg file contains, other then the .po file, only the translations # but each given a unique ID. Starting from 1 and incrementing by 1 for # each message we assign them to the messages. # It is important that the .po file used to generate the cat-id-tbl.c file # (with po-to-tbl) is the same as the one used here. (At least the order # of declarations must not be changed.) # /^msgstr/ { s/msgstr[ ]*"\(.*\)"/# \1/ # Clear substitution flag. tb # Append the next line. :b N # Look whether second part is continuation line. s/\(.*\n\)"\(.*\)"/\1\2/ # Yes, then branch. ta P D # Note that D includes a jump to the start!! # We found a continuation line. But before printing insert '\'. :a s/\(.*\)\(\n.*\)/\1\\\2/ P # We cannot use D here. s/.*\n\(.*\)/\1/ tb } d librep-0.90.2/intl/libgettext.h0000644000175200017520000001314511245011152015353 0ustar chrischris/* Message catalogs for internationalization. Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Because on some systems (e.g. Solaris) we sometimes have to include the systems libintl.h as well as this file we have more complex include protection above. But the systems header might perhaps also define _LIBINTL_H and therefore we have to protect the definition here. */ #if !defined _LIBINTL_H || !defined _LIBGETTEXT_H #ifndef _LIBINTL_H # define _LIBINTL_H 1 #endif #define _LIBGETTEXT_H 1 /* We define an additional symbol to signal that we use the GNU implementation of gettext. */ #define __USE_GNU_GETTEXT 1 #include #if HAVE_LOCALE_H # include #endif #ifdef __cplusplus extern "C" { #endif /* @@ end of prolog @@ */ #ifndef PARAMS # if __STDC__ || defined __cplusplus # define PARAMS(args) args # else # define PARAMS(args) () # endif #endif #ifndef NULL # if !defined __cplusplus || defined __GNUC__ # define NULL ((void *) 0) # else # define NULL (0) # endif #endif #if !HAVE_LC_MESSAGES /* This value determines the behaviour of the gettext() and dgettext() function. But some system does not have this defined. Define it to a default value. */ # define LC_MESSAGES (-1) #endif /* Declarations for gettext-using-catgets interface. Derived from Jim Meyering's libintl.h. */ struct _msg_ent { const char *_msg; int _msg_number; }; #if HAVE_CATGETS /* These two variables are defined in the automatically by po-to-tbl.sed generated file `cat-id-tbl.c'. */ extern const struct _msg_ent _msg_tbl[]; extern int _msg_tbl_length; #endif /* For automatical extraction of messages sometimes no real translation is needed. Instead the string itself is the result. */ #define gettext_noop(Str) (Str) /* Look up MSGID in the current default message catalog for the current LC_MESSAGES locale. If not found, returns MSGID itself (the default text). */ extern char *gettext PARAMS ((const char *__msgid)); extern char *gettext__ PARAMS ((const char *__msgid)); /* Look up MSGID in the DOMAINNAME message catalog for the current LC_MESSAGES locale. */ extern char *dgettext PARAMS ((const char *__domainname, const char *__msgid)); extern char *dgettext__ PARAMS ((const char *__domainname, const char *__msgid)); /* Look up MSGID in the DOMAINNAME message catalog for the current CATEGORY locale. */ extern char *dcgettext PARAMS ((const char *__domainname, const char *__msgid, int __category)); extern char *dcgettext__ PARAMS ((const char *__domainname, const char *__msgid, int __category)); /* Set the current default message catalog to DOMAINNAME. If DOMAINNAME is null, return the current default. If DOMAINNAME is "", reset to the default of "messages". */ extern char *textdomain PARAMS ((const char *__domainname)); extern char *textdomain__ PARAMS ((const char *__domainname)); /* Specify that the DOMAINNAME message catalog will be found in DIRNAME rather than in the system locale data base. */ extern char *bindtextdomain PARAMS ((const char *__domainname, const char *__dirname)); extern char *bindtextdomain__ PARAMS ((const char *__domainname, const char *__dirname)); #if ENABLE_NLS /* Solaris 2.3 has the gettext function but dcgettext is missing. So we omit this optimization for Solaris 2.3. BTW, Solaris 2.4 has dcgettext. */ # if !HAVE_CATGETS && (!HAVE_GETTEXT || HAVE_DCGETTEXT) # define gettext(Msgid) \ dgettext (NULL, Msgid) # define dgettext(Domainname, Msgid) \ dcgettext (Domainname, Msgid, LC_MESSAGES) # if defined __GNUC__ && __GNUC__ == 2 && __GNUC_MINOR__ >= 7 /* This global variable is defined in loadmsgcat.c. We need a sign, whether a new catalog was loaded, which can be associated with all translations. */ extern int _nl_msg_cat_cntr; # define dcgettext(Domainname, Msgid, Category) \ (__extension__ \ ({ \ char *__result; \ if (__builtin_constant_p (Msgid)) \ { \ static char *__translation__; \ static int __catalog_counter__; \ if (! __translation__ || __catalog_counter__ != _nl_msg_cat_cntr) \ { \ __translation__ = \ dcgettext__ (Domainname, Msgid, Category); \ __catalog_counter__ = _nl_msg_cat_cntr; \ } \ __result = __translation__; \ } \ else \ __result = dcgettext__ (Domainname, Msgid, Category); \ __result; \ })) # endif # endif #else # define gettext(Msgid) (Msgid) # define dgettext(Domainname, Msgid) (Msgid) # define dcgettext(Domainname, Msgid, Category) (Msgid) # define textdomain(Domainname) ((char *) Domainname) # define bindtextdomain(Domainname, Dirname) ((char *) Dirname) #endif /* @@ begin of epilog @@ */ #ifdef __cplusplus } #endif #endif librep-0.90.2/intl/l10nflist.c0000644000175200017520000002424411245011152015011 0ustar chrischris/* Handle list of needed message catalogs Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. Contributed by Ulrich Drepper , 1995. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #if defined HAVE_STRING_H || defined _LIBC # ifndef _GNU_SOURCE # define _GNU_SOURCE 1 # endif # include #else # include # ifndef memcpy # define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) # endif #endif #if !HAVE_STRCHR && !defined _LIBC # ifndef strchr # define strchr index # endif #endif #if defined _LIBC || defined HAVE_ARGZ_H # include #endif #include #include #if defined STDC_HEADERS || defined _LIBC # include #endif #include "loadinfo.h" /* On some strange systems still no definition of NULL is found. Sigh! */ #ifndef NULL # if defined __STDC__ && __STDC__ # define NULL ((void *) 0) # else # define NULL 0 # endif #endif /* @@ end of prolog @@ */ #ifdef _LIBC /* Rename the non ANSI C functions. This is required by the standard because some ANSI C functions will require linking with this object file and the name space must not be polluted. */ # ifndef stpcpy # define stpcpy(dest, src) __stpcpy(dest, src) # endif #else # ifndef HAVE_STPCPY static char *stpcpy PARAMS ((char *dest, const char *src)); # endif #endif /* Define function which are usually not available. */ #if !defined _LIBC && !defined HAVE___ARGZ_COUNT /* Returns the number of strings in ARGZ. */ static size_t argz_count__ PARAMS ((const char *argz, size_t len)); static size_t argz_count__ (argz, len) const char *argz; size_t len; { size_t count = 0; while (len > 0) { size_t part_len = strlen (argz); argz += part_len + 1; len -= part_len + 1; count++; } return count; } # undef __argz_count # define __argz_count(argz, len) argz_count__ (argz, len) #endif /* !_LIBC && !HAVE___ARGZ_COUNT */ #if !defined _LIBC && !defined HAVE___ARGZ_STRINGIFY /* Make '\0' separated arg vector ARGZ printable by converting all the '\0's except the last into the character SEP. */ static void argz_stringify__ PARAMS ((char *argz, size_t len, int sep)); static void argz_stringify__ (argz, len, sep) char *argz; size_t len; int sep; { while (len > 0) { size_t part_len = strlen (argz); argz += part_len; len -= part_len + 1; if (len > 0) *argz++ = sep; } } # undef __argz_stringify # define __argz_stringify(argz, len, sep) argz_stringify__ (argz, len, sep) #endif /* !_LIBC && !HAVE___ARGZ_STRINGIFY */ #if !defined _LIBC && !defined HAVE___ARGZ_NEXT static char *argz_next__ PARAMS ((char *argz, size_t argz_len, const char *entry)); static char * argz_next__ (argz, argz_len, entry) char *argz; size_t argz_len; const char *entry; { if (entry) { if (entry < argz + argz_len) entry = strchr (entry, '\0') + 1; return entry >= argz + argz_len ? NULL : (char *) entry; } else if (argz_len > 0) return argz; else return 0; } # undef __argz_next # define __argz_next(argz, len, entry) argz_next__ (argz, len, entry) #endif /* !_LIBC && !HAVE___ARGZ_NEXT */ /* Return number of bits set in X. */ static int pop PARAMS ((int x)); static inline int pop (x) int x; { /* We assume that no more than 16 bits are used. */ x = ((x & ~0x5555) >> 1) + (x & 0x5555); x = ((x & ~0x3333) >> 2) + (x & 0x3333); x = ((x >> 4) + x) & 0x0f0f; x = ((x >> 8) + x) & 0xff; return x; } struct loaded_l10nfile * _nl_make_l10nflist (l10nfile_list, dirlist, dirlist_len, mask, language, territory, codeset, normalized_codeset, modifier, special, sponsor, revision, filename, do_allocate) struct loaded_l10nfile **l10nfile_list; const char *dirlist; size_t dirlist_len; int mask; const char *language; const char *territory; const char *codeset; const char *normalized_codeset; const char *modifier; const char *special; const char *sponsor; const char *revision; const char *filename; int do_allocate; { char *abs_filename; struct loaded_l10nfile *last = NULL; struct loaded_l10nfile *retval; char *cp; size_t entries; int cnt; /* Allocate room for the full file name. */ abs_filename = (char *) malloc (dirlist_len + strlen (language) + ((mask & TERRITORY) != 0 ? strlen (territory) + 1 : 0) + ((mask & XPG_CODESET) != 0 ? strlen (codeset) + 1 : 0) + ((mask & XPG_NORM_CODESET) != 0 ? strlen (normalized_codeset) + 1 : 0) + (((mask & XPG_MODIFIER) != 0 || (mask & CEN_AUDIENCE) != 0) ? strlen (modifier) + 1 : 0) + ((mask & CEN_SPECIAL) != 0 ? strlen (special) + 1 : 0) + (((mask & CEN_SPONSOR) != 0 || (mask & CEN_REVISION) != 0) ? (1 + ((mask & CEN_SPONSOR) != 0 ? strlen (sponsor) + 1 : 0) + ((mask & CEN_REVISION) != 0 ? strlen (revision) + 1 : 0)) : 0) + 1 + strlen (filename) + 1); if (abs_filename == NULL) return NULL; retval = NULL; last = NULL; /* Construct file name. */ memcpy (abs_filename, dirlist, dirlist_len); __argz_stringify (abs_filename, dirlist_len, ':'); cp = abs_filename + (dirlist_len - 1); *cp++ = '/'; cp = stpcpy (cp, language); if ((mask & TERRITORY) != 0) { *cp++ = '_'; cp = stpcpy (cp, territory); } if ((mask & XPG_CODESET) != 0) { *cp++ = '.'; cp = stpcpy (cp, codeset); } if ((mask & XPG_NORM_CODESET) != 0) { *cp++ = '.'; cp = stpcpy (cp, normalized_codeset); } if ((mask & (XPG_MODIFIER | CEN_AUDIENCE)) != 0) { /* This component can be part of both syntaces but has different leading characters. For CEN we use `+', else `@'. */ *cp++ = (mask & CEN_AUDIENCE) != 0 ? '+' : '@'; cp = stpcpy (cp, modifier); } if ((mask & CEN_SPECIAL) != 0) { *cp++ = '+'; cp = stpcpy (cp, special); } if ((mask & (CEN_SPONSOR | CEN_REVISION)) != 0) { *cp++ = ','; if ((mask & CEN_SPONSOR) != 0) cp = stpcpy (cp, sponsor); if ((mask & CEN_REVISION) != 0) { *cp++ = '_'; cp = stpcpy (cp, revision); } } *cp++ = '/'; stpcpy (cp, filename); /* Look in list of already loaded domains whether it is already available. */ last = NULL; for (retval = *l10nfile_list; retval != NULL; retval = retval->next) if (retval->filename != NULL) { int compare = strcmp (retval->filename, abs_filename); if (compare == 0) /* We found it! */ break; if (compare < 0) { /* It's not in the list. */ retval = NULL; break; } last = retval; } if (retval != NULL || do_allocate == 0) { free (abs_filename); return retval; } retval = (struct loaded_l10nfile *) malloc (sizeof (*retval) + (__argz_count (dirlist, dirlist_len) * (1 << pop (mask)) * sizeof (struct loaded_l10nfile *))); if (retval == NULL) return NULL; retval->filename = abs_filename; retval->decided = (__argz_count (dirlist, dirlist_len) != 1 || ((mask & XPG_CODESET) != 0 && (mask & XPG_NORM_CODESET) != 0)); retval->data = NULL; if (last == NULL) { retval->next = *l10nfile_list; *l10nfile_list = retval; } else { retval->next = last->next; last->next = retval; } entries = 0; /* If the DIRLIST is a real list the RETVAL entry corresponds not to a real file. So we have to use the DIRLIST separation mechanism of the inner loop. */ cnt = __argz_count (dirlist, dirlist_len) == 1 ? mask - 1 : mask; for (; cnt >= 0; --cnt) if ((cnt & ~mask) == 0 && ((cnt & CEN_SPECIFIC) == 0 || (cnt & XPG_SPECIFIC) == 0) && ((cnt & XPG_CODESET) == 0 || (cnt & XPG_NORM_CODESET) == 0)) { /* Iterate over all elements of the DIRLIST. */ char *dir = NULL; while ((dir = __argz_next ((char *) dirlist, dirlist_len, dir)) != NULL) retval->successor[entries++] = _nl_make_l10nflist (l10nfile_list, dir, strlen (dir) + 1, cnt, language, territory, codeset, normalized_codeset, modifier, special, sponsor, revision, filename, 1); } retval->successor[entries] = NULL; return retval; } /* Normalize codeset name. There is no standard for the codeset names. Normalization allows the user to use any of the common names. */ const char * _nl_normalize_codeset (codeset, name_len) const unsigned char *codeset; size_t name_len; { int len = 0; int only_digit = 1; char *retval; char *wp; size_t cnt; for (cnt = 0; cnt < name_len; ++cnt) if (isalnum (codeset[cnt])) { ++len; if (isalpha (codeset[cnt])) only_digit = 0; } retval = (char *) malloc ((only_digit ? 3 : 0) + len + 1); if (retval != NULL) { if (only_digit) wp = stpcpy (retval, "iso"); else wp = retval; for (cnt = 0; cnt < name_len; ++cnt) if (isalpha (codeset[cnt])) *wp++ = tolower (codeset[cnt]); else if (isdigit (codeset[cnt])) *wp++ = codeset[cnt]; *wp = '\0'; } return (const char *) retval; } /* @@ begin of epilog @@ */ /* We don't want libintl.a to depend on any other library. So we avoid the non-standard function stpcpy. In GNU C Library this function is available, though. Also allow the symbol HAVE_STPCPY to be defined. */ #if !_LIBC && !HAVE_STPCPY static char * stpcpy (dest, src) char *dest; const char *src; { while ((*dest++ = *src++) != '\0') /* Do nothing. */ ; return dest - 1; } #endif librep-0.90.2/intl/intl-compat.c0000644000175200017520000000315611245011152015423 0ustar chrischris/* intl-compat.c - Stub functions to call gettext functions from GNU gettext Library. Copyright (C) 1995 Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #include "libgettext.h" /* @@ end of prolog @@ */ #undef gettext #undef dgettext #undef dcgettext #undef textdomain #undef bindtextdomain char * bindtextdomain (domainname, dirname) const char *domainname; const char *dirname; { return bindtextdomain__ (domainname, dirname); } char * dcgettext (domainname, msgid, category) const char *domainname; const char *msgid; int category; { return dcgettext__ (domainname, msgid, category); } char * dgettext (domainname, msgid) const char *domainname; const char *msgid; { return dgettext__ (domainname, msgid); } char * gettext (msgid) const char *msgid; { return gettext__ (msgid); } char * textdomain (domainname) const char *domainname; { return textdomain__ (domainname); } librep-0.90.2/intl/hash-string.h0000644000175200017520000000337311245011152015431 0ustar chrischris/* Implements a string hashing function. Copyright (C) 1995, 1997 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU Library General Public License along with the GNU C Library; see the file COPYING.LIB. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* @@ end of prolog @@ */ #ifndef PARAMS # if __STDC__ # define PARAMS(Args) Args # else # define PARAMS(Args) () # endif #endif /* We assume to have `unsigned long int' value with at least 32 bits. */ #define HASHWORDBITS 32 /* Defines the so called `hashpjw' function by P.J. Weinberger [see Aho/Sethi/Ullman, COMPILERS: Principles, Techniques and Tools, 1986, 1987 Bell Telephone Laboratories, Inc.] */ static unsigned long hash_string PARAMS ((const char *__str_param)); static inline unsigned long hash_string (str_param) const char *str_param; { unsigned long int hval, g; const char *str = str_param; /* Compute the hash value for the given string. */ hval = 0; while (*str != '\0') { hval <<= 4; hval += (unsigned long) *str++; g = hval & ((unsigned long) 0xf << (HASHWORDBITS - 4)); if (g != 0) { hval ^= g >> (HASHWORDBITS - 8); hval ^= g; } } return hval; } librep-0.90.2/intl/gettextP.h0000644000175200017520000000420611245011152015002 0ustar chrischris/* Header describing internals of gettext library Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. Written by Ulrich Drepper , 1995. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef _GETTEXTP_H #define _GETTEXTP_H #include "loadinfo.h" /* @@ end of prolog @@ */ #ifndef PARAMS # if __STDC__ # define PARAMS(args) args # else # define PARAMS(args) () # endif #endif #ifndef internal_function # define internal_function #endif #ifndef W # define W(flag, data) ((flag) ? SWAP (data) : (data)) #endif #ifdef _LIBC # include # define SWAP(i) bswap_32 (i) #else static nls_uint32 SWAP PARAMS ((nls_uint32 i)); static inline nls_uint32 SWAP (i) nls_uint32 i; { return (i << 24) | ((i & 0xff00) << 8) | ((i >> 8) & 0xff00) | (i >> 24); } #endif struct loaded_domain { const char *data; int use_mmap; size_t mmap_size; int must_swap; nls_uint32 nstrings; struct string_desc *orig_tab; struct string_desc *trans_tab; nls_uint32 hash_size; nls_uint32 *hash_tab; }; struct binding { struct binding *next; char *domainname; char *dirname; }; struct loaded_l10nfile *_nl_find_domain PARAMS ((const char *__dirname, char *__locale, const char *__domainname)) internal_function; void _nl_load_domain PARAMS ((struct loaded_l10nfile *__domain)) internal_function; void _nl_unload_domain PARAMS ((struct loaded_domain *__domain)) internal_function; /* @@ begin of epilog @@ */ #endif /* gettextP.h */ librep-0.90.2/intl/gettext.h0000644000175200017520000000620511245011152014663 0ustar chrischris/* Internal header for GNU gettext internationalization functions. Copyright (C) 1995, 1997 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU Library General Public License along with the GNU C Library; see the file COPYING.LIB. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef _GETTEXT_H #define _GETTEXT_H 1 #include #if HAVE_LIMITS_H || _LIBC # include #endif /* @@ end of prolog @@ */ /* The magic number of the GNU message catalog format. */ #define _MAGIC 0x950412de #define _MAGIC_SWAPPED 0xde120495 /* Revision number of the currently used .mo (binary) file format. */ #define MO_REVISION_NUMBER 0 /* The following contortions are an attempt to use the C preprocessor to determine an unsigned integral type that is 32 bits wide. An alternative approach is to use autoconf's AC_CHECK_SIZEOF macro, but doing that would require that the configure script compile and *run* the resulting executable. Locally running cross-compiled executables is usually not possible. */ #if __STDC__ # define UINT_MAX_32_BITS 4294967295U #else # define UINT_MAX_32_BITS 0xFFFFFFFF #endif /* If UINT_MAX isn't defined, assume it's a 32-bit type. This should be valid for all systems GNU cares about because that doesn't include 16-bit systems, and only modern systems (that certainly have ) have 64+-bit integral types. */ #ifndef UINT_MAX # define UINT_MAX UINT_MAX_32_BITS #endif #if UINT_MAX == UINT_MAX_32_BITS typedef unsigned nls_uint32; #else # if USHRT_MAX == UINT_MAX_32_BITS typedef unsigned short nls_uint32; # else # if ULONG_MAX == UINT_MAX_32_BITS typedef unsigned long nls_uint32; # else /* The following line is intended to throw an error. Using #error is not portable enough. */ "Cannot determine unsigned 32-bit data type." # endif # endif #endif /* Header for binary .mo file format. */ struct mo_file_header { /* The magic number. */ nls_uint32 magic; /* The revision number of the file format. */ nls_uint32 revision; /* The number of strings pairs. */ nls_uint32 nstrings; /* Offset of table with start offsets of original strings. */ nls_uint32 orig_tab_offset; /* Offset of table with start offsets of translation strings. */ nls_uint32 trans_tab_offset; /* Size of hashing table. */ nls_uint32 hash_tab_size; /* Offset of first hashing entry. */ nls_uint32 hash_tab_offset; }; struct string_desc { /* Length of addressed string. */ nls_uint32 length; /* Offset of string in file. */ nls_uint32 offset; }; /* @@ begin of epilog @@ */ #endif /* gettext.h */ librep-0.90.2/intl/gettext.c0000644000175200017520000000362311245011152014657 0ustar chrischris/* Implementation of gettext(3) function. Copyright (C) 1995, 1997 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #ifdef _LIBC # define __need_NULL # include #else # ifdef STDC_HEADERS # include /* Just for NULL. */ # else # ifdef HAVE_STRING_H # include # else # define NULL ((void *) 0) # endif # endif #endif #ifdef _LIBC # include #else # include "libgettext.h" #endif /* @@ end of prolog @@ */ /* Names for the libintl functions are a problem. They must not clash with existing names and they should follow ANSI C. But this source code is also used in GNU C Library where the names have a __ prefix. So we have to make a difference here. */ #ifdef _LIBC # define GETTEXT __gettext # define DGETTEXT __dgettext #else # define GETTEXT gettext__ # define DGETTEXT dgettext__ #endif /* Look up MSGID in the current default message catalog for the current LC_MESSAGES locale. If not found, returns MSGID itself (the default text). */ char * GETTEXT (msgid) const char *msgid; { return DGETTEXT (NULL, msgid); } #ifdef _LIBC /* Alias for function name in GNU C Library. */ weak_alias (__gettext, gettext); #endif librep-0.90.2/intl/finddomain.c0000644000175200017520000001333411245011152015303 0ustar chrischris/* Handle list of needed message catalogs Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. Written by Ulrich Drepper , 1995. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #include #include #include #include #if defined STDC_HEADERS || defined _LIBC # include #else # ifdef HAVE_MALLOC_H # include # else void free (); # endif #endif #if defined HAVE_STRING_H || defined _LIBC # include #else # include # ifndef memcpy # define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) # endif #endif #if !HAVE_STRCHR && !defined _LIBC # ifndef strchr # define strchr index # endif #endif #if defined HAVE_UNISTD_H || defined _LIBC # include #endif #include "gettext.h" #include "gettextP.h" #ifdef _LIBC # include #else # include "libgettext.h" #endif /* @@ end of prolog @@ */ /* List of already loaded domains. */ static struct loaded_l10nfile *_nl_loaded_domains; /* Return a data structure describing the message catalog described by the DOMAINNAME and CATEGORY parameters with respect to the currently established bindings. */ struct loaded_l10nfile * internal_function _nl_find_domain (dirname, locale, domainname) const char *dirname; char *locale; const char *domainname; { struct loaded_l10nfile *retval; const char *language; const char *modifier; const char *territory; const char *codeset; const char *normalized_codeset; const char *special; const char *sponsor; const char *revision; const char *alias_value; int mask; /* LOCALE can consist of up to four recognized parts for the XPG syntax: language[_territory[.codeset]][@modifier] and six parts for the CEN syntax: language[_territory][+audience][+special][,[sponsor][_revision]] Beside the first part all of them are allowed to be missing. If the full specified locale is not found, the less specific one are looked for. The various parts will be stripped off according to the following order: (1) revision (2) sponsor (3) special (4) codeset (5) normalized codeset (6) territory (7) audience/modifier */ /* If we have already tested for this locale entry there has to be one data set in the list of loaded domains. */ retval = _nl_make_l10nflist (&_nl_loaded_domains, dirname, strlen (dirname) + 1, 0, locale, NULL, NULL, NULL, NULL, NULL, NULL, NULL, domainname, 0); if (retval != NULL) { /* We know something about this locale. */ int cnt; if (retval->decided == 0) _nl_load_domain (retval); if (retval->data != NULL) return retval; for (cnt = 0; retval->successor[cnt] != NULL; ++cnt) { if (retval->successor[cnt]->decided == 0) _nl_load_domain (retval->successor[cnt]); if (retval->successor[cnt]->data != NULL) break; } return cnt >= 0 ? retval : NULL; /* NOTREACHED */ } /* See whether the locale value is an alias. If yes its value *overwrites* the alias name. No test for the original value is done. */ alias_value = _nl_expand_alias (locale); if (alias_value != NULL) { #if defined _LIBC || defined HAVE_STRDUP locale = strdup (alias_value); if (locale == NULL) return NULL; #else size_t len = strlen (alias_value) + 1; locale = (char *) malloc (len); if (locale == NULL) return NULL; memcpy (locale, alias_value, len); #endif } /* Now we determine the single parts of the locale name. First look for the language. Termination symbols are `_' and `@' if we use XPG4 style, and `_', `+', and `,' if we use CEN syntax. */ mask = _nl_explode_name (locale, &language, &modifier, &territory, &codeset, &normalized_codeset, &special, &sponsor, &revision); /* Create all possible locale entries which might be interested in generalization. */ retval = _nl_make_l10nflist (&_nl_loaded_domains, dirname, strlen (dirname) + 1, mask, language, territory, codeset, normalized_codeset, modifier, special, sponsor, revision, domainname, 1); if (retval == NULL) /* This means we are out of core. */ return NULL; if (retval->decided == 0) _nl_load_domain (retval); if (retval->data == NULL) { int cnt; for (cnt = 0; retval->successor[cnt] != NULL; ++cnt) { if (retval->successor[cnt]->decided == 0) _nl_load_domain (retval->successor[cnt]); if (retval->successor[cnt]->data != NULL) break; } } /* The room for an alias was dynamically allocated. Free it now. */ if (alias_value != NULL) free (locale); return retval; } #ifdef _LIBC static void __attribute__ ((unused)) free_mem (void) { struct loaded_l10nfile *runp = _nl_loaded_domains; while (runp != NULL) { struct loaded_l10nfile *here = runp; if (runp->data != NULL) _nl_unload_domain ((struct loaded_domain *) runp->data); runp = runp->next; free (here); } } text_set_element (__libc_subfreeres, free_mem); #endif librep-0.90.2/intl/explodename.c0000644000175200017520000001101011245011152015461 0ustar chrischris/* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. Contributed by Ulrich Drepper , 1995. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #if defined STDC_HEADERS || defined _LIBC # include #endif #if defined HAVE_STRING_H || defined _LIBC # include #else # include #endif #include #include "loadinfo.h" /* On some strange systems still no definition of NULL is found. Sigh! */ #ifndef NULL # if defined __STDC__ && __STDC__ # define NULL ((void *) 0) # else # define NULL 0 # endif #endif /* @@ end of prolog @@ */ int _nl_explode_name (name, language, modifier, territory, codeset, normalized_codeset, special, sponsor, revision) char *name; const char **language; const char **modifier; const char **territory; const char **codeset; const char **normalized_codeset; const char **special; const char **sponsor; const char **revision; { enum { undecided, xpg, cen } syntax; char *cp; int mask; *modifier = NULL; *territory = NULL; *codeset = NULL; *normalized_codeset = NULL; *special = NULL; *sponsor = NULL; *revision = NULL; /* Now we determine the single parts of the locale name. First look for the language. Termination symbols are `_' and `@' if we use XPG4 style, and `_', `+', and `,' if we use CEN syntax. */ mask = 0; syntax = undecided; *language = cp = name; while (cp[0] != '\0' && cp[0] != '_' && cp[0] != '@' && cp[0] != '+' && cp[0] != ',') ++cp; if (*language == cp) /* This does not make sense: language has to be specified. Use this entry as it is without exploding. Perhaps it is an alias. */ cp = strchr (*language, '\0'); else if (cp[0] == '_') { /* Next is the territory. */ cp[0] = '\0'; *territory = ++cp; while (cp[0] != '\0' && cp[0] != '.' && cp[0] != '@' && cp[0] != '+' && cp[0] != ',' && cp[0] != '_') ++cp; mask |= TERRITORY; if (cp[0] == '.') { /* Next is the codeset. */ syntax = xpg; cp[0] = '\0'; *codeset = ++cp; while (cp[0] != '\0' && cp[0] != '@') ++cp; mask |= XPG_CODESET; if (*codeset != cp && (*codeset)[0] != '\0') { *normalized_codeset = _nl_normalize_codeset (*codeset, cp - *codeset); if (strcmp (*codeset, *normalized_codeset) == 0) free ((char *) *normalized_codeset); else mask |= XPG_NORM_CODESET; } } } if (cp[0] == '@' || (syntax != xpg && cp[0] == '+')) { /* Next is the modifier. */ syntax = cp[0] == '@' ? xpg : cen; cp[0] = '\0'; *modifier = ++cp; while (syntax == cen && cp[0] != '\0' && cp[0] != '+' && cp[0] != ',' && cp[0] != '_') ++cp; mask |= XPG_MODIFIER | CEN_AUDIENCE; } if (syntax != xpg && (cp[0] == '+' || cp[0] == ',' || cp[0] == '_')) { syntax = cen; if (cp[0] == '+') { /* Next is special application (CEN syntax). */ cp[0] = '\0'; *special = ++cp; while (cp[0] != '\0' && cp[0] != ',' && cp[0] != '_') ++cp; mask |= CEN_SPECIAL; } if (cp[0] == ',') { /* Next is sponsor (CEN syntax). */ cp[0] = '\0'; *sponsor = ++cp; while (cp[0] != '\0' && cp[0] != '_') ++cp; mask |= CEN_SPONSOR; } if (cp[0] == '_') { /* Next is revision (CEN syntax). */ cp[0] = '\0'; *revision = ++cp; mask |= CEN_REVISION; } } /* For CEN syntax values it might be important to have the separator character in the file name, not for XPG syntax. */ if (syntax == xpg) { if (*territory != NULL && (*territory)[0] == '\0') mask &= ~TERRITORY; if (*codeset != NULL && (*codeset)[0] == '\0') mask &= ~XPG_CODESET; if (*modifier != NULL && (*modifier)[0] == '\0') mask &= ~XPG_MODIFIER; } return mask; } librep-0.90.2/intl/dgettext.c0000644000175200017520000000337211245011152015024 0ustar chrischris/* Implementation of the dgettext(3) function Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #if defined HAVE_LOCALE_H || defined _LIBC # include #endif #ifdef _LIBC # include #else # include "libgettext.h" #endif /* @@ end of prolog @@ */ /* Names for the libintl functions are a problem. They must not clash with existing names and they should follow ANSI C. But this source code is also used in GNU C Library where the names have a __ prefix. So we have to make a difference here. */ #ifdef _LIBC # define DGETTEXT __dgettext # define DCGETTEXT __dcgettext #else # define DGETTEXT dgettext__ # define DCGETTEXT dcgettext__ #endif /* Look up MSGID in the DOMAINNAME message catalog of the current LC_MESSAGES locale. */ char * DGETTEXT (domainname, msgid) const char *domainname; const char *msgid; { return DCGETTEXT (domainname, msgid, LC_MESSAGES); } #ifdef _LIBC /* Alias for function name in GNU C Library. */ weak_alias (__dgettext, dgettext); #endif librep-0.90.2/intl/dcgettext.c0000644000175200017520000004020011245011152015156 0ustar chrischris/* Implementation of the dcgettext(3) function. Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #include #ifdef __GNUC__ # define alloca __builtin_alloca # define HAVE_ALLOCA 1 #else # if defined HAVE_ALLOCA_H || defined _LIBC # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca char *alloca (); # endif # endif # endif #endif #include #ifndef errno extern int errno; #endif #ifndef __set_errno # define __set_errno(val) errno = (val) #endif #if defined STDC_HEADERS || defined _LIBC # include #else char *getenv (); # ifdef HAVE_MALLOC_H # include # else void free (); # endif #endif #if defined HAVE_STRING_H || defined _LIBC # ifndef _GNU_SOURCE # define _GNU_SOURCE 1 # endif # include #else # include #endif #if !HAVE_STRCHR && !defined _LIBC # ifndef strchr # define strchr index # endif #endif #if defined HAVE_UNISTD_H || defined _LIBC # include #endif #include "gettext.h" #include "gettextP.h" #ifdef _LIBC # include #else # include "libgettext.h" #endif #include "hash-string.h" /* @@ end of prolog @@ */ #ifdef _LIBC /* Rename the non ANSI C functions. This is required by the standard because some ANSI C functions will require linking with this object file and the name space must not be polluted. */ # define getcwd __getcwd # ifndef stpcpy # define stpcpy __stpcpy # endif #else # if !defined HAVE_GETCWD char *getwd (); # define getcwd(buf, max) getwd (buf) # else char *getcwd (); # endif # ifndef HAVE_STPCPY static char *stpcpy PARAMS ((char *dest, const char *src)); # endif #endif /* Amount to increase buffer size by in each try. */ #define PATH_INCR 32 /* The following is from pathmax.h. */ /* Non-POSIX BSD systems might have gcc's limits.h, which doesn't define PATH_MAX but might cause redefinition warnings when sys/param.h is later included (as on MORE/BSD 4.3). */ #if defined(_POSIX_VERSION) || (defined(HAVE_LIMITS_H) && !defined(__GNUC__)) # include #endif #ifndef _POSIX_PATH_MAX # define _POSIX_PATH_MAX 255 #endif #if !defined(PATH_MAX) && defined(_PC_PATH_MAX) # define PATH_MAX (pathconf ("/", _PC_PATH_MAX) < 1 ? 1024 : pathconf ("/", _PC_PATH_MAX)) #endif /* Don't include sys/param.h if it already has been. */ #if defined(HAVE_SYS_PARAM_H) && !defined(PATH_MAX) && !defined(MAXPATHLEN) # include #endif #if !defined(PATH_MAX) && defined(MAXPATHLEN) # define PATH_MAX MAXPATHLEN #endif #ifndef PATH_MAX # define PATH_MAX _POSIX_PATH_MAX #endif /* XPG3 defines the result of `setlocale (category, NULL)' as: ``Directs `setlocale()' to query `category' and return the current setting of `local'.'' However it does not specify the exact format. And even worse: POSIX defines this not at all. So we can use this feature only on selected system (e.g. those using GNU C Library). */ #ifdef _LIBC # define HAVE_LOCALE_NULL #endif /* Name of the default domain used for gettext(3) prior any call to textdomain(3). The default value for this is "messages". */ const char _nl_default_default_domain[] = "messages"; /* Value used as the default domain for gettext(3). */ const char *_nl_current_default_domain = _nl_default_default_domain; /* Contains the default location of the message catalogs. */ const char _nl_default_dirname[] = GNULOCALEDIR; /* List with bindings of specific domains created by bindtextdomain() calls. */ struct binding *_nl_domain_bindings; /* Prototypes for local functions. */ static char *find_msg PARAMS ((struct loaded_l10nfile *domain_file, const char *msgid)) internal_function; static const char *category_to_name PARAMS ((int category)) internal_function; static const char *guess_category_value PARAMS ((int category, const char *categoryname)) internal_function; /* For those loosing systems which don't have `alloca' we have to add some additional code emulating it. */ #ifdef HAVE_ALLOCA /* Nothing has to be done. */ # define ADD_BLOCK(list, address) /* nothing */ # define FREE_BLOCKS(list) /* nothing */ #else struct block_list { void *address; struct block_list *next; }; # define ADD_BLOCK(list, addr) \ do { \ struct block_list *newp = (struct block_list *) malloc (sizeof (*newp)); \ /* If we cannot get a free block we cannot add the new element to \ the list. */ \ if (newp != NULL) { \ newp->address = (addr); \ newp->next = (list); \ (list) = newp; \ } \ } while (0) # define FREE_BLOCKS(list) \ do { \ while (list != NULL) { \ struct block_list *old = list; \ list = list->next; \ free (old); \ } \ } while (0) # undef alloca # define alloca(size) (malloc (size)) #endif /* have alloca */ /* Names for the libintl functions are a problem. They must not clash with existing names and they should follow ANSI C. But this source code is also used in GNU C Library where the names have a __ prefix. So we have to make a difference here. */ #ifdef _LIBC # define DCGETTEXT __dcgettext #else # define DCGETTEXT dcgettext__ #endif /* Look up MSGID in the DOMAINNAME message catalog for the current CATEGORY locale. */ char * DCGETTEXT (domainname, msgid, category) const char *domainname; const char *msgid; int category; { #ifndef HAVE_ALLOCA struct block_list *block_list = NULL; #endif struct loaded_l10nfile *domain; struct binding *binding; const char *categoryname; const char *categoryvalue; char *dirname, *xdomainname; char *single_locale; char *retval; int saved_errno = errno; /* If no real MSGID is given return NULL. */ if (msgid == NULL) return NULL; /* If DOMAINNAME is NULL, we are interested in the default domain. If CATEGORY is not LC_MESSAGES this might not make much sense but the defintion left this undefined. */ if (domainname == NULL) domainname = _nl_current_default_domain; /* First find matching binding. */ for (binding = _nl_domain_bindings; binding != NULL; binding = binding->next) { int compare = strcmp (domainname, binding->domainname); if (compare == 0) /* We found it! */ break; if (compare < 0) { /* It is not in the list. */ binding = NULL; break; } } if (binding == NULL) dirname = (char *) _nl_default_dirname; else if (binding->dirname[0] == '/') dirname = binding->dirname; else { /* We have a relative path. Make it absolute now. */ size_t dirname_len = strlen (binding->dirname) + 1; size_t path_max; char *ret; path_max = (unsigned) PATH_MAX; path_max += 2; /* The getcwd docs say to do this. */ dirname = (char *) alloca (path_max + dirname_len); ADD_BLOCK (block_list, dirname); __set_errno (0); while ((ret = getcwd (dirname, path_max)) == NULL && errno == ERANGE) { path_max += PATH_INCR; dirname = (char *) alloca (path_max + dirname_len); ADD_BLOCK (block_list, dirname); __set_errno (0); } if (ret == NULL) { /* We cannot get the current working directory. Don't signal an error but simply return the default string. */ FREE_BLOCKS (block_list); __set_errno (saved_errno); return (char *) msgid; } stpcpy (stpcpy (strchr (dirname, '\0'), "/"), binding->dirname); } /* Now determine the symbolic name of CATEGORY and its value. */ categoryname = category_to_name (category); categoryvalue = guess_category_value (category, categoryname); xdomainname = (char *) alloca (strlen (categoryname) + strlen (domainname) + 5); ADD_BLOCK (block_list, xdomainname); stpcpy (stpcpy (stpcpy (stpcpy (xdomainname, categoryname), "/"), domainname), ".mo"); /* Creating working area. */ single_locale = (char *) alloca (strlen (categoryvalue) + 1); ADD_BLOCK (block_list, single_locale); /* Search for the given string. This is a loop because we perhaps got an ordered list of languages to consider for th translation. */ while (1) { /* Make CATEGORYVALUE point to the next element of the list. */ while (categoryvalue[0] != '\0' && categoryvalue[0] == ':') ++categoryvalue; if (categoryvalue[0] == '\0') { /* The whole contents of CATEGORYVALUE has been searched but no valid entry has been found. We solve this situation by implicitly appending a "C" entry, i.e. no translation will take place. */ single_locale[0] = 'C'; single_locale[1] = '\0'; } else { char *cp = single_locale; while (categoryvalue[0] != '\0' && categoryvalue[0] != ':') *cp++ = *categoryvalue++; *cp = '\0'; } /* If the current locale value is C (or POSIX) we don't load a domain. Return the MSGID. */ if (strcmp (single_locale, "C") == 0 || strcmp (single_locale, "POSIX") == 0) { FREE_BLOCKS (block_list); __set_errno (saved_errno); return (char *) msgid; } /* Find structure describing the message catalog matching the DOMAINNAME and CATEGORY. */ domain = _nl_find_domain (dirname, single_locale, xdomainname); if (domain != NULL) { retval = find_msg (domain, msgid); if (retval == NULL) { int cnt; for (cnt = 0; domain->successor[cnt] != NULL; ++cnt) { retval = find_msg (domain->successor[cnt], msgid); if (retval != NULL) break; } } if (retval != NULL) { FREE_BLOCKS (block_list); __set_errno (saved_errno); return retval; } } } /* NOTREACHED */ } #ifdef _LIBC /* Alias for function name in GNU C Library. */ weak_alias (__dcgettext, dcgettext); #endif static char * internal_function find_msg (domain_file, msgid) struct loaded_l10nfile *domain_file; const char *msgid; { size_t top, act, bottom; struct loaded_domain *domain; if (domain_file->decided == 0) _nl_load_domain (domain_file); if (domain_file->data == NULL) return NULL; domain = (struct loaded_domain *) domain_file->data; /* Locate the MSGID and its translation. */ if (domain->hash_size > 2 && domain->hash_tab != NULL) { /* Use the hashing table. */ nls_uint32 len = strlen (msgid); nls_uint32 hash_val = hash_string (msgid); nls_uint32 idx = hash_val % domain->hash_size; nls_uint32 incr = 1 + (hash_val % (domain->hash_size - 2)); nls_uint32 nstr = W (domain->must_swap, domain->hash_tab[idx]); if (nstr == 0) /* Hash table entry is empty. */ return NULL; if (W (domain->must_swap, domain->orig_tab[nstr - 1].length) == len && strcmp (msgid, domain->data + W (domain->must_swap, domain->orig_tab[nstr - 1].offset)) == 0) return (char *) domain->data + W (domain->must_swap, domain->trans_tab[nstr - 1].offset); while (1) { if (idx >= domain->hash_size - incr) idx -= domain->hash_size - incr; else idx += incr; nstr = W (domain->must_swap, domain->hash_tab[idx]); if (nstr == 0) /* Hash table entry is empty. */ return NULL; if (W (domain->must_swap, domain->orig_tab[nstr - 1].length) == len && strcmp (msgid, domain->data + W (domain->must_swap, domain->orig_tab[nstr - 1].offset)) == 0) return (char *) domain->data + W (domain->must_swap, domain->trans_tab[nstr - 1].offset); } /* NOTREACHED */ } /* Now we try the default method: binary search in the sorted array of messages. */ bottom = 0; top = domain->nstrings; while (bottom < top) { int cmp_val; act = (bottom + top) / 2; cmp_val = strcmp (msgid, domain->data + W (domain->must_swap, domain->orig_tab[act].offset)); if (cmp_val < 0) top = act; else if (cmp_val > 0) bottom = act + 1; else break; } /* If an translation is found return this. */ return bottom >= top ? NULL : (char *) domain->data + W (domain->must_swap, domain->trans_tab[act].offset); } /* Return string representation of locale CATEGORY. */ static const char * internal_function category_to_name (category) int category; { const char *retval; switch (category) { #ifdef LC_COLLATE case LC_COLLATE: retval = "LC_COLLATE"; break; #endif #ifdef LC_CTYPE case LC_CTYPE: retval = "LC_CTYPE"; break; #endif #ifdef LC_MONETARY case LC_MONETARY: retval = "LC_MONETARY"; break; #endif #ifdef LC_NUMERIC case LC_NUMERIC: retval = "LC_NUMERIC"; break; #endif #ifdef LC_TIME case LC_TIME: retval = "LC_TIME"; break; #endif #ifdef LC_MESSAGES case LC_MESSAGES: retval = "LC_MESSAGES"; break; #endif #ifdef LC_RESPONSE case LC_RESPONSE: retval = "LC_RESPONSE"; break; #endif #ifdef LC_ALL case LC_ALL: /* This might not make sense but is perhaps better than any other value. */ retval = "LC_ALL"; break; #endif default: /* If you have a better idea for a default value let me know. */ retval = "LC_XXX"; } return retval; } /* Guess value of current locale from value of the environment variables. */ static const char * internal_function guess_category_value (category, categoryname) int category; const char *categoryname; { const char *retval; /* The highest priority value is the `LANGUAGE' environment variable. This is a GNU extension. */ retval = getenv ("LANGUAGE"); if (retval != NULL && retval[0] != '\0') return retval; /* `LANGUAGE' is not set. So we have to proceed with the POSIX methods of looking to `LC_ALL', `LC_xxx', and `LANG'. On some systems this can be done by the `setlocale' function itself. */ #if defined HAVE_SETLOCALE && defined HAVE_LC_MESSAGES && defined HAVE_LOCALE_NULL return setlocale (category, NULL); #else /* Setting of LC_ALL overwrites all other. */ retval = getenv ("LC_ALL"); if (retval != NULL && retval[0] != '\0') return retval; /* Next comes the name of the desired category. */ retval = getenv (categoryname); if (retval != NULL && retval[0] != '\0') return retval; /* Last possibility is the LANG environment variable. */ retval = getenv ("LANG"); if (retval != NULL && retval[0] != '\0') return retval; /* We use C as the default domain. POSIX says this is implementation defined. */ return "C"; #endif } /* @@ begin of epilog @@ */ /* We don't want libintl.a to depend on any other library. So we avoid the non-standard function stpcpy. In GNU C Library this function is available, though. Also allow the symbol HAVE_STPCPY to be defined. */ #if !_LIBC && !HAVE_STPCPY static char * stpcpy (dest, src) char *dest; const char *src; { while ((*dest++ = *src++) != '\0') /* Do nothing. */ ; return dest - 1; } #endif #ifdef _LIBC /* If we want to free all resources we have to do some work at program's end. */ static void __attribute__ ((unused)) free_mem (void) { struct binding *runp; for (runp = _nl_domain_bindings; runp != NULL; runp = runp->next) { free (runp->domainname); if (runp->dirname != _nl_default_dirname) /* Yes, this is a pointer comparison. */ free (runp->dirname); } if (_nl_current_default_domain != _nl_default_default_domain) /* Yes, again a pointer comparison. */ free ((char *) _nl_current_default_domain); } text_set_element (__libc_subfreeres, free_mem); #endif librep-0.90.2/intl/cat-compat.c0000644000175200017520000001474111245011152015226 0ustar chrischris/* Compatibility code for gettext-using-catgets interface. Copyright (C) 1995, 1997 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #include #ifdef STDC_HEADERS # include # include #else char *getenv (); # ifdef HAVE_MALLOC_H # include # endif #endif #ifdef HAVE_NL_TYPES_H # include #endif #include "libgettext.h" /* @@ end of prolog @@ */ /* XPG3 defines the result of `setlocale (category, NULL)' as: ``Directs `setlocale()' to query `category' and return the current setting of `local'.'' However it does not specify the exact format. And even worse: POSIX defines this not at all. So we can use this feature only on selected system (e.g. those using GNU C Library). */ #ifdef _LIBC # define HAVE_LOCALE_NULL #endif /* The catalog descriptor. */ static nl_catd catalog = (nl_catd) -1; /* Name of the default catalog. */ static const char default_catalog_name[] = "messages"; /* Name of currently used catalog. */ static const char *catalog_name = default_catalog_name; /* Get ID for given string. If not found return -1. */ static int msg_to_cat_id PARAMS ((const char *msg)); /* Substitution for systems lacking this function in their C library. */ #if !_LIBC && !HAVE_STPCPY static char *stpcpy PARAMS ((char *dest, const char *src)); #endif /* Set currently used domain/catalog. */ char * textdomain (domainname) const char *domainname; { nl_catd new_catalog; char *new_name; size_t new_name_len; char *lang; #if defined HAVE_SETLOCALE && defined HAVE_LC_MESSAGES \ && defined HAVE_LOCALE_NULL lang = setlocale (LC_MESSAGES, NULL); #else lang = getenv ("LC_ALL"); if (lang == NULL || lang[0] == '\0') { lang = getenv ("LC_MESSAGES"); if (lang == NULL || lang[0] == '\0') lang = getenv ("LANG"); } #endif if (lang == NULL || lang[0] == '\0') lang = "C"; /* See whether name of currently used domain is asked. */ if (domainname == NULL) return (char *) catalog_name; if (domainname[0] == '\0') domainname = default_catalog_name; /* Compute length of added path element. */ new_name_len = sizeof (LOCALEDIR) - 1 + 1 + strlen (lang) + sizeof ("/LC_MESSAGES/") - 1 + sizeof (PACKAGE) - 1 + sizeof (".cat"); new_name = (char *) malloc (new_name_len); if (new_name == NULL) return NULL; strcpy (new_name, PACKAGE); new_catalog = catopen (new_name, 0); if (new_catalog == (nl_catd) -1) { /* NLSPATH search didn't work, try absolute path */ sprintf (new_name, "%s/%s/LC_MESSAGES/%s.cat", LOCALEDIR, lang, PACKAGE); new_catalog = catopen (new_name, 0); if (new_catalog == (nl_catd) -1) { free (new_name); return (char *) catalog_name; } } /* Close old catalog. */ if (catalog != (nl_catd) -1) catclose (catalog); if (catalog_name != default_catalog_name) free ((char *) catalog_name); catalog = new_catalog; catalog_name = new_name; return (char *) catalog_name; } char * bindtextdomain (domainname, dirname) const char *domainname; const char *dirname; { #if HAVE_SETENV || HAVE_PUTENV char *old_val, *new_val, *cp; size_t new_val_len; /* This does not make much sense here but to be compatible do it. */ if (domainname == NULL) return NULL; /* Compute length of added path element. If we use setenv we don't need the first byts for NLSPATH=, but why complicate the code for this peanuts. */ new_val_len = sizeof ("NLSPATH=") - 1 + strlen (dirname) + sizeof ("/%L/LC_MESSAGES/%N.cat"); old_val = getenv ("NLSPATH"); if (old_val == NULL || old_val[0] == '\0') { old_val = NULL; new_val_len += 1 + sizeof (LOCALEDIR) - 1 + sizeof ("/%L/LC_MESSAGES/%N.cat"); } else new_val_len += strlen (old_val); new_val = (char *) malloc (new_val_len); if (new_val == NULL) return NULL; # if HAVE_SETENV cp = new_val; # else cp = stpcpy (new_val, "NLSPATH="); # endif cp = stpcpy (cp, dirname); cp = stpcpy (cp, "/%L/LC_MESSAGES/%N.cat:"); if (old_val == NULL) { # if __STDC__ stpcpy (cp, LOCALEDIR "/%L/LC_MESSAGES/%N.cat"); # else cp = stpcpy (cp, LOCALEDIR); stpcpy (cp, "/%L/LC_MESSAGES/%N.cat"); # endif } else stpcpy (cp, old_val); # if HAVE_SETENV setenv ("NLSPATH", new_val, 1); free (new_val); # else putenv (new_val); /* Do *not* free the environment entry we just entered. It is used from now on. */ # endif #endif return (char *) domainname; } #undef gettext char * gettext (msg) const char *msg; { int msgid; if (msg == NULL || catalog == (nl_catd) -1) return (char *) msg; /* Get the message from the catalog. We always use set number 1. The message ID is computed by the function `msg_to_cat_id' which works on the table generated by `po-to-tbl'. */ msgid = msg_to_cat_id (msg); if (msgid == -1) return (char *) msg; return catgets (catalog, 1, msgid, (char *) msg); } /* Look through the table `_msg_tbl' which has `_msg_tbl_length' entries for the one equal to msg. If it is found return the ID. In case when the string is not found return -1. */ static int msg_to_cat_id (msg) const char *msg; { int cnt; for (cnt = 0; cnt < _msg_tbl_length; ++cnt) if (strcmp (msg, _msg_tbl[cnt]._msg) == 0) return _msg_tbl[cnt]._msg_number; return -1; } /* @@ begin of epilog @@ */ /* We don't want libintl.a to depend on any other library. So we avoid the non-standard function stpcpy. In GNU C Library this function is available, though. Also allow the symbol HAVE_STPCPY to be defined. */ #if !_LIBC && !HAVE_STPCPY static char * stpcpy (dest, src) char *dest; const char *src; { while ((*dest++ = *src++) != '\0') /* Do nothing. */ ; return dest - 1; } #endif librep-0.90.2/intl/bindtextdom.c0000644000175200017520000001232311245011152015511 0ustar chrischris/* Implementation of the bindtextdomain(3) function Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H # include #endif #if defined STDC_HEADERS || defined _LIBC # include #else # ifdef HAVE_MALLOC_H # include # else void free (); # endif #endif #if defined HAVE_STRING_H || defined _LIBC # include #else # include # ifndef memcpy # define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) # endif #endif #ifdef _LIBC # include #else # include "libgettext.h" #endif #include "gettext.h" #include "gettextP.h" /* @@ end of prolog @@ */ /* Contains the default location of the message catalogs. */ extern const char _nl_default_dirname[]; /* List with bindings of specific domains. */ extern struct binding *_nl_domain_bindings; /* Names for the libintl functions are a problem. They must not clash with existing names and they should follow ANSI C. But this source code is also used in GNU C Library where the names have a __ prefix. So we have to make a difference here. */ #ifdef _LIBC # define BINDTEXTDOMAIN __bindtextdomain # ifndef strdup # define strdup(str) __strdup (str) # endif #else # define BINDTEXTDOMAIN bindtextdomain__ #endif /* Specify that the DOMAINNAME message catalog will be found in DIRNAME rather than in the system locale data base. */ char * BINDTEXTDOMAIN (domainname, dirname) const char *domainname; const char *dirname; { struct binding *binding; /* Some sanity checks. */ if (domainname == NULL || domainname[0] == '\0') return NULL; for (binding = _nl_domain_bindings; binding != NULL; binding = binding->next) { int compare = strcmp (domainname, binding->domainname); if (compare == 0) /* We found it! */ break; if (compare < 0) { /* It is not in the list. */ binding = NULL; break; } } if (dirname == NULL) /* The current binding has be to returned. */ return binding == NULL ? (char *) _nl_default_dirname : binding->dirname; if (binding != NULL) { /* The domain is already bound. If the new value and the old one are equal we simply do nothing. Otherwise replace the old binding. */ if (strcmp (dirname, binding->dirname) != 0) { char *new_dirname; if (strcmp (dirname, _nl_default_dirname) == 0) new_dirname = (char *) _nl_default_dirname; else { #if defined _LIBC || defined HAVE_STRDUP new_dirname = strdup (dirname); if (new_dirname == NULL) return NULL; #else size_t len = strlen (dirname) + 1; new_dirname = (char *) malloc (len); if (new_dirname == NULL) return NULL; memcpy (new_dirname, dirname, len); #endif } if (binding->dirname != _nl_default_dirname) free (binding->dirname); binding->dirname = new_dirname; } } else { /* We have to create a new binding. */ #if !defined _LIBC && !defined HAVE_STRDUP size_t len; #endif struct binding *new_binding = (struct binding *) malloc (sizeof (*new_binding)); if (new_binding == NULL) return NULL; #if defined _LIBC || defined HAVE_STRDUP new_binding->domainname = strdup (domainname); if (new_binding->domainname == NULL) return NULL; #else len = strlen (domainname) + 1; new_binding->domainname = (char *) malloc (len); if (new_binding->domainname == NULL) return NULL; memcpy (new_binding->domainname, domainname, len); #endif if (strcmp (dirname, _nl_default_dirname) == 0) new_binding->dirname = (char *) _nl_default_dirname; else { #if defined _LIBC || defined HAVE_STRDUP new_binding->dirname = strdup (dirname); if (new_binding->dirname == NULL) return NULL; #else len = strlen (dirname) + 1; new_binding->dirname = (char *) malloc (len); if (new_binding->dirname == NULL) return NULL; memcpy (new_binding->dirname, dirname, len); #endif } /* Now enqueue it. */ if (_nl_domain_bindings == NULL || strcmp (domainname, _nl_domain_bindings->domainname) < 0) { new_binding->next = _nl_domain_bindings; _nl_domain_bindings = new_binding; } else { binding = _nl_domain_bindings; while (binding->next != NULL && strcmp (domainname, binding->next->domainname) > 0) binding = binding->next; new_binding->next = binding->next; binding->next = new_binding; } binding = new_binding; } return binding->dirname; } #ifdef _LIBC /* Alias for function name in GNU C Library. */ weak_alias (__bindtextdomain, bindtextdomain); #endif librep-0.90.2/intl/VERSION0000644000175200017520000000005111245011152014067 0ustar chrischrisGNU gettext library from gettext-0.10.35 librep-0.90.2/intl/Makefile.in0000644000175200017520000001454511245011152015101 0ustar chrischris# Makefile for directory with message catalog handling in GNU NLS Utilities. # Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. PACKAGE = @PACKAGE@ VERSION = @VERSION@ SHELL = /bin/sh srcdir = @srcdir@ top_srcdir = @top_srcdir@ top_builddir = .. VPATH = @srcdir@ prefix = @prefix@ exec_prefix = @exec_prefix@ transform = @program_transform_name@ libdir = $(exec_prefix)/lib includedir = $(prefix)/include datadir = $(prefix)/@DATADIRNAME@ localedir = $(datadir)/locale gnulocaledir = $(prefix)/share/locale gettextsrcdir = @datadir@/gettext/intl aliaspath = $(localedir):. subdir = intl datarootdir = @datarootdir@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ MKINSTALLDIRS = @MKINSTALLDIRS@ l = @l@ AR = ar CC = @CC@ LIBTOOL = @LIBTOOL@ RANLIB = @RANLIB@ DEFS = -DLOCALEDIR=\"$(localedir)\" -DGNULOCALEDIR=\"$(gnulocaledir)\" \ -DLOCALE_ALIAS_PATH=\"$(aliaspath)\" @DEFS@ CPPFLAGS = @CPPFLAGS@ CFLAGS = @CFLAGS@ LDFLAGS = @LDFLAGS@ COMPILE = $(CC) -c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $(XCFLAGS) HEADERS = $(COMHDRS) libgettext.h loadinfo.h COMHDRS = gettext.h gettextP.h hash-string.h SOURCES = $(COMSRCS) intl-compat.c cat-compat.c COMSRCS = bindtextdom.c dcgettext.c dgettext.c gettext.c \ finddomain.c loadmsgcat.c localealias.c textdomain.c l10nflist.c \ explodename.c OBJECTS = @INTLOBJS@ bindtextdom.$lo dcgettext.$lo dgettext.$lo gettext.$lo \ finddomain.$lo loadmsgcat.$lo localealias.$lo textdomain.$lo l10nflist.$lo \ explodename.$lo CATOBJS = cat-compat.$lo ../po/cat-id-tbl.$lo GETTOBJS = intl-compat.$lo DISTFILES.common = ChangeLog Makefile.in linux-msg.sed po2tbl.sed.in \ xopen-msg.sed $(HEADERS) $(SOURCES) DISTFILES.normal = VERSION DISTFILES.gettext = libintl.glibc intlh.inst.in .SUFFIXES: .SUFFIXES: .c .o .lo .c.o: $(COMPILE) $< .c.lo: $(LIBTOOL) --mode=compile --tag=CC $(COMPILE) $< INCLUDES = -I.. -I. -I$(top_srcdir)/intl -I$(top_srcdir)/lib all: all-@USE_INCLUDED_LIBINTL@ all-yes: libintl.$la intlh.inst all-no: libintl.a: $(OBJECTS) rm -f $@ $(AR) cru $@ $(OBJECTS) $(RANLIB) $@ libintl.la: $(OBJECTS) $(LIBTOOL) --mode=link --tag=CC $(CC) $(LDFLAGS) -o $@ $(OBJECTS) \ -version-info 1:0 -rpath $(libdir) ../po/cat-id-tbl.$lo: ../po/cat-id-tbl.c $(top_srcdir)/po/$(PACKAGE).pot cd ../po && $(MAKE) cat-id-tbl.$lo check: all # This installation goal is only used in GNU gettext. Packages which # only use the library should use install instead. # We must not install the libintl.h/libintl.a files if we are on a # system which has the gettext() function in its C library or in a # separate library or use the catgets interface. A special case is # where configure found a previously installed GNU gettext library. # If you want to use the one which comes with this version of the # package, you have to use `configure --with-included-gettext'. install: install-exec install-data install-exec: all if test "$(PACKAGE)" = "gettext" \ && test '@INTLOBJS@' = '$(GETTOBJS)'; then \ if test -r $(MKINSTALLDIRS); then \ $(MKINSTALLDIRS) $(libdir) $(includedir); \ else \ $(top_srcdir)/mkinstalldirs $(libdir) $(includedir); \ fi; \ $(INSTALL_DATA) intlh.inst $(includedir)/libintl.h; \ $(INSTALL_DATA) libintl.a $(libdir)/libintl.a; \ else \ : ; \ fi install-data: all if test "$(PACKAGE)" = "gettext"; then \ if test -r $(MKINSTALLDIRS); then \ $(MKINSTALLDIRS) $(gettextsrcdir); \ else \ $(top_srcdir)/mkinstalldirs $(gettextsrcdir); \ fi; \ $(INSTALL_DATA) VERSION $(gettextsrcdir)/VERSION; \ dists="$(DISTFILES.common)"; \ for file in $$dists; do \ $(INSTALL_DATA) $(srcdir)/$$file $(gettextsrcdir)/$$file; \ done; \ else \ : ; \ fi # Define this as empty until I found a useful application. installcheck: uninstall: dists="$(DISTFILES.common)"; \ for file in $$dists; do \ rm -f $(gettextsrcdir)/$$file; \ done info dvi: $(OBJECTS): ../config.h libgettext.h bindtextdom.$lo finddomain.$lo loadmsgcat.$lo: gettextP.h gettext.h loadinfo.h dcgettext.$lo: gettextP.h gettext.h hash-string.h loadinfo.h tags: TAGS TAGS: $(HEADERS) $(SOURCES) here=`pwd`; cd $(srcdir) && etags -o $$here/TAGS $(HEADERS) $(SOURCES) id: ID ID: $(HEADERS) $(SOURCES) here=`pwd`; cd $(srcdir) && mkid -f$$here/ID $(HEADERS) $(SOURCES) mostlyclean: rm -f *.a *.o *.lo core core.* clean: mostlyclean distclean: clean rm -f Makefile ID TAGS po2msg.sed po2tbl.sed maintainer-clean: distclean @echo "This command is intended for maintainers to use;" @echo "it deletes files that may require special tools to rebuild." # GNU gettext needs not contain the file `VERSION' but contains some # other files which should not be distributed in other packages. distdir = ../$(PACKAGE)-$(VERSION)/$(subdir) dist distdir: Makefile $(DISTFILES) if test "$(PACKAGE)" = gettext; then \ additional="$(DISTFILES.gettext)"; \ else \ additional="$(DISTFILES.normal)"; \ fi; \ for file in $(DISTFILES.common) $$additional; do \ ln $(srcdir)/$$file $(distdir) 2> /dev/null \ || cp -p $(srcdir)/$$file $(distdir); \ done dist-libc: tar zcvf intl-glibc.tar.gz $(COMSRCS) $(COMHDRS) libintl.h.glibc Makefile: Makefile.in ../config.status cd .. \ && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status # The dependency for intlh.inst is different in gettext and all other # packages. Because we cannot you GNU make features we have to solve # the problem while rewriting Makefile.in. @GT_YES@intlh.inst: intlh.inst.in ../config.status @GT_YES@ cd .. \ @GT_YES@ && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= \ @GT_YES@ $(SHELL) ./config.status @GT_NO@.PHONY: intlh.inst @GT_NO@intlh.inst: # Tell versions [3.59,3.63) of GNU make not to export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: librep-0.90.2/doc/gc-protection0000644000175200017520000000431711245011152015327 0ustar chrischrisDate: Sun, 19 Dec 1999 14:58:46 GMT From: John Harper To: Ceri Storey Subject: Re: [Librep-list] GC questions CC: librep-list@mail1.sourceforge.net Sender: librep-list-admin@sourceforge.net Ceri Storey writes: |I was wondering a few things about how the gc works. | |what are the `sweep' functions*, and the (PUSH|POP)GC macros for? |how does the GC find it's initial set of roots? okay, I'm assuming you know basically how a mark/sweep gc works (mark phase: mark all reachable objects from a set of roots; sweep phase: free all unreachable objects, unmark any other objects) rep's gc relies on C code that calls functions that may gc marking all objects that may be referenced after the control returns. It does this on the stack, using a chained list of rep_GC_root objects, each one contains a pointer to the protected lisp object, and a pointer to the next rep_GC_root object the rep_PUSHGC and rep_POPGC macros simply maintain the linkage of the chain of rep_GC_root objects, and the values they protect. rep_PUSHGC(x,y) installs protection for repv y using rep_GC_root x, rep_POPGC removes the last piece of protection added so if I have a data object foo, that needs to be protected across a function call bar (), I'd do something like: repv foo; rep_GC_root gc_foo; rep_PUSHGC (gc_foo, foo); bar (); rep_POPGC; the mark phase of gc then uses each item in the chain of rep_GC_root objects as a root to mark from (there's also a second chain of roots, type rep_GC_n_roots, that protects a counted-array of lisp values) the second phase of gc is sweeping. By this point any objects that may be referenced in the future have been marked, any others are not marked. each data type has its own sweep function; this normally works by freeing any unmarked objects of its type, and rebuilding its list of all allocated objects (of its type). You can use a singly-linked list to do this in O(N) time by reversing the list each sweep (each data type can also have two marking functions, one to mark the contents of a single object of its type that is known to be reachable, and one to mark objects that it knows must not be freed, even when there are no references to them) John librep-0.90.2/doc/embed-30000644000175200017520000000416011245011152013762 0ustar chrischrisDate: Wed, 16 Feb 2000 16:46:33 GMT From: John Harper To: "Mikolaj J. Habryn" Subject: Re: embedding librep Mikolaj J. Habryn writes: |>>>>> "JH" == John Harper writes: | | JH> Frecursive_edit is rep's built-in | JH> event loop (you use rep_register_input_fd to register a | JH> function to be called when data arrives on a particular fd, | JH> e.g. sawmill's X connection) | | JH> after this function exits, so will sawmill | | I'm not sure I understand the causal relationship - is that last |fact due to the exit condition for sawmill being leaving the event |loop? Yes, I think so. Sawmill won't leave the top-level event loop (the event loop may be called recursively), until it's time to exit (this is done by executing (throw 'quit FOO) from within the event loop) |Or would it be possible to set up some context here, *not* call the |event loop, return from rep_call_with_barrier, and then later call |functions (or just invoke the event loop) in the sawmill context |(presumably using rep_call_with_barrier again)? This should work fine. The barrier around inner_main () is probably not necessary in this case, though it's a good idea to leave it there. (Barriers are used to control the weird control-flow patterns that may be introduced by the use of continuations. A continuation is a copy of the stack that may be used (possibly multiple times) to switch control to a previous context. A bit like C's setjmp/longjmp, except that you can jump into stack frames that have *already exited*! An open barrier just provides notification when the position on the stack it represents is entered or exited, a closed barrier (like the one around inner_main) actually _prevents_ continuations being used to pass that stack position. Closed barriers are also used to group threads. (there are more details in src/continuations.c) The reason you need to worry about this is because your C code is probably not going to like being reentered multiple times (but with different heap states), so you need to use closed barriers to prevent this happening..) librep-0.90.2/doc/embed-20000644000175200017520000000760011245011152013763 0ustar chrischrisDate: Mon, 14 Feb 2000 13:31:51 GMT From: John Harper To: "Mikolaj J. Habryn" Subject: Re: embedding librep Mikolaj J. Habryn writes: | Hmm - I'm having trouble reaching sourceforge at the moment, but |I'll dig through the archives and subscribe as soon as that changes. well, there's not much there, but there may be a few useful messages.. | | It appears that rep_load_environment does the actual execution of |the code - I presume that what I want to do is register lambda |expressions inside there (calling back into the C-code to do so), and |then return into inner_main. rep_load_environment is usually just used to do initialisation, in the case of rep.c it's the whole program, but that's not usual. Sawmill main.c is probably a better example, it's inner_main does the following: static repv inner_main (repv arg) { repv res = rep_load_environment(rep_string_dup ("sawmill")); if (res != rep_NULL) { /* final initialisation.. */ if(rep_SYM(Qbatch_mode)->value == Qnil) manage_windows (); /* then jump into the event loop.. */ if(rep_SYM(Qbatch_mode)->value == Qnil) res = Frecursive_edit (); } return res; } this is called after all exported lisp functions have been registered. manage_windows is a function to adopt all existing top-level windows, Frecursive_edit is rep's built-in event loop (you use rep_register_input_fd to register a function to be called when data arrives on a particular fd, e.g. sawmill's X connection) after this function exits, so will sawmill | | How do I make a C function visible to the lisp code, to register the |hooks with, and so that the hooks can get extra information if they |need it? by convention a lisp function `foo-bar' is represented by a C function Ffoo_bar and a subroutine data object Sfoo_bar. These are defined using the DEFUN macro: DEFUN ("foo-bar", Ffoo_bar, Sfoo_bar, (repv arg1), rep_Subr1) { /* signal an error if `arg1' isn't a cons */ rep_DECLARE (1, arg1, rep_CONSP (arg1)); ... do something with arg return some-result-repv; } (repv arg1) is the actual argument list for the function, rep_Subr1 defines the type of the subroutine object, in this case a function receiving a single argument, there's rep_Subr[1-5] and rep_SubrN which takes a single parameter, the _list_ of arguments given to the function to register this function with the interpreter it's necessary to then call: rep_ADD_SUBR (Sfoo_bar); in an initialisation function somewhere. | | How do I actually call the hooks, once they've been registered with |the C code? DEFUN-declared functions can be called as normal C functions. To create a hook, you need to define a symbol, i.e.: DEFSYM (foo_bar, "foo-bar"); this sets up storage for a symbol `foo-bar', and creates a `repv Qfoo_bar' variable. You then need to call rep_INTERN (foo_bar); in an initialisation function to initialise `Qfoo_bar'. If the symbol needs dynamic scope (i.e. it's used to represent a hook), then you do: rep_INTERN_SPECIAL (foo_bar); you can then do for example: Fset (Qfoo_bar, Qnil); to initialise it to nil, though that's not actually required for hooks. To invoke a hook, use Fcall_hook, i.e. Fcall_hook (Qfoo_bar, ARG-LIST, TYPE) ARG-LIST is the list of argument values to pass to the hook, e.g. to pass a single value use `rep_LIST_1 (VALUE)'. TYPE is a symbol defining how to interpret the values returned by functions, usually just use Qnil to force all functions in the hook to be called. If you just want to call a single lisp function, you can use rep_call_lispN, for example: rep_call_lisp1 (Fsymbol_value (Qfoo_bar, Qt), VALUE); when you do anything that may execute lisp code, you need to careful about garbage collection. Basically, you must have told the interpreter about any lisp values you're going to use after the called lisp code finishes executing. John librep-0.90.2/doc/embed-10000644000175200017520000000501711245011152013762 0ustar chrischrisDate: Mon, 14 Feb 2000 11:49:27 GMT From: John Harper To: "Mikolaj J. Habryn" Subject: Re: embedding librep Mikolaj J. Habryn writes: | Hi John - do you have any simple examples of using librep in an |inferior role? I need a scripting interface for a program that I'm |writing, and I'd much rather re-use somebody else's code :) Is there |anything other than sawmill (or presumably jade) that I could squint |at and try to understand? the simplest (and only other) example is rep.c in librep/src, it's not commented so here's a slightly simplified annotated version (from cvs librep) #include static repv inner_main (repv arg) { -- this boots the lisp environment, then loads the rep.jl[c] script return rep_load_environment (rep_string_dup ("rep")); } int main(int argc, char **argv) { char *prog_name = *argv++; argc--; -- this initialises the lisp data structures rep_init (prog_name, &argc, &argv, 0, 0); if (rep_get_option ("--version", 0)) { printf ("rep version %s\n", REP_VERSION); return 0; } -- this function is complex, it creates an execution context then calls inner_main from within this new context. It's needed because new librep does continuations and (soft) threading rep_call_with_barrier (inner_main, Qnil, rep_TRUE, 0, 0, 0); -- this function just checks if an error occurred, if so it will print some descriptive message, and returns a suitable exit code return rep_top_level_exit (); } But this is only half the story (or less). The main thing you'd have to understand is the C representation of Lisp data types. The header file rep_lisp.h defines this, and is reasonably well commented. For each data type there will be at least two macros rep_FOOP (x) which tests if a repv (a lisp pointer) is of type FOO, and rep_FOO (x) which casts the lisp pointer to the correct C pointer. So, e.g. for pairs, there's rep_CONSP and rep_CONS. There's also accessor macros rep_CAR (x) and rep_CDR (x) for this type. Another thing is that if a repv == rep_NULL, then an error occurred somewhere, and control should be unwound back to the top-level Garbage collection also complicates things, I posted a message to librep-list explaining the mechanics of this, it will be in the archives on sourceforge.. I've been meaning to document all this, but it's quite an undertaking :-) If you decide to use rep, I'm happy to answer as many questions as you have, or just post them to librep-list@lists.sourceforge.net John librep-0.90.2/lisp/rep.jl0000644000175200017520000000450011245011153014141 0ustar chrischris#| bootstrap for rep module $Id$ Copyright (C) 1993, 1994, 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep)) (open-structures '(rep.module-system rep.lang.interpreter rep.lang.symbols rep.lang.math rep.lang.debug rep.vm.interpreter rep.io.streams rep.io.files rep.io.processes rep.io.file-handlers rep.data rep.regexp rep.system)) ;;(setq backtrace-on-error '(void-value invalid-function bad-arg missing-arg)) (defvar standard-output (stdout-file) "Stream that `prin?' writes its output to by default.") (defvar standard-input (stdin-file) "Stream that `read' takes its input from by default.") (defvar standard-error (stderr-file) "Standard stream for error output.") ;; null i18n function until gettext is loaded (defun _ (arg) arg) (export-bindings '(_)) (export-bindings (parse-interface '(compound-interface (structure-interface rep.lang.interpreter) (structure-interface rep.lang.debug) (structure-interface rep.lang.symbols) (structure-interface rep.lang.math) (structure-interface rep.lang.debug) (structure-interface rep.data) (structure-interface rep.io.streams) (structure-interface rep.vm.interpreter) (structure-interface rep.module-system) (export backquote)))) ;; later changed to 'user (setq *user-structure* 'rep) (require 'rep.lang.backquote) (require 'rep.io.file-handlers.tilde) (defvar debug-entry (make-autoload 'debug-entry "rep/lang/debugger")) (defvar debug-exit) (defvar debug-error-entry (make-autoload 'debug-error-entry "rep/lang/debugger")) librep-0.90.2/lisp/Makefile.in0000644000175200017520000000424511245011153015077 0ustar chrischris# Makefile.in for rep's Lisp files # Copyright (C) 1998 John Harper # $Id$ # # This file is part of rep. # # rep is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # rep is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with rep; see the file COPYING. If not, write to # the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. top_builddir=.. VPATH=@srcdir@:@top_srcdir@ INSTALL_FILES = *.jl *.jlc INSTALL_DIRS := . rep rep rep/lang rep/vm rep/vm/compiler rep/io \ rep/io/file-handlers rep/io/file-handlers/remote rep/i18n \ rep/data rep/www rep/util rep/mail rep/threads rep/system \ rep/net rep/test rep/xml all : lisp lisp : ../src/.libexec $(COMPILE_ENV) $(rep_prog) --batch --no-rc \ -l rep.vm.compiler -f compile-assembler $(COMPILE_ENV) $(rep_prog) --batch --no-rc \ -l rep.vm.compiler -f compile-compiler $(COMPILE_ENV) $(rep_prog) --batch --no-rc \ -l rep.vm.compiler -f compile-lisp-lib ../src/.libexec : ( cd ../src && $(MAKE) .libexec ) check : all $(COMPILE_ENV) $(rep_prog) --batch --check install : all installdirs for d in $(INSTALL_DIRS); do \ for f in $(foreach x,$(INSTALL_FILES),$$d/$(x)); do \ $(INSTALL_DATA) $$f $(DESTDIR)$(replispdir)/$$d; \ done; \ done $(SHELL) $(top_srcdir)/install-aliases -l . $(DESTDIR)$(replispdir) installdirs : mkinstalldirs $(SHELL) $< $(foreach x,$(INSTALL_DIRS),$(DESTDIR)$(replispdir)/$(x)) uninstall : for d in $(INSTALL_DIRS); do \ for f in $(foreach x,$(INSTALL_FILES),$$d/$(x)); do \ rm -f $(DESTDIR)$(replispdir)/$$f; \ done; \ done clean : rm -f `find . \( -name '*.jlc' -o -name '*~' -o -name core \) -print` distclean : clean rm -f Makefile realclean : distclean .PHONY : all lisp install uninstall clean realclean distclean librep-0.90.2/lisp/rep/user.jl0000644000175200017520000001064611245011153015127 0ustar chrischris#| rep.jl -- read-eval-print loop $Id$ Copyright (C) 1993, 1994 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure user () ((open rep rep.regexp rep.system rep.io.files rep.io.processes) (set-binds)) (defun do-load (name) (cond ((file-exists-p name) (load name nil t t)) ((string-match "\\.jlc?$" name) (load name)) (t (require (intern name))))) (defun parse-options () (let (arg) (condition-case error-data (while (setq arg (car command-line-args)) (setq command-line-args (cdr command-line-args)) (cond ((member arg '("--call" "-f")) (setq arg (car command-line-args)) (setq command-line-args (cdr command-line-args)) ((symbol-value (read-from-string arg)))) ((member arg '("--load" "-l")) (setq arg (car command-line-args)) (setq command-line-args (cdr command-line-args)) (do-load arg)) ((string= arg "--check") (require 'rep.test.framework) (run-self-tests-and-exit)) ((string= arg "--help") (format standard-error "\ usage: %s [OPTIONS...] where OPTIONS are any of: FILE load the Lisp file FILE (from the cwd if possible, implies --batch mode) --batch batch mode: process options and exit --interp interpreted mode: don't load compiled Lisp files --debug start in the debugger (implies --interp) --call FUNCTION call the Lisp function FUNCTION --f FUNCTION --load FILE load the file of Lisp forms called FILE -l FILE -s FILE (implies --batch mode) --check run self tests and exit --version print version details --no-rc don't load rc or site-init files --quit, -q terminate the interpreter process\n" program-name) (throw 'quit 0)) ((string= arg "--version") (format standard-output "rep version %s\n" rep-version) (throw 'quit 0)) ((member arg '("--quit" "-q")) (throw 'quit 0)) (t (setq batch-mode t) (do-load arg)))) (error (error-handler-function (car error-data) (cdr error-data)) (throw 'quit 1))))) (setq *user-structure* 'user) ;; Install all autoload hooks. (load-all "autoload" (lambda (f) (load f nil t))) ;; Do operating-system initialisation (load-all (concat "os-" (symbol-name operating-system)) t) ;; Load site specific initialisation. Errors here are trapped since ;; they're probably not going to result in an unusable state (unless (get-command-line-option "--no-rc") (condition-case error-data (progn ;; First the site-wide stuff (load-all "site-init") ;; Now try to interpret the user's startup file, or failing that ;; the default.jl file providing site-wide user options (or (load (concat (user-home-directory) ".reprc") t t t) (load "rep-default" t))) (error (default-error-handler (car error-data) (cdr error-data))))) ;; Use all arguments which are left. (if (get-command-line-option "--debug") (progn (require 'rep.lang.debugger) (call-with-lexical-origins (lambda () (setq interpreted-mode t) (setq debug-on-error '(bad-arg missing-arg invalid-function void-value invalid-read-syntax premature-end-of-stream invalid-lambda-list invalid-macro invalid-autoload no-catcher file-error invalid-stream setting-constant process-error arith-error assertion-failed check-failed test-failed)) (break) (parse-options)))) (parse-options)) (unless batch-mode (format standard-output "rep %s, Copyright (C) 1999-2000 John Harper rep comes with ABSOLUTELY NO WARRANTY; for details see the file COPYING Built %s\n" rep-version rep-build-id) (require 'rep.util.repl) (repl))) ;; prevent this being opened as a module nil librep-0.90.2/lisp/rep/system.jl0000644000175200017520000000413611245011153015472 0ustar chrischris#| rep.system bootstrap $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.system)) (open-structures '(rep.lang.symbols rep.data rep.io.files)) ;;; Hook manipulation (defun add-hook (hook-symbol new-func #!optional at-end) "Arrange it so that FUNCTION-NAME is added to the hook-list stored in symbol, HOOK-SYMBOL. It will added at the head of the list unless AT-END is true in which case it is added at the end." (unless (boundp hook-symbol) (make-variable-special hook-symbol) (set hook-symbol nil)) (if at-end (set hook-symbol (nconc (symbol-value hook-symbol) (cons new-func nil))) (set hook-symbol (cons new-func (symbol-value hook-symbol))))) (defun remove-hook (hook-symbol old-func) "Remove FUNCTION-NAME from the hook HOOK-SYMBOL." (set hook-symbol (delete old-func (symbol-value hook-symbol)))) (defun in-hook-p (hook-symbol fun) "Returns t if the function FUN is stored in the hook called HOOK-SYMBOL." (and (boundp hook-symbol) (memq fun (symbol-value hook-symbol)))) (export-bindings '(add-hook remove-hook in-hook-p)) ;;; misc (autoload 'getenv "rep/system/environ") (autoload 'setenv "rep/system/environ") (autoload 'unsetenv "rep/system/environ") (autoload 'pwd-prompt "rep/system/pwd-prompt") (export-bindings '(getenv setenv unsetenv operating-system rep-version rep-interface-id rep-build-id pwd-prompt)) librep-0.90.2/lisp/rep/structures.jl0000644000175200017520000000457111245011153016374 0ustar chrischris#| rep.structures bootstrap $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.structures)) (open-structures '(rep.lang.symbols rep.data)) (make-structure nil nil nil '%interfaces) (defun make-interface (name sig) "Create an interface called NAME exporting the list of symbols SIG." (structure-define (get-structure '%interfaces) name sig)) (defun parse-interface (sig) "Return the list of symbols described by the module interface SIG." (cond ((null sig) '()) ((eq (car sig) 'export) (cdr sig)) ((eq (car sig) 'compound-interface) (apply append (mapcar parse-interface (cdr sig)))) ((eq (car sig) 'structure-interface) (structure-interface (intern-structure (cadr sig)))) ((symbolp sig) (let ((interfaces (get-structure '%interfaces))) (or (structure-bound-p interfaces sig) (error "No such interface: %s" sig)) (%structure-ref interfaces sig))))) (defun alias-structure (from to) "Create an alias of the structure called FROM as the name TO." (name-structure (get-structure from) to)) (defun locate-binding (var imported) "Return the name of the structure binding VAR, using the list of module names IMPORTED as the search start points." (when imported (let ((tem (structure-exports-p (get-structure (car imported)) var))) (cond ((null tem) (locate-binding var (cdr imported))) ((eq tem 'external) ;; this module exports it, but it doesn't define ;; it, so search its imports (locate-binding var (structure-imports (get-structure (car imported))))) (t (car imported)))))) (export-bindings '(make-interface parse-interface alias-structure locate-binding)) librep-0.90.2/lisp/rep/regexp.jl0000644000175200017520000000401011245011153015427 0ustar chrischris#| rep.regexp bootstrap $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.regexp)) (open-structures '(rep.data)) (defun string-replace (regexp template string) "Return the string created by replacing all matches of REGEXP in STRING with the expansion of TEMPLATE. If TEMPLATE is a string, it is expanded using the `expand-last-match' function, otherwise TEMPLATE is called as a function with STRING as its sole argument. It should return a string. Also it is guaranteed that the last regular expression to have been matched was REGEXP when TEMPLATE is called." (let loop ((point 0) (out '())) (if (string-match regexp string point) (loop (match-end) (cons (if (stringp template) (expand-last-match template) (template string)) (cons (substring string point (match-start)) out))) (if (null out) string (apply concat (nreverse (cons (substring string point) out))))))) (defun string-split (regexp string) "Return a list of substrings of STRING, each delimited by REGEXP." (let loop ((point 0) (parts '())) (if (string-match regexp string point) (loop (match-end) (cons (substring string point (match-start)) parts)) (nreverse (cons (substring string point) parts))))) (export-bindings '(string-replace string-split)) librep-0.90.2/lisp/rep/module-system.jl0000644000175200017520000001446611245011153016764 0ustar chrischris#| rep.module-system bootstrap $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.module-system)) (open-structures '(rep.lang.symbols rep.structures rep.data)) ;; rename the bindings required by exported macros (%define %make-structure make-structure) (%define %make-interface make-interface) (%define %parse-interface parse-interface) (%define %external-structure-ref external-structure-ref) (%define %alias-structure alias-structure) ;; module syntax (defmacro define-interface (name sig) "Associate the symbol NAME with the module interface SIG (in a separate interface-name namespace). An interface specification must be of the form: INTERFACE -> (export [ID...]) or NAME or (compound-interface [INTERFACE...]) or (structure-interface [STRUCTURE-NAME...]) where an ID is a symbol naming a top-level binding to export, and NAME is the name of an interface previously defined using define-interface. The `export' form adds top-level definitions ID... to the interface; the `compound-interface' clauses forms the union of the given interfaces." (list '%make-interface (list 'quote name) (list '%parse-interface (list 'quote sig)))) (defmacro structure (#!optional sig config . body) "Create a new module whose interface is SIG, whose configuration is defined by CONFIG (either a single clause, or a list of clauses), and whose definitions are defined by the list of forms BODY. See `define-interface' for the interface syntax, each configuration clause must have the syntax: CLAUSE -> (open [NAME...]) or (access [NAME...]) where NAME is the name of a module. Opening a module imports all of its exported definitions into the currently module, while accessing a module makes the exported definitions available from the current module using the `structure-ref' form." (unless (listp (car config)) (setq config (list config))) (list '%make-structure (list '%parse-interface (list 'quote sig)) (list* 'lambda nil (cons '(open rep.module-system) config)) (list* 'lambda nil body))) (defmacro define-structure (name #!optional sig config . body) "Create a module called NAME whose interface is SIG, whose configuration is defined by CONFIG (either a single clause, or a list of clauses), and whose definitions are defined by the list of forms BODY. See the `define-interface' and `structure' macros for descriptions of the interface and configuration clause syntaxes respectively." (unless (listp (car config)) (setq config (list config))) (list '%make-structure (list '%parse-interface (list 'quote sig)) (list* 'lambda nil (cons '(open rep.module-system) config)) (list* 'lambda nil body) (list 'quote name))) (defmacro define-structures (structs config . body) "Similar to `define-structure' except that multiple structures are created, each exporting a particular view of the underlying bindings. STRUCTS is a list defining the names and interfaces of the created modules, each item has the form `(NAME INTERFACE)'. CONFIG and BODY are exactly the same as in the `define-structure' syntax." (unless (listp (car config)) (setq config (list config))) (require 'rep.lang.backquote) (let ((tem (gensym))) `(let ((,tem (list (structure () ((export-all) ,@config) ,@body)))) ,@(mapcar (lambda (x) (let ((name (car x)) (interface (cadr x))) `(%make-structure (%parse-interface ',interface) (lambda () (open rep.module-system) (%open-structures ,tem)) () ',name))) structs)))) (defmacro define-structure-alias (to from) "Create a secondary name TO for the structure called FROM." (list '%alias-structure (list 'quote from) (list 'quote to))) (defmacro structure-ref (struct-name var-name) "Evaluates to the current value of the global binding of symbol VAR-NAME in the module called STRUCT-NAME. This structure must previously have been opened or accessed by the current module. When read, the syntax `FOO#BAR' expands to `(structure-ref FOO BAR)'." (list '%external-structure-ref (list 'quote struct-name) (list 'quote var-name))) ;; `%meta' structure used for configuring modules ;; helper definitions (defmacro structure-open names (list '%open-structures (list 'quote names))) (defmacro structure-access names (list '%access-structures (list 'quote names))) (defmacro set-binds () (list '%structure-set-binds (list '%current-structure) ''t)) (defmacro export-all () (list '%structure-exports-all (list '%current-structure) ''t)) (let ((meta-struct (make-structure '(open %open-structures access %access-structures set-binds %structure-set-binds export-all %structure-exports-all %current-structure quote) nil nil '%meta))) (structure-define meta-struct 'quote quote) (structure-define meta-struct 'open structure-open) (structure-define meta-struct '%open-structures open-structures) (structure-define meta-struct 'access structure-access) (structure-define meta-struct '%access-structures access-structures) (structure-define meta-struct 'set-binds set-binds) (structure-define meta-struct '%structure-set-binds structure-set-binds) (structure-define meta-struct 'export-all export-all) (structure-define meta-struct '%structure-exports-all structure-exports-all) (structure-define meta-struct '%current-structure current-structure)) ;; exports (export-bindings '(define-interface structure define-structure define-structures define-structure-alias structure-ref %make-structure %make-interface %parse-interface %external-structure-ref %alias-structure)) (export-bindings '(lambda validate-byte-code run-byte-code load)) librep-0.90.2/lisp/rep/data.jl0000644000175200017520000001225211245011153015055 0ustar chrischris#| rep.data bootstrap $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.data)) (open-structures '(rep.regexp rep.io.files)) (defun assoc-regexp (input alist #!optional fold-case) "Scan ALIST for an element whose car is a regular expression matching the string INPUT." (catch 'return (mapc (lambda (cell) (when (string-match (car cell) input nil fold-case) (throw 'return cell))) alist))) (defun setcar (cell x) (rplaca cell x) x) (defun setcdr (cell x) (rplacd cell x) x) ;; Some function pseudonyms (%define string= equal) (%define string< <) (defun member-if (fun lst) "Similar to the `member' function, except that the function FUN is called to test the elements for matches. If `(FUN ELT)' returns true, then the sublist starting with ELT is returned." (cond ((null lst) '()) ((fun (car lst)) lst) (t (member-if fun (cdr lst))))) (defun remove-if (pred lst) "Returns a new copy of LST with any elements removed for which (PRED ELT) returns true." (let loop ((rest lst) (out '())) (cond ((null rest) (nreverse out)) ((pred (car rest)) (loop (cdr rest) out)) (t (loop (cdr rest) (cons (car rest) out)))))) (defun remove-if-not (fun lst) "Returns a new copy of LST with any elements removed for which (PRED ELT) returns false." (remove-if (lambda (x) (not (fun x))) lst)) (defun remove (elt lst) "Returns a new copy of LST with all elements `equal' to ELT discarded." (remove-if (lambda (x) (equal x elt)) lst)) (defun remq (elt lst) "Returns a new copy of LST with all elements `eq' to ELT discarded." (remove-if (lambda (x) (eq x elt)) lst)) (export-bindings '(assoc-regexp setcar setcdr string= string< member-if remove-if remove-if-not remove remq)) ;; cons accessors (defun caar (x) (car (car x))) (defun cdar (x) (cdr (car x))) (defun cadr (x) (car (cdr x))) (defun cddr (x) (cdr (cdr x))) (defun caaar (x) (car (caar x))) (defun cdaar (x) (cdr (caar x))) (defun cadar (x) (car (cdar x))) (defun cddar (x) (cdr (cdar x))) (defun caadr (x) (car (cadr x))) (defun cdadr (x) (cdr (cadr x))) (defun caddr (x) (car (cddr x))) (defun cdddr (x) (cdr (cddr x))) (defun caaaar (x) (caar (caar x))) (defun cadaar (x) (cadr (caar x))) (defun caadar (x) (caar (cdar x))) (defun caddar (x) (cadr (cdar x))) (defun caaadr (x) (caar (cadr x))) (defun cadadr (x) (cadr (cadr x))) (defun caaddr (x) (caar (cddr x))) (defun cadddr (x) (cadr (cddr x))) (defun cdaaar (x) (cdar (caar x))) (defun cddaar (x) (cddr (caar x))) (defun cdadar (x) (cdar (cdar x))) (defun cdddar (x) (cddr (cdar x))) (defun cdaadr (x) (cdar (cadr x))) (defun cddadr (x) (cddr (cadr x))) (defun cdaddr (x) (cdar (cddr x))) (defun cddddr (x) (cddr (cddr x))) (export-bindings '(caar cdar cadr cddr caaar cdaar cadar cddar caadr cdadr caddr cdddr caaaar cadaar caadar caddar caaadr cadadr caaddr cadddr cdaaar cddaar cdadar cdddar cdaadr cddadr cdaddr cddddr)) ;; vector utils (defun vector->list (vec) (do ((i 0 (1+ i)) (out '() (cons (aref vec i) out))) ((= i (length vec)) (nreverse out)))) (defun list->vector (lst) (apply vector lst)) (export-bindings '(vector->list list->vector)) ;; guardian wrapper (defun make-guardian () "Create a new guardian. Guardians provide a means of protecting data objects from deallocation when they have no extant references. `make-guardian' returns a function representing a single guardian. Calling this function with a single argument adds that value to the list of objects protected by the guardian. Calling the function with no arguments returns one of the objects that would otherwise have been deallocated by the garbage collector, or false if no such objects exist that have not already been returned." (let ((g (make-primitive-guardian))) (lambda args (if args (primitive-guardian-push g (car args)) (primitive-guardian-pop g))))) (export-bindings '(make-guardian)) ;; autoloads (autoload 'string-upper-case-p "rep/data/string-util") (autoload 'string-lower-case-p "rep/data/string-util") (autoload 'string-capitalized-p "rep/data/string-util") (autoload 'string-upcase "rep/data/string-util") (autoload 'string-downcase "rep/data/string-util") (autoload 'capitalize-string "rep/data/string-util") (autoload 'mapconcat "rep/data/string-util") (autoload 'sort "rep/data/sort") (export-bindings '(string-upper-case-p string-lower-case-p string-capitalized-p string-upcase string-downcase capitalize-string mapconcat sort upcase-table downcase-table flatten-table)) librep-0.90.2/lisp/rep/vm/peephole.jl0000644000175200017520000004071211245011153016371 0ustar chrischris#| peephole.jl -- peephole optimizer for rep assembly code $Id$ Copyright (C) 1999, 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# ;; Most of the optimisation patterns in the peephole optimiser were ;; lifted from jwz's byte-optimize.el (XEmacs) (declare (unsafe-for-call/cc)) (define-structure rep.vm.peephole (export peephole-optimizer) (open rep rep.vm.bytecodes) ;; todo: ;; c{dd..d}r; car --> ca{dd..d}r ;; c{dd..d}r; cdr --> cd{dd..d}r ;; shift the instruction window (defmacro shift () '(progn (setq point (cdr point)) (setq insn0 insn1) (setq insn1 insn2) (setq insn2 (nth 3 point)))) ;; refill the window (defmacro refill () '(progn (setq insn0 (nth 1 point)) (setq insn1 (nth 2 point)) (setq insn2 (nth 3 point)))) ;; delete the first instruction in the window (defmacro del-0 () '(progn (rplacd point (nthcdr 2 point)) (setq insn0 insn1) (setq insn1 insn2) (setq insn2 (nth 3 point)))) ;; delete the second instruction in the window (defmacro del-1 () '(progn (rplacd (cdr point) (nthcdr 3 point)) (setq insn1 insn2) (setq insn2 (nth 3 point)))) ;; delete the third instruction in the window (defmacro del-2 () '(progn (rplacd (nthcdr 2 point) (nthcdr 4 point)) (setq insn2 (nth 3 point)))) ;; delete the first two instructions in the window (defmacro del-0-1 () '(progn (rplacd point (nthcdr 3 point)) (setq insn0 insn2) (setq insn1 (nth 2 point)) (setq insn2 (nth 3 point)))) ;; delete the second two instructions in the window (defmacro del-1-2 () '(progn (rplacd (cdr point) (nthcdr 4 point)) (setq insn1 (nth 2 point)) (setq insn2 (nth 3 point)))) ;; delete all instructions in the window (defmacro del-0-1-2 () '(progn (rplacd point (nthcdr 4 point)) (refill))) ;; debugging (defmacro before () `(format standard-error "before: [%S %S %S]\n" (nth 1 point) (nth 2 point) (nth 3 point))) (defmacro after () `(format standard-error "after: [%S %S %S]\n" (nth 1 point) (nth 2 point) (nth 3 point))) ;; run the optimiser over CODE-STRING, modifying and returning it ;; returns (CODE . EXTRA-STACK) (defun peephole-optimizer (code-string) (let ((keep-going t) (extra-stack 0) point insn0 insn1 insn2 tem) ;; add an extra cons cell so we can always refer to the ;; cdr of the intsruction _before_ insn0, this makes it ;; easy to delete instructions (setq code-string (cons 'start code-string)) (while keep-going (setq keep-going nil) (setq point code-string) (refill) (while insn0 ;;(format standard-error "iter: %S\n\n" code-string) (cond ;; ; pop --> ;; ; pop --> pop ;; ; pop --> pop; pop ((and (eq (car insn1) 'pop) (memq (car insn0) byte-side-effect-free-insns)) (setq tem (aref byte-insn-stack-delta (bytecode-ref (car insn0)))) (cond ((= tem 1) (del-0-1) (setq keep-going t)) ((= tem 0) (del-0) (setq keep-going t)) ((= tem -1) (rplaca insn0 'pop) (rplacd insn0 nil) (setq keep-going t)))) ;; {push,dup}; setn #X; refn #X ;; --> {push,dup}; setn #X; {push, dup} ;; {push,dup}; bind X; refn #0 ;; --> {push,dup}; bind X; {push, dup} ;; {push,dup}; slot-set #X; slot-ref #X ;; --> {push,dup}; slot-set #X; {push, dup} ((and (or (and (eq (car insn1) 'setn) (eq (car insn2) 'refn) (eq (cadr insn1) (cadr insn2))) (and (eq (car insn1) 'bind) (eq (car insn2) 'refn) (eq (cadr insn2) 0)) (and (eq (car insn1) 'slot-set) (eq (car insn2) 'slot-ref) (eq (cadr insn1) (cadr insn2)))) (or (eq (car insn0) 'dup) (eq (car insn0) 'push))) (rplaca insn2 (car insn0)) (rplacd insn2 (cdr insn0)) (setq keep-going t)) ;; setn #X; refn #X --> dup; setn #X ;; bind; refn #0 --> dup; bind ;; slot-set #X; slot-ref #X --> dup; slot-set #X ((or (and (eq (car insn0) 'setn) (eq (car insn1) 'refn) (eq (cadr insn0) (cadr insn1))) (and (eq (car insn0) 'bind) (eq (car insn1) 'refn) (eql (cadr insn1) 0)) (and (eq (car insn0) 'slot-set) (eq (car insn1) 'slot-ref) (eq (cadr insn0) (cadr insn1)))) (rplaca insn1 (car insn0)) (rplacd insn1 (cdr insn0)) (rplaca insn0 'dup) (rplacd insn0 nil) ;; this might require extra stack space (setq extra-stack 1) (setq keep-going t)) ;; dup; {,} X; pop --> {,} X ((and (eq (car insn0) 'dup) (or (memq (car insn1) byte-varset-insns) (memq (car insn1) byte-varbind-insns)) (eq (car insn2) 'pop)) (rplaca insn2 (car insn1)) (rplacd insn2 (cdr insn1)) (del-0-1) (setq keep-going t)) ;; X; X --> X; dup ((and (memq (car insn0) byte-varref-insns) (eq (car insn1) (car insn0)) (eq (cadr insn0) (cadr insn1))) (rplaca insn1 'dup) (rplacd insn1 nil) (setq keep-going t)) ;; X; X --> deleted ((or (and (eq (car insn0) 'refn) (eq (car insn1) 'setn) (eql (cadr insn0) (cadr insn1))) (and (eq (car insn0) 'refg) (eq (car insn1) 'setg) (eq (cadr insn0) (cadr insn1))) (and (eq (car insn0) 'slot-ref) (eq (car insn1) 'slot-set) (eq (cadr insn0) (cadr insn1)))) (del-0-1) (setq keep-going t)) ;; c?r; c?r --> c??r ((and (memq (car insn0) '(car cdr)) (memq (car insn1) '(car cdr))) (rplaca insn1 (if (eq (car insn0) 'car) (if (eq (car insn1) 'car) 'caar 'cdar) (if (eq (car insn1) 'car) 'cadr 'cddr))) (del-0) (setq keep-going t)) ;; test-scm; scm-test --> deleted ;; test-scm-f; scm-test --> deleted ;; [ these are only possible because scm-test is only used ;; for `cond' tests, not for its actual value ] ((and (memq (car insn0) '(test-scm test-scm-f)) (eq (car insn1) 'scm-test)) (del-0-1) (setq keep-going t)) ;; push 1; sub --> dec ;; push -1; sub --> inc ;; push 1; add --> inc ;; push -1; add --> dec ;; [ XXX these and more should be handled at a higher level ] ((and (eq (car insn0) 'push) (memq (car insn1) '(sub add)) (memql (cadr insn0) '(1 -1))) (let ((new (if (eql (cadr insn0) 1) (if (eq (car insn1) 'sub) 'dec 'inc) (if (eq (car insn1) 'sub) 'inc 'dec)))) (rplaca insn1 new) (del-0) (setq keep-going t))) ;; push 0; {add,sub} --> ((and (equal insn0 '(push 0)) (memq (car insn1) '(add sub))) (del-0-1) (setq keep-going t)) ;; push 0; num-eq --> zerop ((and (equal insn0 '(push 0)) (eq (car insn1) 'num-eq)) (rplaca insn1 'zerop) (del-0) (setq keep-going t)) ;; zerop; not --> not-zero-p ((and (eq (car insn0) 'zerop) (eq (car insn1) 'not)) (rplaca insn1 'not-zero-p) (del-0) (setq keep-going t)) ;; jmp X; X: --> X: ((and (eq (car insn0) 'jmp) (eq (cadr insn0) insn1)) (del-0) (setq keep-going t)) ;; {jn,jt} X; X: --> pop; X: ((and (memq (car insn0) '(jn jt)) (eq (cadr insn0) insn1)) (rplaca insn0 'pop) (rplacd insn0 nil) (setq keep-going t)) ;; {jpt,jpn} X; pop --> {jt,jn} X ((and (memq (car insn0) '(jpt jpn)) (eq (car insn1) 'pop)) (rplaca insn0 (if (eq (car insn0) 'jpt) 'jt 'jn)) (del-1) (setq keep-going t)) ;; not; {jn,jt} X --> {jt,jn} X ((and (eq (car insn0) 'not) (memq (car insn1) '(jn jt))) (rplaca insn1 (if (eq (car insn1) 'jn) 'jt 'jn)) (del-0) (setq keep-going t)) ;; jt X; (push ()) --> jpt X ((and (eq (car insn0) 'jt) (equal insn1 '(push ()))) (rplaca insn0 'jpt) (del-1) (setq keep-going t)) ;; {jn,jt} X; jmp Y; X: --> {jt,jn} Y; X: ((and (memq (car insn0) '(jn jt)) (eq (car insn1) 'jmp) (eq (cadr insn0) insn2)) (rplaca insn1 (if (eq (car insn0) 'jn) 'jt 'jn)) (del-0) (setq keep-going t)) ;; (push X); X; --> whatever ((and (eq (car insn0) 'push) (memq (car insn1) byte-conditional-jmp-insns)) (let* ;; only way to get a nil constant is through `(push ())' ((is-nil (equal insn0 '(push ()))) (is-t (not is-nil))) (cond ((or (and is-nil (eq (car insn1) 'jn)) (and is-t (eq (car insn1) 'jt)) (and is-nil (eq (car insn1) 'jpn)) (and is-t (eq (car insn1) 'jpt))) ;; nil; jn X --> jmp X ;; t; jt X --> jmp X ;; nil; jpn X --> jmp X ;; t; jpt X --> jmp X (rplaca insn1 'jmp) (del-0)) ((or (and is-nil (eq (car insn1) 'jt)) (and is-t (eq (car insn1) 'jn)) (and is-t (eq (car insn1) 'jnp)) (and is-nil (eq (car insn1) 'jtp))) ;; nil; jt X --> ;; t; jn X --> ;; t; jnp X --> ;; nil; jtp X --> (del-0-1)) ((or (and is-nil (eq (car insn1) 'jnp)) (and is-t (eq (car insn1) 'jtp))) ;; nil; jnp X --> nil; jmp X ;; t; jtp X --> t; jmp X (rplaca insn1 'jmp)) ((or (and is-t (eq (car insn1) 'jpn)) (and is-nil (eq (car insn1) 'jpt))) ;; t; jpn X --> t ;; nil; jpt X --> nil (del-1)) (t (error "Unhandled contional jump case"))) (setq keep-going t))) ;; ; unbind ---> unbind; op ((and (eq (car insn1) 'unbind) (memq (car insn0) byte-varref-free-insns)) (let ((op (car insn0)) (arg (cdr insn0))) (rplaca insn0 (car insn1)) (rplacd insn0 (cdr insn1)) (rplaca insn1 op) (rplacd insn1 arg) (setq keep-going t))) ;; X; unbind --> pop; unbind ((and (memq (car insn0) byte-varbind-insns) (eq (car insn1) 'unbind)) (rplaca insn0 'pop) (rplacd insn0 nil) (setq keep-going t)) ;; init-bind; unbind --> deleted ((and (eq (car insn0) 'init-bind) (eq (car insn1) 'unbind)) (del-0-1) (setq keep-going t)) ;; init-bind; {return,unbindall} --> {return,unbindall} ((and (eq (car insn0) 'init-bind) (memq (car insn1) '(return unbindall))) (del-0) (setq keep-going t)) ;; unbind; return --> return ((and (eq (car insn0) 'unbind) (eq (car insn1) 'return)) (del-0) (setq keep-going t)) ;; X; dup... ; X --> X; dup...; dup ((and (memq (car insn0) byte-varref-insns) (eq (car insn1) 'dup)) (let ((tem (nthcdr 2 point))) (while (eq (car (car tem)) 'dup) (setq tem (cdr tem))) (when (equal (car tem) insn0) (rplaca (car tem) 'dup) (rplacd (car tem) nil) (setq keep-going t)))) ;; X: Y: --> X: [s/X/Y/] ((and (symbolp insn0) (symbolp insn1)) (let loop ((rest (cdr code-string))) (when rest (when (and (eq (cadar rest) insn1) (or (memq (caar rest) byte-jmp-insns) (eq (caar rest) 'push-label))) (rplaca (cdar rest) insn0)) (loop (cdr rest)))) (del-1) (setq keep-going t)) ;; [unused] X: --> deleted ((and (symbolp insn0) (let loop ((rest (cdr code-string))) (cond ((null rest) t) ((and (eq (cadar rest) insn0) (or (memq (caar rest) byte-jmp-insns) (eq (caar rest) 'push-label))) nil) (t (loop (cdr rest)))))) (del-0) (setq keep-going t)) ;; jmp X; ... Y: --> jmp X; Y: ;; return; ... Y: --> return; Y: ((and (memq (car insn0) '(jmp ejmp return)) insn1 (not (symbolp insn1))) (setq tem (nthcdr 2 point)) (while (and tem (not (symbolp (car tem)))) (setq tem (cdr tem))) (unless (eq tem (nthcdr 2 point)) (rplacd (cdr point) tem) (refill) (setq keep-going t))) ;; j* X; ... X: jmp Y --> j* Y; ... X: jmp Y ((and (memq (car insn0) byte-jmp-insns) (setq tem (or (memq (cadr insn0) (cdr code-string)) (error "Can't find jump destination: %s, %s" insn0 (cdr code-string)))) (setq tem (car (cdr tem))) (eq (car tem) 'jmp) (not (eq (cadr insn0) (cadr tem)))) (rplacd insn0 (cdr tem)) (setq keep-going t)) ;; jmp X; ... X: return --> return; ... X: return ((and (eq (car insn0) 'jmp) (setq tem (or (memq (cadr insn0) (cdr code-string)) (error "Can't find jump destination: %s, %s" insn0 (cdr code-string)))) (setq tem (car (cdr tem))) (eq (car tem) 'return)) (rplaca insn0 'return) (rplacd insn0 nil) (setq keep-going t)) ;; {jnp,jtp} X; ... X: Y --> whatever ((and (memq (car insn0) '(jnp jtp)) (setq tem (cdr (or (memq (cadr insn0) (cdr code-string)) (error "Can't find jump destination: %s, %s" insn0 (cdr code-string))))) (car tem) (memq (car (car tem)) byte-conditional-jmp-insns)) (let ((jmp (car tem)) need-new-label) (if (eq (car insn0) 'jtp) (cond ((memq (car jmp) '(jpt jt)) ;; jtp X; ... X: jpt Y --> jt Y; ... ;; jtp X; ... X: jt Y --> jt Y; ... (rplaca insn0 'jt)) ((eq (car jmp) 'jpn) ;; jtp X; ... X: jpn Y --> jpt Z; ... X: jpn Y; Z: (rplaca insn0 'jpt) (setq need-new-label t)) ((memq (car jmp) '(jn jnp)) ;; jtp X; ... X: jn Y --> jt Z; ... X: jpn Y; Z: ;; jtp X; ... X: jnp Y --> jt Z; ... X: jpn Y; Z: (rplaca insn0 'jt) (setq need-new-label t)) ((eq (car jmp) 'jtp) ;; jtp X; ... X: jtp Y --> jtp Y; ... (rplaca insn0 'jtp))) (cond ((eq (car jmp) 'jpt) ;; jnp X; ... X: jpt Y --> jn Z; ... X: jpt Y; Z: (rplaca insn0 'jnp) (setq need-new-label t)) ((memq (car jmp) '(jpn jn)) ;; jnp X; ... X: jpn Y --> jn Y ... ;; jnp X; ... X: jn Y --> jn Y ... (rplaca insn0 'jn)) ((memq (car jmp) '(jt jtp)) ;; jnp X; ... X: jt Y --> jn Z; ... X: jt Y; Z: ;; jnp X; ... X: jtp Y --> jn Z; ... X: jt Y; Z: (rplaca insn0 'jn) (setq need-new-label t)) ((eq (car jmp) 'jnp) ;; jnp X; ... X: jnp Y --> jnp Y ... (rplaca insn0 'jnp)))) (if (not need-new-label) (rplaca (cdr insn0) (cadr jmp)) ;; add label `Z:' following the second jump (let ((label (cons (gensym) (cdr tem)))) (rplaca (cdr insn0) (car label)) (rplacd tem label))) (setq keep-going t))) ;; {jpt,jpn} X; jmp Y; X: --> {jnp,jtp} Y; X: ;; {jtp,jnp} X; jmp Y; X: --> {jpn,jpt} Y; X: ((and (eq (car insn1) 'jmp) (memq (car insn0) '(jpt jpn jtp jnp)) (eq (cadr insn0) insn2)) (rplaca insn1 (case (car insn0) ((jpt) 'jnp) ((jpn) 'jtp) ((jtp) 'jpn) ((jnp) 'jpt))) (del-0) (setq keep-going t)) ;; ; jmp X; ... X: Y --> whatever ;; ;; [ this should be handled already, by (1) changing the ;; first jump, then by (2) dereferencing the constant ] ;; jmp X: Y: ... X: Y --> ??? ) ;; shift in the next instruction (shift))) ;; now do one last pass, looking for simple things (setq point code-string) (refill) (while insn0 (cond ;; push X; {,} Y; push X ;; --> push X; dup; {,} Y ((and (eq (car insn0) 'push) (or (memq (car insn1) byte-varset-insns) (memq (car insn1) byte-varbind-insns)) (equal insn0 insn2)) (rplaca insn2 (car insn1)) (rplacd insn2 (cdr insn1)) (rplaca insn1 'dup) (rplacd insn1 nil) (setq extra-stack 1) (setq keep-going t)) ;; push X; {dup,push X}... --> push X; dup... ;; X; {dup, X}... --> X; dup... ((or (eq (car insn0) 'push) (memq (car insn0) byte-varref-insns)) (setq tem (nthcdr 2 point)) (while (or (eq (caar tem) 'dup) (equal (car tem) insn0)) (rplaca (car tem) 'dup) (rplacd (car tem) nil) (setq tem (cdr tem))))) (shift)) ;; drop the extra cons we added (cons (cdr code-string) extra-stack)))) librep-0.90.2/lisp/rep/vm/disassembler.jl0000644000175200017520000001653211245011153017250 0ustar chrischris;; disassembler.jl -- Disassembles compiled Lisp functions ;; $Id$ ;; Copyright (C) 1993, 1994 John Harper ;; This file is part of Jade. ;; Jade is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; Jade is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with Jade; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (declare (unsafe-for-call/cc)) (define-structure rep.vm.disassembler (export disassemble disassemble-1) (open rep rep.vm.bytecodes) (define-structure-alias disassembler rep.vm.disassembler) ;; Lookup table of strings naming instructions (define disassembler-opcodes [ "slot-ref" nil nil nil nil nil nil nil ; #x00 "call" nil nil nil nil nil nil nil "push" nil nil nil nil nil nil nil ; #x10 "refg" nil nil nil nil nil nil nil "setg" nil nil nil nil nil nil nil ; #x20 "setn" nil nil nil nil nil nil nil "slot-set" nil nil nil nil nil nil nil ; #x30 "refn" nil nil nil nil nil nil nil "ref" "%set" "fluid-ref" "enclose" "init-bind" "unbind" "dup" "swap" ; #x40 "pop" "push\t()" "push\tt" "cons" "car" "cdr" "rplaca" "rplacd" "nth" "nthcdr" "aset" "aref" "length" "bind" "add" "neg" "sub" ; #x50 "mul" "div" "rem" "lnot" "not" "lor" "land" "equal" "eq" "structure-ref" "scm-test" "gt" "ge" "lt" "le" ; #x60 "inc" "dec" "ash" "zerop" "null" "atom" "consp" "listp" "numberp" "stringp" "vectorp" "catch" "throw" "binderr" "return" "unbindall" ; #x70 "boundp" "symbolp" "get" "put" "errorpro" "signal" "quotient" "reverse" "nreverse" "assoc" "assq" "rassoc" "rassq" "last" "mapcar" "mapc" ; #x80 "member" "memq" "delete" "delq" "delete-if" "delete-if-not" "copy-sequence" "sequencep" "functionp" "special-form-p" "subrp" "eql" "lxor" "max" "min" "filter" ; #x90 "macrop" "bytecodep" "pushi\t0" "pushi\t1" "pushi\t2" "pushi\t-1" "pushi\t-2" "pushi\t%d" "pushi\t%d" "pushi\t%d" "caar" "cadr" "cdar" "cddr" "caddr" "cadddr" ; #xa0 "caddddr" "cadddddr" "caddddddr" "cadddddddr" "floor" "ceiling" "truncate" "round" "apply" "forbid" "permit" "exp" "log" "sin" "cos" "tan" ; #xb0 "sqrt" "expt" "swap2" "mod" "make-closure" "unbindall-0" "closurep" "pop-all" "fluid-set" "fluid-bind" "memql" "num-eq" "test-scm" "test-scm-f" "%define" "spec-bind" ; #xc0 "set" "required-arg" "optional-arg" "rest-arg" "not-zero-p" "keyword-arg" "optional-arg*" "keyword-arg*" nil nil nil nil nil nil nil nil ; #xd0 nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil ; #xe0 nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil ; #xf0 "ejmp\t%d" "jpn\t%d" "jpt\t%d" "jmp\t%d" "jn\t%d" "jt\t%d" "jnp\t%d" "jtp\t%d" ]) (defun disassemble-1 (code-string consts stream #!optional depth) (unless depth (setq depth 0)) (let ((i 0) (indent (make-string depth)) c arg op) (while (< i (length code-string)) (setq c (aref code-string i)) (format stream "\n%s%d\t\t" indent i) (cond ((< c (bytecode last-with-args)) (setq op (logand c #xf8)) (cond ((< (logand c #x07) 6) (setq arg (logand c #x07))) ((= (logand c #x07) 6) (setq i (1+ i) arg (aref code-string i))) (t (setq arg (logior (ash (aref code-string (1+ i)) 8) (aref code-string (+ i 2))) i (+ i 2)))) (cond ((= op (bytecode call)) (format stream "call\t#%d" arg)) ((= op (bytecode push)) (let ((argobj (aref consts arg))) (if (or (and (consp argobj) (eq (car argobj) 'byte-code)) (bytecodep argobj)) (progn (format stream "push\t[%d] bytecode...\n" arg) (disassemble argobj stream (1+ depth))) (format stream "push\t[%d] %S" arg (aref consts arg))))) ((= op (bytecode bind)) (format stream "bind\t[%d] %S" arg (aref consts arg))) ((= op (bytecode refn)) (format stream "refn\t#%d" arg)) ((= op (bytecode setn)) (format stream "setn\t#%d" arg)) ((= op (bytecode slot-ref)) (format stream "slot-ref #%d" arg)) ((= op (bytecode slot-set)) (format stream "slot-set #%d" arg)) ((= op (bytecode refg)) (format stream "refg\t[%d] %S" arg (aref consts arg))) ((= op (bytecode setg)) (format stream "setg\t[%d] %S" arg (aref consts arg))))) ((> c (bytecode last-before-jmps)) (setq arg (logior (ash (aref code-string (1+ i)) 8) (aref code-string (+ i 2))) op c i (+ i 2)) (format stream (aref disassembler-opcodes op) arg)) ((= c (bytecode pushi)) (setq arg (aref code-string (1+ i))) (setq i (1+ i)) (when (>= arg 128) (setq arg (- (- 256 arg)))) (format stream (aref disassembler-opcodes c) arg)) ((or (= c (bytecode pushi-pair-neg)) (= c (bytecode pushi-pair-pos))) (setq arg (logior (ash (aref code-string (1+ i)) 8) (aref code-string (+ i 2)))) (setq i (+ i 2)) (when (= c (bytecode pushi-pair-neg)) (setq arg (- arg))) (format stream (aref disassembler-opcodes c) arg)) (t (if (setq op (aref disassembler-opcodes c)) (write stream op) (format stream "" c)))) (setq i (1+ i))) (write stream ?\n))) ;;;###autoload (defun disassemble (arg #!optional stream depth) "Dissasembles ARG, with output to STREAM, or the *disassembly* buffer." (interactive "aFunction to disassemble:") (let (code-string consts stack (print-escape t)) (unless stream (if (featurep 'jade) (progn (declare (bound open-buffer clear-buffer goto-other-view goto-buffer insert start-of-buffer goto)) (setq stream (open-buffer "*disassembly*")) (clear-buffer stream) (goto-other-view) (goto-buffer stream) (insert "\n" stream) (goto (start-of-buffer)) (setq stream (cons stream t))) (setq stream standard-output))) (unless depth (setq depth 0)) (when (zerop depth) (if (symbolp arg) (progn (format stream "Disassembly of function %s:\n\n" arg) (setq arg (symbol-value arg))) (format stream "Disassembly of %S:\n\n" arg))) (when (closurep arg) (setq arg (closure-function arg))) (cond ((and (consp arg) (eq (car arg) 'run-byte-code)) (setq code-string (nth 1 arg) consts (nth 2 arg) stack (nth 3 arg))) (t (setq code-string (aref arg 0) consts (aref arg 1)) (when (zerop depth) (let ((spec (and (> (length arg) 4) (aref arg 4))) (doc (and (> (length arg) 3) (aref arg 3)))) (when spec (format stream "Interactive spec: %S\n" spec)) (when doc (format stream "Doc string: %S\n" doc))) (setq stack (aref arg 2))))) (when (zerop depth) (format stream "%d bytes, %d constants, and (%d,%d,%d) stack slots\n" (length code-string) (length consts) (logand stack #x3ff) (logand (ash stack -10) #x3ff) (ash stack -20))) (disassemble-1 code-string consts stream depth)))) librep-0.90.2/lisp/rep/vm/compiler.jl0000644000175200017520000003033611245011153016403 0ustar chrischris#| compiler.jl -- compiler for Lisp files/forms $Id$ Copyright (C) 1993, 1994, 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.vm.compiler (export compile-file compile-directory compile-lisp-lib compile-lib-batch compile-batch compile-assembler compile-compiler compile-function compile-form compile-module) (open rep rep.structures rep.system rep.io.files rep.regexp rep.vm.compiler.basic rep.vm.compiler.bindings rep.vm.compiler.modules rep.vm.bytecodes) (define-structure-alias compiler rep.vm.compiler) (define assembler-sources '(rep.vm.peephole rep.vm.assembler rep.vm.bytecodes rep.vm.bytecode-defs)) (define compiler-sources '(rep.vm.compiler rep.vm.compiler.basic rep.vm.compiler.bindings rep.vm.compiler.inline rep.vm.compiler.lap rep.vm.compiler.modules rep.vm.compiler.rep rep.vm.compiler.src rep.vm.compiler.utils)) ;; regexp matching library files not to compile (define lib-exclude-re "\\bautoload\\.jl$|^CVS$") ;; map languages to compiler modules (put 'rep 'compiler-module 'rep.vm.compiler.rep) (put 'no-lang 'compiler-module 'rep.vm.compiler.no-lang) ;; since we default to rep langauge.. (intern-structure 'rep.vm.compiler.rep) #| Notes: Modules ======= The compiler groks the rep module language, notably it will correctly resolve (and perhaps inline) references to features of the rep language, but only if the module header had `(open rep)' and the feature hasn't been shadowed by a second module. The compiler has also been written to enable other language dialects to be compiled, for example `(open scheme)' could mark code as being scheme. Several properties are set on the name of the module to handle this: compiler-handler-property compiler-transform-property compiler-foldablep compiler-pass-1 compiler-pass-2 see the compiler-rep module for example usage. Instruction Encoding ==================== Instructions which get an argument (with opcodes of zero up to `op-last-with-args') encode the type of argument in the low 3 bits of their opcode (this is why these instructions take up 8 opcodes). A value of 0 to 5 (inclusive) is the literal argument, value of 6 means the next byte holds the argument, or a value of 7 says that the next two bytes are used to encode the argument (in big- endian form, i.e. first extra byte has the high 8 bits) All instructions greater than the `op-last-before-jmps' are branches, currently only absolute destinations are supported, all branch instructions encode their destination in the following two bytes (also in big-endian form). Any opcode between `op-last-with-args' and `op-last-before-jmps' is a straightforward single-byte instruction. The machine simulated by lispmach.c is a simple stack-machine, each call to the byte-code interpreter gets its own stack; the size of stack needed is calculated by the compiler. If you hadn't already noticed I based this on the Emacs version 18 byte-compiler. Constants ========= `defconst' forms have to be used with some care. The compiler assumes that the value of the constant is always the same, whenever it is evaluated. It may even be evaluated more than once. In general, any symbols declared as constants (by defconst) have their values set in stone. These values are hard-coded into the compiled byte-code. Also, the value of a constant-symbol is *not* likely to be eq to itself! Use constants as you would use macros in C, i.e. to define values which have to be the same throughout a module. For example, this compiler uses defconst forms to declare the instruction opcodes. If you have doubts about whether or not to use constants -- don't; it may lead to subtle bugs. Inline Functions ================ The defsubst macro allows functions to be defined which will be open- coded into any callers at compile-time. Of course, this can have a similar effect to using a macro, with some differences: * Macros can be more efficient, since the formal parameters are only bound at compile time. But, this means that the arguments may be evaluated more than once, unlike a defsubst where applied forms will only ever be evaluated once, when they are bound to a formal parameter * Macros are more complex to write; though the backquote mechanism can help a lot with this * defsubst's are more efficient in uncompiled code, but this shouldn't really be a consideration, unless code is being generated on the fly Warnings ======== Currently warnings are generated for the following situations: * Functions or special variables are multiply defined * Undefined variables are referenced or set ("undefined" means not defined by defvar, not currently (lexically) bound, and not boundp at compile-time) * Undefined functions are referenced, that is, not defun'd and not fboundp at compile-time * Functions are called with an incorrect number of arguments, either too few required parameters, or too many supplied to a function without a #!rest keyword * Unreachable code in conditional statements * Possibly some other things... TODO ==== Obviously, more optimisation of output code. This isdone in two stages, (1) source code transformations, (2) optimisation of intermediate form (basically bytecode, but as a list of operations and symbolic labels, i.e. the basic blocks) Both (1) and (2) are already being done, but there's probably scope for being more aggressive, especially at the source code (parse tree) level. Optimisation would be a lot more profitable if variables were lexically scoped, perhaps I should switch to lexical scoping. It shouldn't break anything much, since the compiler will give warnings if any funky dynamic-scope tricks are used without the symbols being defvar'd (and therefore declared special/dynamic) The constant folding code is a bit simplistic. For example the form (+ 1 2 3) would be folded to 6, but (+ 1 2 x) *isn't* folded to (+ 3 x) as we would like. This is due to the view of folded functions as ``side-effect-free constant black boxes''. |# ;; 8/11/99: lexical scoping has arrived.. and it works.. and the ;; performance hit is minimal ;; so I need to do all those funky lexical scope optimisation now.. ;;; Top level entrypoints (define (report-progress filename) (message (format nil "(compiling %s)" filename) t)) (defun compile-file (file-name) "Compiles the file of jade-lisp code FILE-NAME into a new file called `(concat FILE-NAME ?c)' (ie, `foo.jl' => `foo.jlc')." (interactive "fLisp file to compile:") (let ((temp-file (make-temp-name)) src-file dst-file body header) (let-fluids ((current-file file-name) (unsafe-for-call/cc nil)) (call-with-frame (lambda () (unwind-protect (progn (when (setq src-file (open-file file-name 'read)) (unwind-protect ;; Read the file, ensuring we record line numbers (call-with-lexical-origins (lambda () ;; First check for `#! .. !#' at start of file (if (and (= (read-char src-file) ?#) (= (read-char src-file) ?!)) (let ((out (make-string-output-stream)) tem) (write out "#!") (catch 'done (while (setq tem (read-char src-file)) (write out tem) (when (and (= tem ?!) (setq tem (read-char src-file))) (write out tem) (when (= tem ?#) (throw 'done t))))) (setq header (get-output-stream-string out))) (seek-file src-file 0 'start)) ;; Scan for top-level definitions in the file. ;; Also eval require forms (for macro defs) (condition-case nil (while t (setq body (cons (read src-file) body))) (end-of-stream)))) (close-file src-file)) (setq body (compile-module-body (nreverse body) t t)) (when (setq dst-file (open-file temp-file 'write)) (condition-case error-info (unwind-protect (progn ;; write out the results (when header (write dst-file header)) (format dst-file ";; Source file: %s\n(validate-byte-code %d %d)\n" file-name bytecode-major bytecode-minor) (mapc (lambda (form) (when form (print form dst-file))) body) (write dst-file ?\n)) (close-file dst-file)) (error ;; Be sure to remove any partially written dst-file. ;; Also, signal the error again so that the user sees it. (delete-file temp-file) ;; Hack to signal error without entering the ;; debugger (again) (throw 'error error-info))) ;; Copy the file to its correct location, and copy ;; permissions from source file (let ((real-name (concat file-name (if (string-match "\\.jl$" file-name) ?c ".jlc")))) (copy-file temp-file real-name) (set-file-modes real-name (file-modes file-name))) t))) (when (file-exists-p temp-file) (delete-file temp-file)))))))) (defun compile-directory (dir-name #!optional force-p exclude-re) "Compiles all Lisp files in the directory DIRECTORY-NAME whose object files are either older than their source file or don't exist. If FORCE-P is true every lisp file is recompiled. Any subdirectories of DIR-NAME are recursed into. EXCLUDE-RE may be a regexp matching files which shouldn't be compiled." (interactive "DDirectory of Lisp files to compile:\nP") (mapc (lambda (file) (unless (or (and exclude-re (string-match exclude-re file)) (eq (aref file 0) #\.)) (let ((abs-file (expand-file-name file dir-name))) (cond ((file-directory-p abs-file) (compile-directory abs-file force-p exclude-re)) ((string-match "\\.jl$" file) (let* ((c-name (concat abs-file ?c))) (when (or force-p (not (file-exists-p c-name)) (file-newer-than-file-p abs-file c-name)) (report-progress abs-file) (compile-file abs-file)))))))) (directory-files dir-name)) t) (defun compile-lisp-lib (#!optional directory force-p) "Recompile all out of date files in the lisp library directory. If FORCE-P is true it's as though all files were out of date. This makes sure that all doc strings are written to their special file and that files which shouldn't be compiled aren't." (interactive "\nP") (let ((*compiler-write-docs* t)) (compile-directory (or directory lisp-lib-directory) force-p lib-exclude-re))) ;; Call like `rep --batch -l compiler -f compile-lib-batch [--force] DIR' (defun compile-lib-batch () (let ((force (when (equal (car command-line-args) "--force") (setq command-line-args (cdr command-line-args)) t)) (dir (car command-line-args))) (setq command-line-args (cdr command-line-args)) (compile-lisp-lib dir force))) ;; Call like `rep --batch -l compiler -f compile-batch [--write-docs] FILES...' (defun compile-batch () (when (get-command-line-option "--write-docs") (setq *compiler-write-docs* t)) (while command-line-args (compile-file (car command-line-args)) (setq command-line-args (cdr command-line-args)))) (defun bootstrap (sources) (let ((*compiler-write-docs* t)) (mapc (lambda (package) (let ((file (expand-file-name (concat (structure-file package) ".jl") lisp-lib-directory))) (when (or (not (file-exists-p (concat file ?c))) (file-newer-than-file-p file (concat file ?c))) (report-progress file) (compile-file file)))) sources))) ;; Used when bootstrapping from the Makefile, recompiles compiler.jl if ;; it's out of date (defun compile-compiler () (bootstrap compiler-sources)) (defun compile-assembler () (bootstrap assembler-sources))) librep-0.90.2/lisp/rep/vm/bytecodes.jl0000644000175200017520000000763211245011153016555 0ustar chrischris#| bytecodes.jl -- Bytecodes for rep virtual machine $Id$ Copyright (C) 1993, 1994, 2000 John Harper This file is part of Librep. Librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.vm.bytecodes (export bytecode-major bytecode-minor bytecode bytecode-ref byte-max-1-byte-arg byte-max-2-byte-arg byte-max-3-byte-arg byte-two-byte-insns byte-three-byte-insns byte-insn-stack-delta byte-constant-insns byte-varref-free-insns byte-side-effect-free-insns byte-conditional-jmp-insns byte-jmp-insns byte-opcodes-with-constants byte-varref-insns byte-varset-insns byte-varbind-insns byte-nth-insns byte-nthcdr-insns) (open rep rep.vm.bytecode-defs) ;;; Description of instruction set for when optimising ;; list of instructions that always have a 1-byte argument following them (define byte-two-byte-insns (list (bytecode pushi))) ;; list of instructions that always have a 2-byte argument following them (define byte-three-byte-insns (list (bytecode pushi-pair-neg) (bytecode pushi-pair-pos) (bytecode ejmp) (bytecode jpn) (bytecode jpt) (bytecode jmp) (bytecode jn) (bytecode jt) (bytecode jnp) (bytecode jtp))) ;; list of instructions that are both side-effect free and don't ;; reference any variables. Also none of these may ever raise exceptions (define byte-varref-free-insns '(dup push cons car cdr eq equal zerop not-zero-p null atom consp listp numberp stringp vectorp symbolp sequencep functionp special-form-p subrp eql macrop bytecodep caar cadr cdar cadddr caddddr cadddddr caddddddr cadddddddr scm-test test-scm test-scm-f)) ;; list of instructions that can be safely deleted if their result ;; isn't actually required (define byte-side-effect-free-insns (append '(refn refg slot-ref ref nth nthcdr aref length add neg sub mul div rem lnot not lor land gt ge lt le inc dec ash boundp get reverse assoc assq rassoc rassq last copy-sequence lxor max min mod make-closure enclose quotient floor ceiling truncate round exp log sin cos tan sqrt expt structure-ref) byte-varref-free-insns)) ;; list of all conditional jumps (define byte-conditional-jmp-insns '(jpn jpt jn jt jnp jtp)) ;; list of all jump instructions (define byte-jmp-insns (list* 'jmp 'ejmp byte-conditional-jmp-insns)) ;; list of all varref instructions (define byte-varref-insns '(refn refg slot-ref)) ;; list of all varset instructions (define byte-varset-insns '(setn setg slot-set)) ;; list of all varbind instructions (define byte-varbind-insns '(bind)) (define byte-nth-insns '((0 . car) (1 . cadr) (2 . caddr) (3 . cadddr) (4 . caddddr) (5 . cadddddr) (6 . caddddddr) (7 . cadddddddr))) (define byte-nthcdr-insns '((0 . ()) (1 . cdr) (2 . cddr))) ;; list of instructions that reference the vector of constants (define byte-opcodes-with-constants (list (bytecode push) (bytecode refq) (bytecode setq) (bytecode refg) (bytecode setg) (bytecode bindspec)))) librep-0.90.2/lisp/rep/vm/bytecode-defs.jl0000644000175200017520000001626611245011153017314 0ustar chrischris#| bytecode-defs.jl -- low-level details of vm bytecodes $Id$ Copyright (C) 1993, 1994, 2000 John Harper This file is part of Librep. Librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.vm.bytecode-defs (export bytecode-major bytecode-minor bytecode bytecode-ref byte-max-1-byte-arg byte-max-2-byte-arg byte-max-3-byte-arg byte-insn-stack-delta) (open rep) ;; Instruction set version (defconst bytecode-major 11) (defconst bytecode-minor 0) ;; macro to get a named bytecode (defmacro bytecode (name) (cdr (assq name bytecode-alist))) (define (bytecode-ref name) (or (cdr (assq name bytecode-alist)) (error "No such instruction: %s" name))) (define bytecode-alist '((slot-ref . #x00) (call . #x08) ;call (stk[n] stk[n-1] ... stk[0]) ; pops n values, replacing the ; function with the result. (push . #x10) ;pushes constant # n (refg . #x18) ;pushes val of symbol n (in c-v) (setg . #x20) ;sets sym n (in c-v) to stk[0]; pop (setn . #x28) (slot-set . #x30) (refn . #x38) (last-with-args . #x3f) (ref . #x40) ;replace symbol with it's value (%set . #x41) (fluid-ref . #x42) (enclose . #x43) (init-bind . #x44) ;initialise a new set of bindings (unbind . #x45) ;unbind all bindings in the top set (dup . #x46) ;duplicate top of stack (swap . #x47) ;swap top two values on stack (pop . #x48) ;pops the stack (nil . #x49) ;pushes () (t . #x4a) ;pushes t (cons . #x4b) (car . #x4c) (cdr . #x4d) (rplaca . #x4e) (rplacd . #x4f) (nth . #x50) (nthcdr . #x51) (aset . #x52) (aref . #x53) (length . #x54) (bind . #x55) (add . #x56) ;adds the top two values (neg . #x57) (sub . #x58) (mul . #x59) (div . #x5a) (rem . #x5b) (lnot . #x5c) (not . #x5d) (lor . #x5e) (land . #x5f) (equal . #x60) (eq . #x61) (structure-ref . #x62) (scm-test . #x63) (gt . #x64) (ge . #x65) (lt . #x66) (le . #x67) (inc . #x68) (dec . #x69) (ash . #x6a) (zerop . #x6b) (null . #x6c) (atom . #x6d) (consp . #x6e) (listp . #x6f) (numberp . #x70) (stringp . #x71) (vectorp . #x72) (catch . #x73) (throw . #x74) (binderr . #x75) (return . #x76) (unbindall . #x77) (boundp . #x78) (symbolp . #x79) (get . #x7a) (put . #x7b) (errorpro . #x7c) (signal . #x7d) (quotient . #x7e) (reverse . #x7f) (nreverse . #x80) (assoc . #x81) (assq . #x82) (rassoc . #x83) (rassq . #x84) (last . #x85) (mapcar . #x86) (mapc . #x87) (member . #x88) (memq . #x89) (delete . #x8a) (delq . #x8b) (delete-if . #x8c) (delete-if-not . #x8d) (copy-sequence . #x8e) (sequencep . #x8f) (functionp . #x90) (special-form-p . #x91) (subrp . #x92) (eql . #x93) (lxor . #x94) (max . #x95) (min . #x96) (filter . #x97) (macrop . #x98) (bytecodep . #x99) (pushi-0 . #x9a) (pushi-1 . #x9b) (pushi-2 . #x9c) (pushi-minus-1 . #x9d) (pushi-minus-2 . #x9e) (pushi . #x9f) (pushi-pair-neg . #xa0) (pushi-pair-pos . #xa1) (caar . #xa2) (cadr . #xa3) (cdar . #xa4) (cddr . #xa5) (caddr . #xa6) (cadddr . #xa7) (caddddr . #xa8) (cadddddr . #xa9) (caddddddr . #xaa) (cadddddddr . #xab) (floor . #xac) (ceiling . #xad) (truncate . #xae) (round . #xaf) (apply . #xb0) (forbid . #xb1) (permit . #xb2) (exp . #xb3) (log . #xb4) (sin . #xb5) (cos . #xb6) (tan . #xb7) (sqrt . #xb8) (expt . #xb9) (swap2 . #xba) (mod . #xbb) (make-closure . #xbc) (unbindall-0 . #xbd) (closurep . #xbe) (pop-all . #xbf) (fluid-set . #xc0) (fluid-bind . #xc1) (memql . #xc2) (num-eq . #xc3) (test-scm . #xc4) (test-scm-f . #xc5) (%define . #xc6) (spec-bind . #xc7) (set . #xc8) (required-arg . #xc9) (optional-arg . #xca) (rest-arg . #xcb) (not-zero-p . #xcc) (keyword-arg . #xcd) (optional-arg* . #xce) (keyword-arg* . #xcf) (last-before-jmps . #xf7) ;;; All jmps take two-byte arguments (ejmp . #xf8) ;if (pop[1]) goto error-handler, ; else jmp x (jpn . #xf9) ;if stk[0] nil, pop and jmp x (jpt . #xfa) ;if stk[0] t, pop and jmp x (jmp . #xfb) ;jmp to x (jn . #xfc) ;pop the stack, if nil, jmp x (jt . #xfd) ;pop the stack, if t, jmp x (jnp . #xfe) ;if stk[0] nil, jmp x, else pop (jtp . #xff))) ;if stk[0] t, jmp x, else pop ;; maximum argument value in 1,2,3 byte instructions (defconst byte-max-1-byte-arg 5) (defconst byte-max-2-byte-arg #xff) (defconst byte-max-3-byte-arg #xffff) ;; maps from each instruction to the effect they have on the stack ;; pointer. i.e. +1 means the instruction always increases the net ;; stack position by one (define byte-insn-stack-delta [+1 nil nil nil nil nil nil nil ;#x00 nil nil nil nil nil nil nil nil +1 nil nil nil nil nil nil nil ;#x10 +1 nil nil nil nil nil nil nil -1 nil nil nil nil nil nil nil ;#x20 -1 nil nil nil nil nil nil nil -1 nil nil nil nil nil nil nil ;#x30 +1 nil nil nil nil nil nil nil 0 -1 0 0 0 0 +1 0 ;#x40 -1 +1 +1 -1 0 0 -1 -1 -1 -1 -1 -1 0 -1 -1 0 ;#x50 -1 -1 -1 -1 0 0 -1 -1 -1 -1 -1 0 -1 -1 -1 -1 ;#x60 0 0 -1 0 0 0 0 0 0 0 0 nil -1 -1 -1 0 ;#x70 0 0 -1 -2 -1 -1 -1 0 0 -1 -1 -1 -1 0 -1 -1 ;#x80 -1 -1 -1 -1 -1 -1 0 0 0 0 0 -1 -1 -1 -1 -1 ;#x90 0 0 +1 +1 +1 +1 +1 +1 +1 +1 0 0 0 0 0 0 ;#xa0 0 0 0 0 0 0 0 0 -1 0 0 0 0 0 0 0 ;#xb0 0 -1 0 -1 -1 0 0 nil -1 -2 -1 -1 0 0 -1 -2 ;#xc0 -1 +1 +1 +1 0 0 nil nil nil nil nil nil nil nil nil nil ;#xd0 nil nil nil nil nil nil nil nil -1 nil nil nil nil nil nil nil ;#xe0 -1 nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil ;#xf0 -1 nil nil 0 -1 -1 nil nil])) librep-0.90.2/lisp/rep/vm/assembler.jl0000644000175200017520000001336011245011153016544 0ustar chrischris#| assembler.jl -- higher-level assembler $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# ;; The plan is to use in the compiler at some point to remove the ugly ;; lap code representation, instead compile to assembly language, then ;; assemble that.. (with the peephole pass inbetween) (define-structure rep.vm.assembler (export assemble) (open rep rep.vm.bytecodes rep.data.tables rep.data.records) (define-record-type :label (make-label name) labelp (name label-name label-name-set) (address label-address label-address-set) (forwards label-forwards label-forwards-set)) ;; Syntax of INSNS is a list of `(INSN [ARG])' or `LABEL'. One pseudo ;; insn: `(push-label LABEL)' ;; Example: ;; ((push 0) ;; foo ;; (push 1) ;; (add) ;; (jmp foo)) ;; Returns (BYTE-CODE-VECTOR . CONSTANT-VECTOR) (define (assemble insns #!optional start) (let ((code '()) (pc (or start 0)) (labels (make-table symbol-hash eq)) (constants '()) (next-const-id 0)) (define (get-label name) (or (table-ref labels name) (let ((l (make-label name))) (table-set labels name l) l))) (define (get-const-id value) (or (cdr (assoc value constants)) (prog1 next-const-id (setq constants (cons (cons value next-const-id) constants)) (setq next-const-id (1+ next-const-id))))) (define (emit-byte-at byte addr) (setq code (cons (cons byte addr) code))) (define (emit-byte byte) (emit-byte-at byte pc) (setq pc (1+ pc))) (define (emit-address-at addr pc) (emit-byte-at (ash addr -8) pc) (emit-byte-at (logand addr 255) (1+ pc))) (define (emit-address addr) (emit-address-at addr pc) (setq pc (+ pc 2))) (define (emit-label-addr label) (if (label-address label) (emit-address (label-address label)) (label-forwards-set label (cons pc (label-forwards label))) (setq pc (+ pc 2)))) (define (emit-insn insn #!optional arg) (let ((op (bytecode-ref insn))) (if (>= op (bytecode last-with-args)) (progn ;; ``normal'' one-byte insn encoding (emit-byte op) (when arg (cond ((memq op byte-two-byte-insns) (if (< arg 256) (emit-byte arg) (error "Argument overflow in two-byte insn: %s" insn))) ((memq op byte-three-byte-insns) (if (< arg 65536) (progn (emit-byte (ash arg -8)) (emit-byte (logand arg 255))) (error "Argument overflow in three-byte insn: %s" insn))) (t (error "Spurious argument to insn: %s" insn))))) ;; insn with embedded argument (cond ((<= arg byte-max-1-byte-arg) (emit-byte (+ op arg))) ((<= arg byte-max-2-byte-arg) (emit-byte (+ op 6)) (emit-byte arg)) ((<= arg byte-max-3-byte-arg) (emit-byte (+ op 7)) (emit-byte (ash arg -8)) (emit-byte (logand arg 255))) (t (error "Argument overflow in insn: %s" insn)))))) (define (emit-jmp insn dest) (emit-byte (bytecode-ref insn)) (emit-label-addr (get-label dest))) (define (emit-push arg) (cond ((and (fixnump arg) (<= arg 65535) (>= arg -65535)) (cond ((zerop arg) (emit-insn 'pushi-0)) ((= arg 1) (emit-insn 'pushi-1)) ((= arg 2) (emit-insn 'pushi-2)) ((= arg -1) (emit-insn 'pushi-minus-1)) ((= arg -2) (emit-insn 'pushi-minus-2)) ((and (<= arg 127) (>= arg -128)) (emit-insn 'pushi (logand arg 255))) ((and (< arg 0) (>= arg -65535)) (emit-insn 'pushi-pair-neg (- arg))) (t (emit-insn 'pushi-pair-pos arg)))) ((eq arg '()) (emit-insn 'nil)) ((eq arg 't) (emit-insn 't)) (t (emit-insn 'push (get-const-id arg))))) (define (emit-push-label arg) ;; push address of label (emit-byte (bytecode pushi-pair-pos)) (emit-label-addr (get-label arg))) (define (emit-label name) (let ((label (get-label name))) (and (label-address label) (error "Multiply-defined label: %s, %s" name insns)) (label-address-set label pc) ;; backpatch forward references (do ((refs (label-forwards label) (cdr refs))) ((null refs) (label-forwards-set label '())) (emit-byte-at (ash pc -8) (car refs)) (emit-byte-at (logand pc 255) (1+ (car refs)))))) (let loop ((rest insns)) (when rest (let ((insn (car rest))) (cond ((symbolp insn) (emit-label insn)) ((eq (car insn) 'push) (emit-push (cadr insn))) ((eq (car insn) 'push-label) (emit-push-label (cadr insn))) ((memq (car insn) '(refg setg)) ;; instruction with constant (emit-insn (car insn) (get-const-id (cadr insn)))) ((memq (car insn) byte-jmp-insns) (emit-jmp (car insn) (cadr insn))) (t (apply emit-insn insn))) (loop (cdr rest))))) (let ((byte-vec (make-string pc)) (const-vec (make-vector next-const-id))) (do ((rest code (cdr rest))) ((null rest)) (aset byte-vec (cdar rest) (caar rest))) (do ((rest constants (cdr rest))) ((null rest)) (aset const-vec (cdar rest) (caar rest))) (cons byte-vec const-vec))))) librep-0.90.2/lisp/rep/xml/reader.jl0000644000175200017520000001242311245011153016206 0ustar chrischris#| rep.xml.reader -- very basic XML parser $Id$ Copyright (C) 2002 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# ;; This is an incredibly basic XML parser. I wrote it to be able to ;; parse the example data in http://www.xmlrpc.com/spec. I haven't read ;; the real XML spec at all, so this definitely doesn't follow it ;; It spits out items that look like this: ;; (TAG PARAMS BODY-ITEMS...) ;; where TAG is a symbol, PARAMS is an alist mapping symbols to strings ;; and BODY-ITEMS... is a list of items ;; So something like bar would be (foo () "bar") ;; Also, any item whose begins with an exclamation mark is read as (! ;; STRING), so e.g. would be (! "-- a comment --") ;; Things like uses the first form: (?xml ;; (version . "1.0")) (define-structure rep.xml.reader (export make-xml-input read-xml-item) (open rep rep.regexp) (defconst token-endings (#\space #\newline #\tab #\> #\= #\/)) (defconst whitespace-chars (#\space #\newline #\tab #\return)) (define (make-xml-input input) (cons input (read-char input))) (define (next stream) (let ((c (read-char (car stream)))) (rplacd stream c) c)) (define-macro (current stream) `(cdr ,stream)) (define (eat-whitespace stream) (when (memq (current stream) whitespace-chars) (while (memq (next stream) whitespace-chars)))) (define (read-string-item stream endings) (let loop ((this (current stream)) (chars '())) (if (or (null this) (memq this endings)) (apply concat (nreverse chars)) (loop (next stream) (cons this chars))))) (define (substitute-entities string) ;; XXX other entities? (string-replace "&(lt|amp|apos|quot);" (lambda () (cdr (assoc (expand-last-match "\\1") '(("lt" . "<") ("amp" . "&") ("apos" . "'") ("quot" . "\""))))) string)) (define (read-token stream) (eat-whitespace stream) (intern (read-string-item stream token-endings))) (define (read-body-data stream) (substitute-entities (read-string-item stream '(#\<)))) (define (read-quoted-token stream) (cond ((space-char-p (current stream)) "") ((not (memq (current stream) '(#\" #\'))) (read-string-item stream token-endings)) (t (let ((delim (list (current stream)))) (next stream) (prog1 (substitute-entities (read-string-item stream delim)) (next stream)))))) (define (read-param-list stream) (let loop ((params '())) (eat-whitespace stream) (if (memq (current stream) '(#\? #\/ #\>)) (nreverse params) (let ((name (read-token stream))) (eat-whitespace stream) (or (= (current stream) #\=) (error "Expected '=' character: %s" stream)) (next stream) (eat-whitespace stream) (let ((data (read-quoted-token stream))) (loop (cons (cons name data) params))))))) (define (read-question-body stream) (let ((name (read-token stream)) (params (read-param-list stream))) (or (= (next stream) #\>) (error "Expected '>' character: %s" stream)) (next stream) (list (intern (concat #\? (symbol-name name))) params))) (define (read-exclam-body stream) (let ((data (substitute-entities (read-string-item stream '(#\>))))) (or (= (current stream) #\>) (error "Expected '>' character: %s" stream)) (next stream) (list '! data))) (define (read-tag-body stream) (let ((name (read-token stream)) (params (read-param-list stream))) (cond ((= (current stream) #\/) (or (= (next stream) #\>) (error "Expected '>' character: %s" stream)) (next stream) (list name params)) ((/= (current stream) #\>) (error "Expected '>' character: %s" stream)) (t (next stream) (let ((items '())) (let ((ended (catch 'list-ended (while (current stream) (setq items (cons (read-xml-item stream 'list-ended) items)))))) (or (string= ended name) (error "Unmatched items: %s, %s" name ended))) (list* name params (nreverse items))))))) (define (read-xml-item stream #!optional catcher) (cond ((null (current stream)) nil) ((= (current stream) #\<) (case (next stream) ((#\/) (next stream) (eat-whitespace stream) (let ((name (read-token stream))) (eat-whitespace stream) (or (= (current stream) #\>) (error "Expected '>' character: %s" stream)) (next stream) (throw catcher name))) ((#\?) (next stream) (read-question-body stream)) ((#\!) (next stream) (read-exclam-body stream)) (t (read-tag-body stream)))) (t (read-body-data stream))))) librep-0.90.2/lisp/rep/xml/printer.jl0000644000175200017520000000373211245011153016432 0ustar chrischris#| rep.xml.printer -- companion XML printer to rep.xml.reader $Id$ Copyright (C) 2002 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.xml.printer (export make-xml-output print-xml-item) (open rep rep.regexp) (define make-xml-output identity) (define (substitute-entities string) (string-replace "[<&'\"]" (lambda () (car (rassoc (expand-last-match "\\0") '(("lt" . "<") ("amp" . "&") ("apos" . "'") ("quot" . "\""))))) string)) (define (print-params stream params) (mapc (lambda (cell) (format stream " %s=\"%s\"" (car cell) (substitute-entities (cdr cell)))) params)) (define (print-xml-item stream item) (cond ((stringp item) (write stream (substitute-entities item))) ((eq (car item) '!) (format stream "" (nth 1 stream))) ((symbolp (car item)) (format stream "<%s" (car item)) (print-params stream (nth 1 item)) (cond ((string-match "^\\?" (symbol-name (car item))) (write stream "?>")) ((null (nthcdr 2 item)) (write stream "/>")) (t (write stream #\>) (mapc (lambda (x) (print-xml-item stream x)) (nthcdr 2 item)) (format stream "" (car item))))) (t (error "Unknown item type: %s" item))))) librep-0.90.2/lisp/rep/system/pwd-prompt.jl0000644000175200017520000000304111245011153017575 0ustar chrischris#| pwd-prompt.jl -- Prompt for a confidential answer (i.e. a password) $Id$ Copyright (C) 1998, 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.system)) (open-structures '(rep.regexp rep.io.streams rep.lang.math)) ;;;###autoload (defun pwd-prompt (prompt) "Prompt for a confidential string, with PROMPT as the title string. The contents of the prompt will be masked out whilst being entered." (when (zerop (system "stty -echo")) (unwind-protect (progn (write standard-error prompt) (unless (string-match "\s$" prompt) (write standard-error #\space )) (flush-file standard-error) (let ((string (read-line standard-input))) (when (string-match "\n$" string) (setq string (substring string 0 (match-start)))) (write standard-error #\newline) string)) (system "stty echo")))) librep-0.90.2/lisp/rep/system/environ.jl0000644000175200017520000000406411245011153017152 0ustar chrischris#| environ.jl -- Functions to manipulate the process-environment $Id$ Copyright (C) 1998 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.system)) (open-structures '(rep.regexp rep.data)) ;;;###autoload (defun getenv (name) "Return the value of the environment variable NAME, a string. The variable `process-environment' is used to find the value." (let ((regexp (concat (quote-regexp name) ?=))) (let loop ((rest process-environment)) (cond ((null rest) nil) ((string-looking-at regexp (car rest)) (substring (car rest) (match-end))) (t (loop (cdr rest))))))) ;;;###autoload (defun setenv (name value) "Set the current value of the environment variable NAME to the string VALUE. The `process-environment' variable is destructively modified." (let ((regexp (concat (quote-regexp name) ?=))) (let loop ((rest process-environment)) (cond ((null rest) (setq process-environment (cons (concat name #\= value) process-environment))) ((string-looking-at regexp (car rest)) (rplaca rest (concat name #\= value))) (t (loop (cdr rest))))))) ;;;###autoload (defun unsetenv (name) "Delete the environment variable called NAME." (let ((re (concat (quote-regexp name) ?=))) (setq process-environment (delete-if (lambda (x) (string-looking-at re x)) process-environment)))) librep-0.90.2/lisp/rep/www/quote-url.jl0000644000175200017520000000446711245011153016736 0ustar chrischris#| quote-url.jl -- url-escape a given string $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# ;; Background: ;; Sen Nagata posted code to do the escaping part of this to the rep ;; mailing list (<20000424174557J.1000@eccosys.com>). I've rewritten it ;; to use regexps, and added the decoder. (define-structure rep.www.quote-url (export quote-url unquote-url) (open rep rep.regexp rep.test.framework) (defconst url-meta-re "[^a-zA-Z0-9$_.!~*'(),-]" "A regexp matching a single character that is reserved in the URL spec. This is taken from draft-fielding-url-syntax-02.txt -- check your local internet drafts directory for a copy.") (define (quote-url string) "Escape URL meta-characters in STRING." (string-replace url-meta-re (lambda (s) (string-upcase (format nil "%%%02x" (aref s (match-start))))) string)) (define (unquote-url string) "Unescape URL meta-characters in STRING." (string-replace "%([0-9A-Fa-f][0-9A-Fa-f])" (lambda () (string->number (expand-last-match "\\1") 16)) string)) ;; Tests (define (self-test) (test (string= (quote-url "http://www.foo.com/bar.html") "http%3A%2F%2Fwww.foo.com%2Fbar.html")) (test (string= (quote-url "http://www.foo.com/~jsh/") "http%3A%2F%2Fwww.foo.com%2F~jsh%2F")) (test (string= (unquote-url "http%3A%2F%2Fwww.foo.com%2Fbar.html") "http://www.foo.com/bar.html")) (test (string= (unquote-url "http%3A%2F%2Fwww.foo.com%2F~jsh%2F") "http://www.foo.com/~jsh/"))) ;;###autoload (define-self-test 'rep.www.quote-url self-test)) librep-0.90.2/lisp/rep/www/fetch-url.jl0000644000175200017520000000315111245011153016657 0ustar chrischris#| fetch-url.jl -- functions for downloading files $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.www.fetch-url (export fetch-url fetch-url-async) (open rep rep.io.processes) (defvar *wget-program* "wget" "Location of `wget' program.") (put 'wget 'error-message "Wget Error") (define (fetch-url url dest-stream) (let ((process (make-process dest-stream))) (set-process-error-stream process standard-error) (unless (zerop (call-process process nil *wget-program* "-nv" "-O" "-" url)) (signal 'wget (list url))))) (define (fetch-url-async url dest-stream callback #!optional error-stream) (let ((process (make-process dest-stream))) (set-process-error-stream process (or error-stream standard-error)) (set-process-function process callback) (start-process process nil *wget-program* "-nv" "-O" "-" url)))) librep-0.90.2/lisp/rep/www/cgi-get.jl0000644000175200017520000000565511245011153016320 0ustar chrischris;; cgi-get.jl -- return the parameters from a CGI GET request ;; Copyright (C) 1999 John Harper ;; $Id$ ;; This file is part of librep. ;; librep is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; librep is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with librep; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (declare (unsafe-for-call/cc)) (define-structure rep.www.cgi-get (export cgi-get-params) (open rep rep.system rep.regexp rep.test.framework) (define-structure-alias cgi-get rep.www.cgi-get) (define unquote-plus-map (let ((map (make-string (1+ ?+))) (i 0)) (while (< i ?+) (aset map i i) (setq i (1+ i))) (aset map ?+ ? ) map)) (defun cgi-get-params (#!optional query-string) (unless query-string (setq query-string (getenv "QUERY_STRING"))) (let ((point 0) (params nil) name value) (while (string-looking-at "([^=]+)=([^&]*)(&|$)" query-string point) (setq point (match-end)) (setq name (intern (unquote (substring query-string (match-start 1) (match-end 1))))) (setq value (unquote (substring query-string (match-start 2) (match-end 2)))) (when (string= value "") (setq value nil)) (setq params (cons (cons name value) params))) (nreverse params))) (defsubst hexdigit (char) (if (and (>= char ?0) (<= char ?9)) (- char ?0) (+ (- (char-upcase char) ?A) 10))) (defun unquote (string) (let ((frags nil) (point 0)) (setq string (translate-string string unquote-plus-map)) (while (string-match "%.." string point) (setq frags (cons (substring string point (match-start)) frags)) (setq point (match-end)) (setq frags (cons (+ (* (hexdigit (aref string (- point 2))) 16) (hexdigit (aref string (1- point)))) frags))) (if (zerop point) string (setq frags (cons (substring string point) frags)) (apply concat (nreverse frags))))) ;; Tests (define (self-test) (test (equal (cgi-get-params "") '())) (test (equal (cgi-get-params "foo=bar") '((foo . "bar")))) (test (equal (cgi-get-params "foo=bar&baz=quux") '((foo . "bar") (baz . "quux")))) (test (equal (cgi-get-params "foo=&baz=quux") '((foo . ()) (baz . "quux")))) (test (equal (cgi-get-params "foo=%3A%2F%3D") '((foo . ":/=")))) (test (equal (cgi-get-params "foo=+bar+") '((foo . " bar "))))) ;;###autoload (define-self-test 'rep.www.cgi-get self-test)) librep-0.90.2/lisp/rep/util/time.jl0000644000175200017520000000270211245011153016056 0ustar chrischris#| rep.util.time -- time conversion functions $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.util.time (export seconds-per-day time->seconds seconds->time time-) (open rep) (defconst seconds-per-day 86400) (define (time->seconds time) "Convert the timestamp TIME to the number of seconds since the epoch." (+ (* (car time) seconds-per-day) (cdr time))) (define (seconds->time secs) "Convert the number of secs past the epoch, SECS, to a timestamp." (cons (quotient secs seconds-per-day) (mod secs seconds-per-day))) (define (time- t1 t2) "Return the number of seconds difference between timestamps T1 and T2." (- (time->seconds t1) (time->seconds t2)))) librep-0.90.2/lisp/rep/util/repl.jl0000644000175200017520000003126311245011153016066 0ustar chrischris#| repl.jl -- rep input loop $Id: repl.jl,v 1.50 2004/10/07 05:03:54 jsh Exp $ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.util.repl (export repl make-repl repl-struct repl-pending repl-eval repl-iterate repl-completions define-repl-command) (open rep rep.structures rep.system rep.regexp rep.io.files) (define current-repl (make-fluid)) (define (make-repl #!optional initial-struct) (cons (or initial-struct *user-structure*) nil)) (define repl-struct car) (define repl-pending cdr) (define repl-set-struct rplaca) (define repl-set-pending rplacd) (define (repl-eval form) (eval form (intern-structure (repl-struct (fluid current-repl))))) (define (repl-boundp x) (condition-case nil (progn (repl-eval x) t) (void-value nil))) ;; returns t if repl should run again (define (repl-iterate repl input) (setq input (concat (repl-pending repl) input)) (repl-set-pending repl nil) (let-fluids ((current-repl repl)) (let ((print-escape t)) (catch 'return (condition-case data (progn (cond ((string-looking-at "\\s*,\\s*" input) ;; a `,' introduces a meta command (let ((stream (make-string-input-stream input (match-end))) (sexps '())) (condition-case nil (while t (setq sexps (cons (read stream) sexps))) (end-of-stream (setq sexps (nreverse sexps)))) (let ((command (repl-command (car sexps)))) (and command (apply command (cdr sexps)))))) ;; ignore empty input lines, or lines with comments only ((string-looking-at "\\s*(;.*)?$" input)) (t (let ((form (condition-case nil (read-from-string input) (premature-end-of-stream (repl-set-pending repl input) (throw 'return (and input (not (string= "" input)))))))) (let ((result (repl-eval form))) (unless (eq result #undefined) (format standard-output "%S\n" result)))))) t) (error (default-error-handler (car data) (cdr data)) t)))))) (define (do-readline prompt completer) (if (file-ttyp standard-input) (progn (require 'rep.io.readline) (readline prompt completer)) (write standard-output prompt) (read-line standard-input))) (define (repl #!optional initial-structure) ;; returns t if repl should run again (define (run-repl) (let ((input (do-readline (format nil (if (repl-pending (fluid current-repl)) "" "%s> ") (repl-struct (fluid current-repl))) completion-generator))) (and input (repl-iterate (fluid current-repl) input)))) (define (interrupt-handler data) (if (eq (car data) 'user-interrupt) (progn (format standard-output "User interrupt!\n") t) (raise-exception data))) (let-fluids ((current-repl (make-repl initial-structure))) (write standard-output "\nEnter `,help' to list commands.\n") (let loop () (when (call-with-exception-handler run-repl interrupt-handler) (loop))))) (define (print-list data #!optional map) (unless map (setq map identity)) (let* ((count (length data)) (mid (inexact->exact (ceiling (/ count 2))))) (do ((i 0 (1+ i)) (left data (cdr left)) (right (nthcdr mid data) (cdr right))) ((null left)) (when (< i mid) (format standard-output " %-30s" (format nil "%s" (map (car left)))) (when right (format standard-output " %s" (map (car right)))) (write standard-output #\newline))))) (define (completion-generator w) ;; Either a special command or unquote. (if (string-head-eq w ",") (mapcar (lambda (x) (concat "," (symbol-name x))) (apropos (concat #\^ (quote-regexp (substring w 1))) (lambda (x) (assq x repl-commands)))) (apropos (concat #\^ (quote-regexp w)) repl-boundp))) (define (repl-completions repl word) (let-fluids ((current-repl repl)) (completion-generator word))) ;;; module utils (define (module-exports-p name var) (structure-exports-p (get-structure name) var)) (define (module-imports name) (structure-imports (get-structure name))) (define (locate-binding* name) (or (locate-binding name (append (list (repl-struct (fluid current-repl))) (module-imports (repl-struct (fluid current-repl))))) (and (structure-bound-p (get-structure (repl-struct (fluid current-repl))) name) (repl-struct (fluid current-repl))))) ;;; commands (define repl-commands '()) (define (define-repl-command name function #!optional doc) (let ((cell (assq name repl-commands))) (if cell (rplacd cell (list function doc)) (setq repl-commands (cons (list name function doc) repl-commands))))) (define (find-command name) (let ((cell (assq name repl-commands))) (if cell cell ;; look for an unambiguous match (let ((re (concat "^" (quote-regexp (symbol-name name))))) (let loop ((rest repl-commands) (matched nil)) (cond ((null rest) (if matched matched (format standard-output "unknown command: ,%s\n" name) nil)) ((string-match re (symbol-name (caar rest))) (if matched ;; already saw something, exit (progn (format standard-output "non-unique abbreviation: ,%s\n" name) nil) (loop (cdr rest) (car rest)))) (t (loop (cdr rest) matched)))))))) (define (repl-command name) (let ((cell (find-command name))) (and cell (cadr cell)))) (define (repl-documentation name) (let ((cell (find-command name))) (and cell (caddr cell)))) (define-repl-command 'in (lambda (struct #!optional form) (if form (format standard-output "%S\n" (eval form (get-structure struct))) (repl-set-struct (fluid current-repl) struct))) "STRUCT [FORM ...]") (define-repl-command 'load (lambda structs (mapc (lambda (struct) (intern-structure struct)) structs)) "STRUCT ...") (define-repl-command 'reload (lambda structs (mapc (lambda (x) (let ((struct (get-structure x))) (when struct (name-structure struct nil)) (intern-structure x))) structs)) "STRUCT ...") (define-repl-command 'unload (lambda structs (mapc (lambda (x) (let ((struct (get-structure x))) (when struct (name-structure struct nil)))) structs)) "STRUCT ...") (define-repl-command 'load-file (lambda files (mapc (lambda (f) (repl-eval `(,load ,f))) files)) "\"FILENAME\" ...") (define-repl-command 'open (lambda structs (repl-eval `(,open-structures (,quote ,structs)))) "STRUCT ...") (define-repl-command 'access (lambda structs (repl-eval `(,access-structures (,quote ,structs)))) "STRUCT ...") (define-repl-command 'structures (lambda () (let (structures) (structure-walk (lambda (var value) (declare (unused value)) (when value (setq structures (cons var structures)))) (get-structure '%structures)) (print-list (sort structures))))) (define-repl-command 'interfaces (lambda () (let (interfaces) (structure-walk (lambda (var value) (declare (unused value)) (setq interfaces (cons var interfaces))) (get-structure '%interfaces)) (print-list (sort interfaces))))) (define-repl-command 'bindings (lambda () (structure-walk (lambda (var value) (format standard-output " (%s %S)\n" var value)) (intern-structure (repl-struct (fluid current-repl)))))) (define-repl-command 'exports (lambda () (print-list (structure-interface (intern-structure (repl-struct (fluid current-repl))))))) (define-repl-command 'imports (lambda () (print-list (module-imports (repl-struct (fluid current-repl)))))) (define-repl-command 'accessible (lambda () (print-list (structure-accessible (intern-structure (repl-struct (fluid current-repl))))))) (define-repl-command 'collect (lambda () (let ((stats (garbage-collect t))) (format standard-output "Used %d/%d cons, %d/%d tuples, %d strings, %d vector slots, %d/%d closures\n" (car (nth 0 stats)) (+ (car (nth 0 stats)) (cdr (nth 0 stats))) (car (nth 1 stats)) (+ (car (nth 1 stats)) (cdr (nth 1 stats))) (car (nth 2 stats)) (nth 3 stats) (car (nth 4 stats)) (+ (car (nth 4 stats)) (cdr (nth 4 stats))))))) (define-repl-command 'disassemble (lambda (arg) (require 'rep.vm.disassembler) (disassemble (repl-eval arg))) "FORM") (define-repl-command 'compile-proc (lambda args (require 'rep.vm.compiler) (mapc (lambda (arg) (compile-function (repl-eval arg) arg)) args)) "PROCEDURE ...") (define-repl-command 'compile (lambda args (require 'rep.vm.compiler) (if (null args) (compile-module (repl-struct (fluid current-repl))) (mapc compile-module args))) "[STRUCT ...]") (define-repl-command 'compile-file (lambda args (require 'rep.vm.compiler) (mapc compile-file args)) "\"FILENAME\" ...") (define-repl-command 'new (lambda (name) (declare (bound %open-structures)) (make-structure nil (lambda () (%open-structures '(rep.module-system))) nil name) (repl-set-struct (fluid current-repl) name)) "STRUCT") (define-repl-command 'expand (lambda (form) (format standard-output "%s\n" (repl-eval `(,macroexpand ',form)))) "FORM") (define-repl-command 'step (lambda (form) (format standard-output "%s\n" (repl-eval `(,step ',form)))) "FORM") (define-repl-command 'help (lambda () (write standard-output " Either enter lisp forms to be evaluated, and their result printed, or enter a meta-command prefixed by a `,' character. Names of meta- commands may be abbreviated to their unique leading characters.\n\n") (print-list (sort (mapcar car repl-commands)) (lambda (x) (format nil ",%s %s" x (or (repl-documentation x) "")))))) (define-repl-command 'quit (lambda () (throw 'quit 0))) (define-repl-command 'describe (lambda (name) (require 'rep.lang.doc) (let* ((value (repl-eval name)) (struct (locate-binding* name)) (doc (documentation name struct value))) (write standard-output #\newline) (describe-value value name struct) (write standard-output #\newline) (when doc (format standard-output "%s\n\n" doc)))) "SYMBOL") (define-repl-command 'apropos (lambda (re) (require 'rep.lang.doc) (let ((funs (apropos re repl-boundp))) (mapc (lambda (x) (describe-value (repl-eval x) x)) funs))) "\"REGEXP\"") (define-repl-command 'locate (lambda (var) (let ((struct (locate-binding* var))) (if struct (format standard-output "%s is bound in: %s.\n" var struct) (format standard-output "%s is unbound.\n" var)))) "SYMBOL") (define-repl-command 'whereis (lambda (var) (let ((out '())) (structure-walk (lambda (k v) (declare (unused k)) (when (and v (structure-name v) (structure-exports-p v var)) (setq out (cons (structure-name v) out)))) (get-structure '%structures)) (if out (format standard-output "%s is exported by: %s.\n" var (mapconcat symbol-name (sort out) ", ")) (format standard-output "No module exports %s.\n" var)))) "SYMBOL") (define-repl-command 'time (lambda (form) (let (t1 t2 ret) (setq t1 (current-utime)) (setq ret (repl-eval form)) (setq t2 (current-utime)) (format standard-output "%S\nElapsed: %d seconds\n" ret (/ (- t2 t1) 1e6)))) "FORM") (define-repl-command 'profile (lambda (form) (require 'rep.lang.profiler) (format standard-output "%S\n\n" (call-in-profiler (lambda () (repl-eval form)))) (print-profile)) "FORM") (define-repl-command 'check (lambda (#!optional module) (require 'rep.test.framework) (if (null module) (run-all-self-tests) (run-module-self-tests module))) "[STRUCT]")) librep-0.90.2/lisp/rep/util/memoize.jl0000644000175200017520000000257211245011153016572 0ustar chrischris;; memoize.jl -- create caching-enabled functions ;; Copyright (C) 2000 John Harper ;; $Id$ ;; This file is part of librep. ;; librep is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; librep is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with librep; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (define-structure rep.util.memoize (export memoize memoize-function) (open rep rep.data.tables) (define-structure-alias memoize rep.util.memoize) (define (memoize f) "Create and return a caching version of the function F. F may not be an autoload definition." (unless (functionp f) (error "can only memoize functions: %s" f)) (let ((cache (make-table equal-hash equal))) (lambda args (or (table-ref cache args) (table-set cache args (apply f args)))))) ;; backwards compatibility (define memoize-function memoize)) librep-0.90.2/lisp/rep/util/ispell.jl0000644000175200017520000001462611245011153016420 0ustar chrischris#| ispell.jl -- ispell wrapper $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.util.ispell (export ispell-start ispell-stop ispell-word ispell-test-word ispell-set-dictionary ispell-add-word-to-dictionary ispell-add-word-for-session ispell-save-dictionary) (open rep rep.regexp rep.io.processes rep.system) (defvar *ispell-program* "ispell" "Filename of program used to start ispell(1).") (defvar *ispell-options* nil "List of options to pass to Ispell") (defvar *ispell-dictionary* nil "Name of dictionary to pass to Ispell, or nil for the default.") (defvar *ispell-timeout* 5 "Seconds to wait for ispell output before giving up.") (defvar *ispell-echo-output* nil "Use for debugging only.") (define process nil "Subprocess that ispell is running in, or nil if ispell isn't running.") (define process-busy nil "When t, the process is being used to check a word, but not all results have been received.") (define id-string nil "String sent by ispell identifying itself when it started executing.") (define pending-output nil "String of output received from ispell but not processed.") (define line-callback (make-fluid nil) "Function to call asynchronously with a single line of output from ispell.") ;;; Process management ;; Function to buffer output from Ispell (define (output-filter output) (when (integerp output) (setq output (make-string 1 output))) (and *ispell-echo-output* (stringp output) (let ((print-escape t)) (format standard-error "Ispell: %S\n" output))) (setq pending-output (concat pending-output output)) (while (and (fluid line-callback) pending-output (string-match "\n" pending-output)) (let ((line (substring pending-output 0 (match-end)))) (setq pending-output (substring pending-output (match-end))) ((fluid line-callback) line)))) ;; Start the process if it isn't already (define (ispell-start) (unless process (setq process (make-process output-filter)) (set-process-function process (lambda () (setq process nil) (setq id-string nil))) ;; Use a pty if possible. This allow EOF to be sent via ^D (set-process-connection-type process 'pty) (apply start-process process *ispell-program* "-a" (nconc (and *ispell-dictionary* (list "-d" *ispell-dictionary*)) *ispell-options*)) (setq pending-output nil) (fluid-set line-callback nil) (setq id-string (ispell-read-line)) (unless (string-match "ispell version" id-string 0 t) (ispell-stop) (error "Ispell: %s" id-string)))) (define (ispell-stop) "Kill any subprocesses being used internally to run Ispell." (accept-process-output-1 process 0) ;in case the process already died (when process (ispell-save-dictionary) (if (eq (process-connection-type process) 'pty) (write process ?\^D) ;; Not so successful.. (interrupt-process process)) (let ((counter 0)) (while (and (accept-process-output-1 process *ispell-timeout*) process) (if (< counter 2) (interrupt-process process) (kill-process process)) (setq counter (1+ counter)))))) ;; Read one whole line from the process (including newline) (define (ispell-read-line) (let ((out nil)) (let-fluids ((line-callback (lambda (l) (setq out l) ;; Only want the first line (fluid-set line-callback nil)))) ;; Flush any pending output (output-filter nil) (while (and (not out) process (not (accept-process-output-1 process *ispell-timeout*)))) (or out (error "Ispell timed out waiting for output"))))) ;; put in the before-exit-hook (define (before-exit) (when process (ispell-stop))) (add-hook 'before-exit-hook before-exit) ;; Arbitrate access to the Ispell process, the mutex must be obtained ;; before sending a command that generates output. An error is signalled ;; if the process is busy (define (mutex grab) (if grab (if process-busy (error "Ispell process is busy!") (ispell-start) (setq process-busy t)) (setq process-busy nil))) ;; Check a word with Ispell. Returns the raw (single-line) output ;; see ispell(1) for details (under the -a option) (define (ispell-word word) (let (response tem) (mutex t) (unwind-protect (progn (format process "%s\n" word) (setq response (ispell-read-line)) (if (eq (aref response 0) ?\n) ;; This shouldn't happen (error "Null output from Ispell") ;; Gobble following blank line (setq tem (ispell-read-line)) (unless (eq (aref tem 0) ?\n) (error "Non-null trailing line from Ispell")))) (mutex nil)) response)) ;; return true if WORD is spelt correctly (define (ispell-test-word word) (let ((response (ispell-word word))) (string-looking-at "^[*+-]" response))) ;;; Dictionary management (define (ispell-set-dictionary dict-name) "Set the name of the dictionary used by Ispell to DICT-NAME." (setq *ispell-dictionary* dict-name) (when process (ispell-stop) (ispell-start)) (call-hook '*ispell-dictionary-changed*)) (define (ispell-add-word-to-dictionary word) "Add the string WORD to your personal Ispell dictionary." (ispell-start) (format process "*%s\n" word) (call-hook '*ispell-dictionary-changed*)) (define (ispell-add-word-for-session word) "Add the string WORD to Ispell's per-session dictionary." (ispell-start) (format process "@%s\n" word) (call-hook '*ispell-dictionary-changed*)) (define (ispell-save-dictionary) "Make Ispell save the current personal dictionary to its file." (when process (write process "#\n")))) librep-0.90.2/lisp/rep/util/gaol.jl0000644000175200017520000001721511245011153016047 0ustar chrischris;; gaol.jl -- iron-boxes for untrusted code ;; $Id$ ;; This file is part of librep. ;; librep is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; librep is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with librep; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (define-structure rep.util.gaol (export gaol-define gaol-define-special gaol-define-file-handler gaol-define-vm make-gaol define-gaol-structure gaol-eval gaol-load gaol-open ;; obsolete gaol-rebuild-environment gaol-replace-function gaol-add-special) (open rep rep.io.files rep.io.file-handlers rep.regexp rep.system rep.data.datums rep.structures) (define-structure-alias gaol rep.util.gaol) ;;; configuration/variables ;; list of all safe functions (only those imported into this ;; module may be placed in this list) (define gaol-safe-functions '(nil t % * + - / /= 1+ 1- < <= = > >= add-hook alpha-char-p alphanumericp and append apply aref arrayp aset ash assoc assoc-regexp assq atom backquote beep boundp bytecodep call-hook car caar cadr caaar cdaar cadar cddar caadr cdadr caddr cdddr caaaar cadaar caadar caddar caaadr cadadr caaddr cadddr cdaaar cddaar cdadar cdddar cdaadr cddadr cdaddr cddddr case catch call-with-catch cdr cdar cddr char-downcase char-upcase closurep complete-string concat cond condition-case call-with-error-handlers cons consp copy-sequence copy-stream current-time current-time-string default-boundp default-value defconst %define define defmacro defsubst defun defvar delete delete-if delete-if-not delq digit-char-p do elt eq eql equal error eval eval-when-compile expand-last-match featurep filter fix-time format funcall function functionp garbage-collect gensym get get-output-stream-string getenv identity if integerp interactive intern lambda last length let let* letrec list list* listp logand logior lognot logxor lower-case-p lsh macroexpand macrop make-closure make-list make-string make-string-input-stream make-string-output-stream make-symbol make-vector makunbound mapc mapcar match-end match-start max member memq memql message min mod nconc nop not nreverse nth nthcdr null numberp or prin1 prin1-to-string princ print prog1 prog2 progn put quote quote-regexp random rassoc rassq read read-char read-chars read-from-string read-line reverse rplaca rplacd sequencep set set-default setcar setcdr setplist setq setq-default signal sit-for sleep-for sort space-char-p special-form-p special-variable-p streamp string-equal string-head-eq string-lessp string-looking-at string-match string-split string-replace string< string= stringp subr-name subrp substring symbol-name symbol-plist symbol-value symbolp system-name throw time-later-p translate-string unless unwind-protect call-with-unwind-protect upper-case-p user-full-name user-login-name vector vectorp when while with-internal-definitions with-object write zerop remainder quotient modulo floor ceiling truncate round exp log sin cos tan asin acos atan sqrt expt gcd fixnump rationalp realp exactp inexactp exact->inexact inexact->exact numerator denominator positivep negativep oddp evenp abs lcm make-datum define-datum-printer datum-ref datum-set has-type-p make-fluid fluid fluid-set with-fluids let-fluids string->number number->string mapconcat string-upper-case-p string-lower-case-p string-capitalized-p string-upcase string-downcase capitalize-string mapconcat ;; make-timer delete-timer set-timer ;; make-table make-weak-table string-hash symbol-hash eq-hash ;; equal-hash tablep table-ref table-set table-unset table-walk downcase-table flatten-table upcase-table operating-system rep-version)) ;; table containing all variables accessible by gaolled code (define gaol-structure nil) ;; list of accessible special variables (define gaol-safe-specials (list 'file-handler-alist 'load-filename 'macro-environment)) ;; list of file handlers that may be called. These functions shouldn't ;; be added to the function environment, since that would allow _any_ ;; file operation to be performed (define gaol-safe-file-handlers '(tilde-file-handler tar-file-handler)) ;; alist of file handlers (define file-handler-env nil) ;; function providing the virtual machine, or nil (define byte-code-interpreter nil) ;;; building the actual environments ;; initialization (define (build-structure) (unless gaol-structure (setq gaol-structure (make-structure)) (name-structure gaol-structure '%gaol) (structure-exports-all gaol-structure t) (mapc (lambda (var) (structure-define gaol-structure var (%structure-ref (current-structure) var))) gaol-safe-functions) (setq file-handler-env (mapcar (lambda (sym) (cons sym t)) gaol-safe-file-handlers)))) (defun make-gaol () (build-structure) (declare (bound %open-structures)) (let ((gaol (make-structure '() (lambda () (%open-structures '(%gaol)))))) (set-file-handler-environment file-handler-env gaol) (set-special-environment gaol-safe-specials gaol) (structure-install-vm gaol byte-code-interpreter) (call-hook '*make-gaol-hook* (list gaol)) gaol)) (define (define-gaol-structure name gaol) (name-structure gaol name)) (define default-gaol (let (gaol) (lambda () (unless gaol (setq gaol (make-gaol))) gaol))) ;;; public environment mutators (define (gaol-define var value) (build-structure) (structure-define gaol-structure var value)) (define (gaol-define-special var) (build-structure) (unless (memq var gaol-safe-specials) ;; use nconc to affect existing environments (setq gaol-safe-specials (nconc gaol-safe-specials (list var))))) (define (gaol-define-file-handler name fun) (build-structure) (let ((cell (assq name file-handler-env))) (if cell (rplacd cell fun) (setq file-handler-env (nconc file-handler-env (list (cons name fun))))))) ;; only works properly for gaols created after calling this function (define (gaol-define-vm run validate) (build-structure) (gaol-define 'run-byte-code run) (gaol-define 'validate-byte-code validate) (setq byte-code-interpreter run)) (define (gaol-open struct) (build-structure) (eval `(,open-structures '(,struct)) gaol-structure)) ;;; evaluating in the restricted environment (define (load-in filename struct) (let ((file (open-file filename 'read))) (unwind-protect (condition-case nil (let ((load-filename (canonical-file-name filename))) (while t (eval (read file) struct))) (end-of-stream)) (close-file file)))) (define (gaol-eval form #!optional gaol) (eval form (or gaol (default-gaol)))) (define (gaol-load file #!optional gaol) (load-in file (or gaol (default-gaol)))) ;;; compatibility (define (gaol-rebuild-environment)) (define gaol-replace-function gaol-define) (define gaol-add-special gaol-define-special)) librep-0.90.2/lisp/rep/util/date.jl0000644000175200017520000001606111245011153016040 0ustar chrischris;;;; date.jl -- Date manipulation ;;; Copyright (C) 1997 John Harper ;;; $Id$ ;;; This file is part of Jade. ;;; Jade is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2, or (at your option) ;;; any later version. ;;; Jade is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; You should have received a copy of the GNU General Public License ;;; along with Jade; see the file COPYING. If not, write to ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (declare (unsafe-for-call/cc)) (define-structure rep.util.date (export parse-date date-vec-day-abbrev date-vec-day date-vec-month-abbrev date-vec-month date-vec-year date-vec-hour date-vec-minute date-vec-second date-vec-timezone date-vec-epoch-time) (open rep rep.system rep.regexp) (define-structure-alias date rep.util.date) (define date-month-alist '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12) ("January" . 1) ("February" . 2) ("March" . 3) ("April" . 4) ("June" . 6) ("July" . 7) ("August" . 8) ("September" . 9) ("October" . 10) ("November" . 11) ("December" . 12)) "Alist of (MONTH-NAME . MONTH-NUM).") (define date-timezone-alist '(("UT" . 0) ("GMT" . 0) ("EST" . -300) ("EDT" . -240) ("CST" . -360) ("CDT" . -300) ("MST" . -420) ("MDT" . -360) ("PST" . -480) ("PDT" . -420)) "Alist of (TIMEZONE . MINUTES-DIFFERENCE).") (define date-two-digit-year-prefix (substring (current-time-string) 20 22) "A two-digit string that will be prepended to year specifications that only have two, lower order, digits. This is picked up automatically from the current year, i.e. 1997 -> \"19\", 2001 -> \"20\".") ;; Date parsing ;; Constants defining date structure fields (defconst date-vec-day-abbrev 0) (defconst date-vec-day 1) (defconst date-vec-month-abbrev 2) (defconst date-vec-month 3) (defconst date-vec-year 4) (defconst date-vec-hour 5) (defconst date-vec-minute 6) (defconst date-vec-second 7) (defconst date-vec-timezone 8) (defconst date-vec-epoch-time 9) ;; Parse the date header at position POINT in STRING, returns vector ;; [DAY-ABBREV DAY MONTH-ABBREV MONTH YEAR HOUR MINUTE SECOND ;; TZ-STRING TIME_T] (defun parse-date (string #!optional point) "Parse the date specifiction in STRING, optionally starting at the POINT'th character in the string. This will parse dates in RFC-822 mail messages." (unless point (setq point 0)) (let ((day-abbrev "") (day -1) (month-abbrev "") (month -1) (year -1) (hour 0) (minute 0) (second 0) (timezone 0) time_t tem) (while (< point (length string)) (cond ((string-looking-at "[\t ]*([0-9]+)([\t ]+|$)" string point) (let* ((start (match-start 1)) (end (match-end 1)) (value (string->number (substring string start end)))) ;; Could be year or day of month (if (or (>= day 0) (> (- end start) 2)) ;; Assume year (if (= (- end start) 2) ;; two-digit year (setq year (+ (* 100 (string->number date-two-digit-year-prefix)) value)) (setq year value)) (setq day value)) (setq point end))) ((string-looking-at "[\t ]*([0-9]+):([0-9]+)(:[0-9]+)?[\t ]*([A-Z]+|[+-][0-9]+)?[\t ]*" string point) ;; Time spec. (setq point (match-end)) (setq hour (string->number (substring string (match-start 1) (match-end 1))) minute (string->number (substring string (match-start 2) (match-end 2))) second (if (equal (match-start 3) (match-end 3)) 0 (string->number (substring string (1+ (match-start 3)) (match-end 3)))) timezone (if (equal (match-start 4) (match-end 4)) "UT" (substring string (match-start 4) (match-end 4)))) (if (setq tem (assoc timezone date-timezone-alist)) (setq timezone (cdr tem)) ;; Try +-HHMM (if (string-looking-at "[+-]([0-9][0-9])([0-9][0-9])" timezone) (setq timezone (* (if (= (aref timezone 0) ?+) 1 -1) (+ (* 60 (string->number (substring timezone (match-start 1) (match-end 1)))) (string->number (substring timezone (match-start 2) (match-end 2)))))) ;; whatever.. (setq timezone 0)))) ((string-looking-at "[\t ]*(Mon|Tue|Wed|Thu|Fri|Sat|Sun)[a-z]*[\t ]*,?[\t ]*" string point t) ;; Found day spec (setq day-abbrev (substring string (match-start 1) (match-end 1))) (setq point (match-end))) ((string-looking-at "[\t ]*(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[a-z]*[\t ]*" string point t) ;; Month name (setq month-abbrev (substring string (match-start 1) (match-end 1))) (setq month (cdr (assoc month-abbrev date-month-alist))) (setq point (match-end))) ((string-looking-at "[\t ]*([0-9][0-9][0-9][0-9])-([0-9][0-9])-([0-9][0-9])[\t ]*" string point) ;; ISO 8601 calendar date YYYY-MM-DD (setq year (string->number (expand-last-match "\\1"))) (setq month (string->number (expand-last-match "\\2"))) (setq month-abbrev (car (rassq month date-month-alist))) (setq day (string->number (expand-last-match "\\3"))) ;; XXX day of week calculation (setq point (match-end))) (t ;; Garbage in -- garbage out (setq point (length string))))) (when (< year 0) (setq year (string->number (current-time-string nil "%Y")))) (when (< month 0) (setq month (string->number (current-time-string nil "%m")))) (when (< day 0) (setq day (string->number (current-time-string nil "%d")))) ;; Use Gauss' algorithm (?) to find seconds since 1970 ;; This subroutine is copied from my VMM operating system, ;; which was in turn copied from Linux (let ((g-month (- month 2)) (g-year year) total-seconds total-days) (when (>= 0 g-month) ;; Put feb last since it has leap day (setq g-month (+ g-month 12) g-year (1- g-year))) ;; (DAYS . SECONDS) (setq total-days (+ (- (quotient g-year 4) (quotient g-year 100)) (quotient g-year 400) (quotient (* 367 g-month) 12) day (* g-year 365) -719499) total-seconds (+ second (* 60 (+ minute (- timezone) (* 60 hour))))) (setq time_t (fix-time (cons total-days total-seconds)))) (when (and (string= day-abbrev "") time_t) ;; January 1, 1970 was a Thursday (let ((dow (% (+ (car time_t) 4) 7))) (when (< dow 0) (setq dow (+ dow 7))) (setq day-abbrev (aref ["Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"] dow)))) (vector day-abbrev day month-abbrev month year hour minute second timezone time_t)))) librep-0.90.2/lisp/rep/util/base64.jl0000644000175200017520000000627611245011153016216 0ustar chrischris#| base64.jl -- base64 encoder/decoder $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.util.base64 (export base64-encode base64-decode) (open rep) ;; INPUT and OUTPUT are any type of stream (defconst mime-base64-alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") (define (base64-encode input output) (let ((col 0) reg reg1 reg2 reg3) (catch 'done (while t (setq reg1 (read-char input)) (setq reg2 (read-char input)) (setq reg3 (read-char input)) (cond ((and reg1 reg2 reg3) ;; Got our 24 bits, split into four 6 bit quantities (progn (setq reg (logior (lsh reg1 16) (lsh reg2 8) reg3)) (write output (aref mime-base64-alphabet (lsh reg -18))) (write output (aref mime-base64-alphabet (logand (lsh reg -12) #o77))) (write output (aref mime-base64-alphabet (logand (lsh reg -6) #o77))) (write output (aref mime-base64-alphabet (logand reg #o77))) (setq col (+ col 4)) (when (>= col 76) (write output #\newline) (setq col 0)))) (reg2 ;; 16 bits read, shift in 2 zeros (setq reg (lsh (logior (lsh reg1 8) reg2) 2)) (write output (aref mime-base64-alphabet (lsh reg -12))) (write output (aref mime-base64-alphabet (logand (lsh reg -6) #o77))) (write output (aref mime-base64-alphabet (logand reg #o77))) (write output #\=) (throw 'done t)) (reg1 ;; eight bits read, shift in 4 zeros (setq reg (lsh reg1 4)) (write output (aref mime-base64-alphabet (lsh reg -6))) (write output (aref mime-base64-alphabet (logand reg #o77))) (write output #\=) (write output #\=) (throw 'done t)) (t ;; 0 bits read (throw 'done t))))) (write output #\newline))) (define (base64-decode input output) (let ((reg 0) (bits 0) char) (while (setq char (read-char input)) (cond ((and (>= char #\A) (<= char #\Z)) (setq char (- char #\A))) ((and (>= char #\a) (<= char #\z)) (setq char (+ 26 (- char #\a)))) ((and (>= char #\0) (<= char #\9)) (setq char (+ 52 (- char #\0)))) ((= char #\+) (setq char 62)) ((= char #\/) (setq char 63)) (t (setq char nil))) (when char (setq reg (logior (lsh reg 6) char)) (setq bits (+ bits 6))) (while (>= bits 8) (setq char (lsh reg (- 8 bits))) (setq reg (logxor reg (lsh char (- bits 8)))) (setq bits (- bits 8)) (write output char)))))) librep-0.90.2/lisp/rep/util/autoloader.jl0000644000175200017520000000364011245011153017261 0ustar chrischris#| autoloader.jl -- abstractions for autoloading `definitions' $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.util.autoloader (export make-autoloader autoloader-ref) (open rep rep.structures) ;; (GETTER SYMBOL) => VALUE ;; (SETTER SYMBOL VALUE [REST...]) ;; used to tag autoload cells (in the car, cdr is module name) (define autoload-tag (make-symbol "autoload")) ;; Return a function of two args (SYMBOL MODULE) that can be ;; used to create autoload definitions. GETTER should return ;; the current definition of SYMBOL; SETTER should set the ;; current definition to VALUE (define (make-autoloader getter setter) (lambda (symbol module . rest) (unless (getter symbol) (apply setter symbol (cons autoload-tag module) rest)))) ;; Return a function of one arg (SYMBOL) that returns the definition ;; of SYMBOL. If an autoload has been installed for that identifier, ;; load it, then dereference SYMBOL for a second time. (define (autoloader-ref getter) (lambda (symbol) (let ((value (getter symbol))) (if (eq (car value) autoload-tag) (progn (intern-structure (cdr value)) (getter symbol)) value))))) librep-0.90.2/lisp/rep/threads/utils.jl0000644000175200017520000000210711245011153016734 0ustar chrischris;; threads.jl -- some thread utilities ;; Copyright (C) 2000 John Harper ;; $Id$ ;; This file is part of librep. ;; librep is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; librep is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with librep; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (define-structure rep.threads.utils (export without-interrupts) (open rep) (defmacro without-interrupts forms "Evaluate `(progn FORMS)' with thread preemption disabled." `(unwind-protect (progn (thread-forbid) ,@forms) (thread-permit)))) librep-0.90.2/lisp/rep/threads/proxy.jl0000644000175200017520000000502511245011153016757 0ustar chrischris#| proxy.jl -- move a function to a separate thread $Id$ Copyright (C) 2001 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# ;; I don't think I ever tested this code, but I'm tired of having it ;; sitting in working copy of the sources.. (define-structure rep.threads.proxy (export make-thread-proxy thread-proxy-async-call thread-proxy-delete) (open rep rep.threads rep.threads.message-port) (define special-token (cons)) (define (make-thread-proxy function) (let ((in-port (make-message-port)) proxy-thread) (define (thread-thunk) (while t (let ((data (message-fetch in-port))) (case (car data) ((sync-call) (let ((return-port (cadr data)) (args (cddr data))) (call-with-exception-handler (lambda () (let ((result (apply function args))) (message-send return-port (cons t result)))) (lambda (exception) (message-send return-port (cons nil exception)))))) ((async-call) (apply function (cdr data))) (t (error "Unknown proxy operation: %s\n" (car data))))))) (define (proxy . args) (if (eq (car args) special-token) (case (cadr args) ((async) (message-send in-port (cons 'async-call (cddr args)))) ((get-thread) proxy-thread) (t (error "Unknown special call: %s" (cadr args)))) ;; synchronous call (let ((return-port (make-message-port))) (message-send in-port (list* 'sync-call return-port args)) (let ((result (message-fetch return-port))) (if (car result) (cdr result) (raise-exception (cdr result))))))) (setq proxy-thread (make-thread thread-thunk "object-proxy")) proxy)) (define (thread-proxy-async-call proxy . args) (apply proxy special-token 'async args)) (define (thread-proxy-delete proxy) (thread-delete (proxy special-token 'get-thread)))) librep-0.90.2/lisp/rep/threads/mutex.jl0000644000175200017520000000452011245011153016737 0ustar chrischris;; mutex.jl -- thread mutex devices ;; Copyright (C) 2000 John Harper ;; $Id$ ;; This file is part of librep. ;; librep is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; librep is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with librep; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (define-structure rep.threads.mutex (export make-mutex mutexp obtain-mutex maybe-obtain-mutex release-mutex) (open rep rep.threads rep.threads.utils) (define-structure-alias mutex rep.threads.mutex) ;; Each mutex is (mutex [OWNING-THREAD [BLOCKED-THREADS...]]) (defun make-mutex () "Create and return a mutex object. No thread will own the new mutex." (list 'mutex)) (defun mutexp (arg) "Returns true if ARG is a mutex object." (eq (car arg) 'mutex)) (defun obtain-mutex (mtx #!optional timeout) "Obtain the mutex MTX for the current thread. Will suspend the current thread until the mutex is available. Returns false if the timeout expired." (without-interrupts (if (null (cdr mtx)) (rplacd mtx (list (current-thread))) (rplacd mtx (nconc (cdr mtx) (list (current-thread)))) (not (thread-suspend (current-thread) timeout))))) (defun maybe-obtain-mutex (mtx) "Attempt to obtain mutex MTX for the current thread without blocking. Returns true if able to obtain the mutex, false otherwise." (without-interrupts (if (cdr mtx) nil (obtain-mutex mtx) t))) (defun release-mutex (mtx) "Release the mutex object MTX (which should have previously been obtained by the current thread). Returns true if the mutex has no new owner." (or (eq (cadr mtx) (current-thread)) (error "Not owner of mutex: %S" mtx)) (without-interrupts (rplacd mtx (cddr mtx)) (if (cdr mtx) (progn (thread-wake (cadr mtx)) nil) t)))) librep-0.90.2/lisp/rep/threads/message-port.jl0000644000175200017520000000635211245011153020210 0ustar chrischris#| message-port.jl -- inter-thread communication channels $Id$ Copyright (C) 2001 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.threads.message-port (export make-message-port message-port-p message-fetch message-send message-waiting-p) (open rep rep.threads rep.threads.mutex rep.threads.condition-variable rep.data.records rep.data.queues) (define-record-type :message-port (create-port queue mutex condition) message-port-p (queue port-queue) (mutex port-mutex) (condition port-condition)) (define (make-message-port) "Create and return a new message port." (create-port (make-queue) (make-mutex) (make-condition-variable))) (define (message-waiting-p port) "Return true if there are messages waiting on message port PORT." (obtain-mutex (port-mutex port)) (unwind-protect (not (queue-empty-p (port-queue port))) (release-mutex (port-mutex port)))) (define (message-fetch port #!optional timeout) "Fetch the earliest unread message sent to message port PORT. Blocks the current thread for TIMEOUT milliseconds, or indefinitely if TIMEOUT isn't defined. Returns the message, or false if no message could be read." (obtain-mutex (port-mutex port)) (unwind-protect (let again ((can-wait t)) (if (queue-empty-p (port-queue port)) (if can-wait (again (condition-variable-wait (port-condition port) (port-mutex port) timeout)) nil) ;; we have a waiting message (dequeue (port-queue port)))) (release-mutex (port-mutex port)))) (define (message-send port message) "Send the message MESSAGE (an arbitrary value) to message port PORT." (obtain-mutex (port-mutex port)) (unwind-protect (progn (enqueue (port-queue port) message) (condition-variable-signal (port-condition port))) (release-mutex (port-mutex port))))) #| Test function: (define (test) (let ((port (make-message-port))) (define (master) (do ((i 0 (1+ i))) ((= i 10)) (thread-suspend (current-thread) (random 1000)) (let ((data (make-string i (+ (random 10) #\0)))) (message-send port data) (format standard-output "master: sent %S\n" data)))) (define (slave) (do ((i 0 (1+ i))) ((= i 10)) (thread-suspend (current-thread) (random 1000)) (let ((data (message-fetch port))) (format standard-output "slave: received %S\n" data)))) (call-with-dynamic-root (lambda () (random t) (make-thread slave "slave") (make-thread master "master"))))) |# librep-0.90.2/lisp/rep/threads/condition-variable.jl0000644000175200017520000000651011245011153021347 0ustar chrischris#| condition-variable.jl -- condition variables $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.threads.condition-variable (export make-condition-variable condition-variable-p condition-variable-wait condition-variable-signal condition-variable-broadcast) (open rep rep.data.datums rep.threads rep.threads.utils rep.threads.mutex) (define key (cons)) (define (make-condition-variable) (make-datum '() key)) (define (condition-variable-p arg) (has-type-p arg key)) (define-datum-printer key (lambda (arg stream) (declare (unused arg)) (write stream "#"))) (define (cv-ref cv) (datum-ref cv key)) (define (cv-set cv x) (datum-set cv key x)) (define (condition-variable-wait cv mutex #!optional timeout) (let ((thread (current-thread)) (acquired nil)) (unless (memq thread (cv-ref cv)) (cv-set cv (cons thread (cv-ref cv)))) (without-interrupts ;; these two operations are atomic to prevent people ;; signalling the condition before we actually suspend (release-mutex mutex) (setq acquired (not (thread-suspend thread timeout)))) (obtain-mutex mutex) acquired)) (define (condition-variable-signal cv) (when (cv-ref cv) (let ((thread (last (cv-ref cv)))) (cv-set cv (delq thread (cv-ref cv))) (thread-wake thread)))) (define (condition-variable-broadcast cv) (let ((threads (cv-ref cv))) (cv-set cv '()) ;; wake in fifo order (mapc thread-wake (nreverse threads))))) #| Test program: (structure () (open rep rep.system rep.threads rep.threads.mutex rep.threads.condition-variable) (define mutex (make-mutex)) (define access (make-condition-variable)) (define count 0) (define data 0) (define (producer n) (do ((i 1 (+ i 1))) ((> i n)) (obtain-mutex mutex) (while (= count 1) (condition-variable-wait access mutex)) (setq data i) (setq count (1+ count)) (condition-variable-signal access) (release-mutex mutex))) (define (consumer n) (do ((i 1 (+ i 1))) ((> i n)) (obtain-mutex mutex) (while (= count 0) (condition-variable-wait access mutex)) (format standard-error "consumed: %d\n" data) (setq count (1- count)) (condition-variable-signal access) (release-mutex mutex))) (let* ((arg (get-command-line-option "--num" t)) (n (if arg (string->number arg) 5)) (c (make-thread (lambda () (consumer n))))) ;; run the producer thread.. (producer n) ;; ..then wait for the consumer to terminate (thread-join c))) |# librep-0.90.2/lisp/rep/test/framework.jl0000644000175200017520000000723611245011153017126 0ustar chrischris#| rep.test.framework -- module to allow other modules to test themselves $Id$ Copyright (C) 2001 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.test.framework (export assert check test set-self-test-action disable-self-tests define-self-test autoload-self-test run-all-self-tests run-module-self-tests run-self-tests-and-exit ;; private functions used in macros self-test/failed self-test/disabledp) (open rep rep.util.autoloader rep.data.symbol-table) (define action-alist '((test . ()) (check . ()) (assertion . signal))) (define disabled '()) (define self-tests (make-symbol-table)) (define failed-tests (make-fluid)) ;;; random internal functions (define (abort-if-fatal type message) (let ((action (cdr (assq type action-alist)))) (case action ((exit) (throw 'exit 1)) ((signal) (signal (intern (concat (symbol-name type) "-failed")) (and message (list message))))))) (define (self-test/failed type message) (format standard-error "\n ** %s failed: %s\n\n" (capitalize-string (symbol-name type)) message) (when (and (eq type 'test) (fluid failed-tests)) (fluid-set failed-tests (1+ (fluid failed-tests)))) (abort-if-fatal type message)) (define (self-test/disabledp type) (memq type disabled)) ;;; configuration (define (set-self-test-action type action) (let ((cell (assq type action-alist))) (if cell (rplacd cell action) (setq action-alist (cons (cons type action) action-alist))))) (define (disable-self-tests type) (unless (memq type disabled) (setq disabled (cons type disabled)))) ;;; test management (define (ref-1 x) (symbol-table-ref self-tests x)) (define (set-1 x y) (symbol-table-set self-tests x y)) (define (walk f) (symbol-table-walk f self-tests)) ;; initialize autoloading (define define-self-test set-1) (define autoload-self-test (make-autoloader ref-1 set-1)) (define self-test-ref (autoloader-ref ref-1)) (define (run-all-self-tests) (let ((failures 0)) (walk (lambda (x) (setq failures (+ failures (run-module-self-tests x))))) failures)) (define (run-module-self-tests module) (let ((test-case (self-test-ref module))) (if (not test-case) 0 (format standard-error "%s\n" module) (let-fluids ((failed-tests 0)) (test-case) (fluid failed-tests))))) (define (run-self-tests-and-exit) (let ((failures (run-all-self-tests))) (throw 'quit (if (zerop failures) 0 1)))) ;;; test macros (defmacro assert (form) `(or (self-test/disabledp 'assertion) ,form (self-test/failed 'assertion ,(prin1-to-string form)))) (defmacro check (form) `(or (self-test/disabledp 'check) ,form (self-test/failed 'check ,(prin1-to-string form)))) (defmacro test (form) `(or (self-test/disabledp 'test) ,form (self-test/failed 'test ,(prin1-to-string form)))) ;;; load autoloads (load "rep/test/autoload")) librep-0.90.2/lisp/rep/test/data.jl0000644000175200017520000001370411245011153016037 0ustar chrischris#| rep.test.data -- checks for rep.data module $Id$ Copyright (C) 2001 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.data.self-tests () (open rep rep.data.records rep.test.framework) ;;; equality function tests ;; adapted from guile's test.scm (define (equality-self-test) (define (gen-counter) (let ((n 0)) (lambda () (setq n (1+ n)) n))) (test (eql 'a 'a)) (test (not (eql 'a 'b))) (test (eql 2 2)) (test (eql '() '())) (test (eql '10000 '10000)) (test (not (eql (cons 1 2) (cons 1 2)))) (test (not (eql (lambda () 1) (lambda () 2)))) (let ((p (lambda (x) x))) (test (eql p p))) (let ((g (gen-counter))) (test (eql g g))) (test (not (eql (gen-counter) (gen-counter)))) (letrec ((f (lambda () (if (eql f g) 'f 'both))) (g (lambda () (if (eql f g) 'g 'both)))) (test (not (eql f g)))) (test (eq 'a 'a)) (test (not (eq (list 'a) (list 'a)))) (test (eq '() '())) (test (eq car car)) (let ((x '(a))) (test (eq x x))) (let ((x '())) (test (eq x x))) (let ((x (lambda (x) x))) (test (eq x x))) (test (equal 'a 'a)) (test (equal '(a) '(a))) (test (equal '(a (b) c) '(a (b) c))) (test (equal "abc" "abc")) (test (equal 2 2)) (test (equal (make-vector 5 'a) (make-vector 5 'a)))) ;;; cons and list tests ;; adapted from guile's test.scm (define (cons-self-test) (test (consp '(a . b))) (test (consp '(a . 1))) (test (consp '(a b c))) (test (not (consp '()))) (test (not (consp '#(a b)))) (test (equal '(a) (cons 'a '()))) (test (equal '((a) b c d) (cons '(a) '(b c d)))) (test (equal '("a" b c) (cons "a" '(b c)))) (test (equal '(a . 3) (cons 'a 3))) (test (equal '((a b) . c) (cons '(a b) 'c))) (test (equal 'a (car '(a b c)))) (test (equal '(a) (car '((a) b c d)))) (test (equal 1 (car '(1 . 2)))) (test (equal '(b c d) (cdr '((a) b c d)))) (test (equal 2 (cdr '(1 . 2)))) (test (equal '(a 7 c) (list 'a (+ 3 4) 'c))) (test (equal '() (list))) (test (= 3 (length '(a b c)))) (test (= 3 (length '(a (b) (c d e))))) (test (= 0 (length '()))) (test (equal '(x y) (append '(x) '(y)))) (test (equal '(a b c d) (append '(a) '(b c d)))) (test (equal '(a (b) (c)) (append '(a (b)) '((c))))) (test (equal '() (append))) (test (equal '(a b c . d) (append '(a b) '(c . d)))) (test (equal 'a (append '() 'a))) (test (equal '(c b a) (reverse '(a b c)))) (test (equal '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))) (test (equal 'c (nth 2 '(a b c d)))) (test (equal '(a b c) (memq 'a '(a b c)))) (test (equal '(b c) (memq 'b '(a b c)))) (test (null (memq 'a '(b c d)))) (test (null (memq (list 'a) '(b (a) c)))) (test (equal '((a) c) (member (list 'a) '(b (a) c)))) (test (equal '(101 102) (memql 101 '(100 101 102)))) (let ((e '((a 1) (b 2) (c 3)))) (test (equal '(a 1) (assq 'a e))) (test (equal '(b 2) (assq 'b e))) (test (null (assq 'd e)))) (test (null (assq (list 'a) '(((a)) ((b)) ((c)))))) (test (equal '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))) (test (equal '(5 7) (assq 5 '((2 3) (5 7) (11 13)))))) ;;; tests for rep.data.records (define-record-type :pare (kons x y) pare? (x kar set-kar!) (y kdr)) (define-record-discloser :pare (lambda (x) (format nil "#" (kar x) (kdr x)))) (define (record-self-test) (define pare (kons 1 2)) (test pare) (test (pare? pare)) (test (eql (kar pare) 1)) (test (eql (kdr pare) 2)) (set-kar! pare 3) (test (eql (kar pare) 3))) ;;; string-util tests (define (string-util-self-test) (test (string-upper-case-p "FOO")) (test (not (string-upper-case-p "Foo"))) (test (not (string-upper-case-p "foo"))) (test (not (string-upper-case-p "123"))) (test (string-lower-case-p "foo")) (test (not (string-lower-case-p "Foo"))) (test (not (string-lower-case-p "FOO"))) (test (not (string-lower-case-p "123"))) (test (string-capitalized-p "Foo")) (test (string-capitalized-p "FOO")) (test (not (string-capitalized-p "foo"))) (test (string= (string-upcase "foo") "FOO")) (test (string= (string-upcase "FOO") "FOO")) (test (string= (string-upcase "Foo") "FOO")) (test (string= (string-upcase "123") "123")) (test (string= (string-downcase "FOO") "foo")) (test (string= (string-downcase "foo") "foo")) (test (string= (string-downcase "Foo") "foo")) (test (string= (string-downcase "123") "123")) (test (string= (capitalize-string "FOO") "FOO")) (test (string= (capitalize-string "foo") "Foo")) (test (string= (capitalize-string "Foo") "Foo")) (test (string= (capitalize-string "123") "123")) (test (string= (mapconcat identity '("foo" "bar" "baz") " ") "foo bar baz")) (test (string= (mapconcat identity '("foo" "bar" "baz") #\space) "foo bar baz")) (test (string= (mapconcat identity '() #\space) "")) (test (string= (mapconcat string-upcase '("foo" "bar" "baz") " ") "FOO BAR BAZ"))) (define (self-test) (equality-self-test) (cons-self-test) (record-self-test) (string-util-self-test)) ;;###autoload (define-self-test 'rep.data self-test)) librep-0.90.2/lisp/rep/test/autoload.jl0000644000175200017520000000247011245011153016734 0ustar chrischris#| autoload.jl -- auto-loaded definitions for test suite $Id$ Copyright (C) 2001 Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# #| To rebuild this file, load a tags file containing all lisp files into Jade, select this file, then evaluate: (let ((output-file (buffer-file-name))) (tags-map-buffers (lambda (buffer) (add-autoloads output-file buffer)))) |# ;;; ::autoload-start:: (autoload-self-test 'rep.data.queues 'rep.data.queues) (autoload-self-test 'rep.data 'rep.test.data) (autoload-self-test 'rep.www.quote-url 'rep.www.quote-url) (autoload-self-test 'rep.www.cgi-get 'rep.www.cgi-get) ;;; ::autoload-end:: librep-0.90.2/lisp/rep/net/rpc.jl0000644000175200017520000003551511245011153015525 0ustar chrischris#| rep.net.rpc -- simple RPC mechanisms for inter-host communication $Id$ Copyright (C) 2001 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# ;; Commentary: ;; This module implements a very simple RPC mechanism over TCP/IP ;; sockets. ;; Servers register functions that may be called by remote systems, ;; producing an id that can be used by the remote system (together with ;; the host name and chosen port number) to create a proxy function. ;; Calling the proxy function is then exactly the same as calling the ;; real function (with the exception that all data must be able to be ;; printed and re-read) ;; Using this module to create proxies for functions returned by the ;; `object' macro defined by rep.data.objects gives an object-oriented ;; rpc mechanism, somewhat like a dynamically-typed version of CORBA! ;; Example: ;; =Server= ;; (rpc-create-server) -- create rpc listener on a random port ;; (define (foo x) (+ x 42)) ;; (define foo-id (make-rpc-servant foo)) ;; `foo-id' is now a symbol that uniquely identifies the `foo' function ;; on this server. E.g. it may be something like `9s72fdln00-61vxd7' ;; To turn this into a globally valid id, use the servant-id->global-id ;; function: ;; (define foo-global-id (servant-id->global-id foo-id)) ;; this creates a string, e.g.: "9s72fdln00-61vxd7@1.2.3.4:2000" ;; =Client= ;; (define proxy (global-id->rpc-proxy "9s72fdln00-61vxd7@1.2.3.4:2000")) ;; Now `proxy' is a function that when called marshals all its ;; arguments, sends them to the server, along with the unique id, and ;; waits for a result to be returned, which it then unmarshals and ;; returns ;; Unlike CORBA it's not possible to transparently pass object ;; references (proxies) over an RPC call, and have them work at the ;; other end. ;; The solution is to convert the proxy to a global id, then pass that ;; over the RPC call, so that the other side can convert it into a new ;; proxy. ;; It's also possible to pass references from servers behind firewalls ;; (and thus can't create usable global ids). The solution here is to ;; pass the local servant-id to the remote server, which can then use ;; the remote-servant-id->rpc-proxy function. This knows that the given ;; servant id refers to the connection used to invoke the currently ;; executing rpc call (define-structure rep.net.rpc (export rpc-socket-listener rpc-output-handler rpc-create-server rpc-destroy-server register-rpc-server deregister-rpc-server make-rpc-servant destroy-rpc-servant call-with-rpc-servant async-rpc-call rpc-proxy->global-id rpc-proxy->servant-id servant-id->global-id remote-servant-id->global-id global-id->rpc-proxy) (open rep rep.io.sockets rep.io.processes rep.system rep.regexp rep.data.tables rep.data.records) (define debug-rpc nil) (define (debug fmt . args) (when debug-rpc (let ((print-escape t)) (apply format standard-error fmt args)))) (define-record-type :socket-data (make-socket-data closable) ;; no predicate (pending-data socket-pending-data socket-pending-data-set!) (closable socket-closable-p) (pending-calls socket-pending-calls socket-pending-calls-set!)) ;; The socket used to listen for connections to this server (or false) (define listener-socket nil) ;; The socket that was used to invoke the innermost called servant ;; implementation (define active-socket (make-fluid)) ;;; connection cache ;; maps from (SERVER-NAME . PORT-NUMBER) -> SOCKET (define socket-cache (make-table equal-hash equal)) ;; maps from SOCKET -> SOCKET-DATA (define socket-data-table (make-weak-table eq-hash eq)) ;; Return the socket associated with SERVER:PORT. If there isn't one, ;; try to connect to the server. Signals an error on failure (define (server-socket server port) (or (table-ref socket-cache (cons server port)) (open-server server port))) (define (register-rpc-server socket #!key closable) "Add the connection SOCKET to the table of known rpc connections. If CLOSABLE is true, then the socket could be closed and reopened simply by knowing its address and port number." (let ((server (socket-peer-address socket)) (port (socket-peer-port socket))) (table-set socket-cache (cons server port) socket) (table-set socket-data-table socket (make-socket-data closable)))) (define (deregister-rpc-server socket) "Remove SOCKET from the table of rpc connections." (let ((server (socket-peer-address socket)) (port (socket-peer-port socket))) (when (eq (table-ref socket-cache (cons server port)) socket) (table-unset socket-cache (cons server port))) (let ((data (socket-data socket))) (if (not data) (close-socket socket) (when (socket-closable-p data) (close-socket socket)) (table-unset socket-data-table socket) ;; fail-out any pending calls on this socket (mapc (lambda (id) (dispatch-pending-call socket id nil (list 'rpc-error "Lost connection" server port))) (socket-pending-calls data)))))) ;; Return the data structure associated with SOCKET (define (socket-data socket) (table-ref socket-data-table socket)) ;;; socket I/O ;; maps from ID -> (CALLBACK ERROR? VALUE) (define pending-calls (make-table eq-hash eq)) ;; XXX make this unspoofable (define make-call-id (let ((counter 0)) (lambda () (setq counter (1+ counter))))) (define (record-pending-call socket id callback) (table-set pending-calls id callback) (let ((data (socket-data socket))) (socket-pending-calls-set! data (cons id (socket-pending-calls data))))) (define (dispatch-pending-call socket id succeeded value) (let ((data (socket-data socket))) (socket-pending-calls-set! data (delq id (socket-pending-calls data)))) (let ((callback (table-ref pending-calls id))) (when callback (table-unset pending-calls id) (callback succeeded value)))) (define (rpc-socket-listener master-socket) "The function that should be used to listen for connections on rpc server sockets." (let (socket) (setq socket (socket-accept master-socket (lambda (output) (rpc-output-handler socket output)) (lambda () (deregister-rpc-server socket)))) (register-rpc-server socket #:closable nil) socket)) ;; Open an rpc connection to HOST:PORT; signals an error on failure (define (open-server host port) (let (socket) (setq socket (socket-client host port (lambda (x) (rpc-output-handler socket x)) (lambda () (deregister-rpc-server socket)))) (register-rpc-server socket #:closable t) socket)) (define (rpc-output-handler socket output) "The function used to handle any OUTPUT from SOCKET." (let ((sock-data (socket-data socket))) (socket-pending-data-set! sock-data (concat (socket-pending-data sock-data) output)) ;;(debug "Input: %S\n" (socket-pending-data sock-data)) (catch 'out (while t (let ((stream (make-string-input-stream (socket-pending-data sock-data))) form) (condition-case nil (setq form (read stream)) ((premature-end-of-stream end-of-stream) (throw 'out)) ((invalid-read-syntax) (error "Can't parse rpc message: %S" (socket-pending-data sock-data)))) (debug "Parsed: %S\n" form) ;; this function may be called reentrantly, so make sure the ;; state is always consistent.. (socket-pending-data-set! ;; stream is (STRING . POINT) sock-data (substring (cdr stream) (car stream))) (case (car form) ((result) ;; (result CALL-ID RETURNED? VALUE-OR-EXCEPTION) (let ((id (nth 1 form)) (succeeded (nth 2 form)) (value (nth 3 form))) (dispatch-pending-call socket id succeeded value))) ((call) ;; (call CALL-ID SERVANT-ID ARGS...) (let ((id (nth 1 form)) (servant-id (nth 2 form)) (args (nthcdr 3 form))) (let ((result (call-with-exception-handler (lambda () (let ((impl (servant-ref servant-id))) (unless impl (error "No such RPC servant: %s" servant-id)) (let-fluids ((active-socket socket)) (list t (apply impl args))))) (lambda (data) (list nil data))))) (when id (let ((response (list* 'result id result))) (debug "Wrote: %S\n" response) (write socket (prin1-to-string response))))))))))))) (define (invoke-method socket id callback servant-id args) (record-pending-call socket id callback) (let ((request (list* 'call id servant-id args))) (debug "Wrote: %S\n" request) (write socket (prin1-to-string request)))) (define (invoke-oneway-method socket servant-id args) (let ((request (list* 'call nil servant-id args))) (debug "Wrote: %S\n" request) (write socket (prin1-to-string request)))) (define (synchronous-method-call socket servant-id args) (let ((id (make-call-id)) (done nil) succeeded value) (invoke-method socket id (lambda (a b) (setq done t) (setq succeeded a) (setq value b)) servant-id args) (while (not done) (accept-process-output 60)) (if succeeded value (raise-exception value)))) (define (asynchronous-method-call socket callback servant-id args) (invoke-method socket (make-call-id) callback servant-id args)) (define (oneway-method-call socket servant-id args) (invoke-oneway-method socket servant-id args)) (define (rpc-create-server) "Start listening for rpc connections on the current machine" (unless listener-socket (setq listener-socket (socket-server nil nil rpc-socket-listener)))) (define (rpc-destroy-server) "Stop listening for rpc connections on the current machine" (when listener-socket (close-socket listener-socket) (setq listener-socket nil))) ;;; servants ;; map from ID->RPC-IMPL (define servant-table (make-table eq-hash eq)) ;; Create a new (unique) servant id (define (make-servant-id) (intern (concat (number->string (current-utime) 36) #\- (number->string (random) 36)))) ;; Return the servant implementation associated with ID (define (servant-ref id) (table-ref servant-table id)) (define (make-rpc-servant impl) "Register the function IMPL as an rpc servant, and return the created servant-id." (let ((id (make-servant-id))) (table-set servant-table id impl) id)) (define (destroy-rpc-servant id) "Remove the servant with servant-id ID from the table of servants." (table-unset servant-table id)) (define (call-with-rpc-servant impl callback) "Call the function CALLBACK with a single argument, the servant-id that can be used to call the function IMPL. Once CALLBACK returns, the servant-id becomes invalid." (let ((id (make-rpc-servant impl))) (unwind-protect (callback id) (destroy-rpc-servant id)))) ;;; proxies ;; magic object used to get information from proxies (define proxy-token (cons)) ;; table mapping GLOBAL-ID -> PROXY-WEAK-REF (define proxy-table (make-table string-hash string=)) (define (make-proxy server port servant-id) (let ((global-id (make-global-id server port servant-id))) (define (proxy) (lambda args (if (eq (car args) proxy-token) ;; when called like this, do special things (case (cadr args) ((global-id) global-id) ((servant-id) servant-id) ((oneway) ;; async request - no result required (oneway-method-call (server-socket server port) servant-id (cddr args))) ((async) (asynchronous-method-call (server-socket server port) (caddr args) servant-id (cdddr args)))) ;; otherwise, just forward to the server (synchronous-method-call (server-socket server port) servant-id args)))) ;; Avoid consing a new proxy each time.. (let ((ref (table-ref proxy-table global-id))) (if ref (or (weak-ref ref) (let ((p (proxy))) (weak-ref-set ref p) p)) (let ((p (proxy))) (table-set proxy-table global-id (make-weak-ref p)) p))))) (define (async-rpc-call proxy #!key callback . args) "Call the rpc proxy function PROXY with arguments ARGS. It will be called asynchronously. No result will be returned from the remote function unless CALLBACK is given, in which case (CALLBACK STATUS VALUE) will be called at some point in the future." (if callback (apply proxy proxy-token 'async callback args) (apply proxy proxy-token 'oneway args)) #undefined) (define (rpc-proxy->global-id proxy) "Return the globally-valid servant-id (a string) that can be used to reference the RPC proxy function PROXY." (proxy proxy-token 'global-id)) (define (rpc-proxy->servant-id proxy) "Return the unqualified servant-id (a symbol) that can be used to reference the RPC proxy function PROXY." (proxy proxy-token 'servant-id)) ;;; globally referenceable ids ;; Create the global servant id for ID@SERVER:PORT (define (make-global-id server port id) (format nil "%s@%s:%s" id server port)) (define (servant-id->global-id id) "Return the globally referenceable RPC servant id for local servant id ID." (unless listener-socket (error "Need an active local RPC server")) (make-global-id (socket-address listener-socket) (socket-port listener-socket) id)) (define (remote-servant-id->global-id id) "Return the globally referenceable RPC servant id for the local servant id ID (a symbol) associated with the invoker of the currently active RPC request." (unless (fluid active-socket) (error "Not called from an RPC servant")) (make-global-id (socket-peer-address (fluid active-socket)) (socket-peer-port (fluid active-socket)) id)) (define (global-id->rpc-proxy id) "Return a function that can be used to call the RPC associated with the global servant id ID (a string)." (unless (string-looking-at "(.+)@(.+):(.+)" id) (error "Badly formed global RPC servant id: %s" id)) (let ((servant-id (intern (expand-last-match "\\1"))) (server (expand-last-match "\\2")) (port (string->number (expand-last-match "\\3")))) (make-proxy server port servant-id))) ;;; initialization ;; ensure that the random numbers are random.. (random t)) librep-0.90.2/lisp/rep/net/domain-name.jl0000644000175200017520000000545411245011153017125 0ustar chrischris#| rep.net.domain-name -- domain name utility functions $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.net.domain-name (export domain-parts domain-above domain-above-p domain-below-p domain-equal-p map-domains map-domains-downwards) (open rep rep.regexp) (define (domain-parts domain) "Return the list of domain components that the string DOMAIN consists of." (string-split "\\." domain)) (define (domain-above domain) "Return the name of parent domain of the string DOMAIN." (and (string-match "\\." domain) (substring domain (match-end)))) ;; Returns +ve if D1 is a superset of D2, -ve if D1 is a subset of D2, ;; zero if (= D1 D2), or false if D1 and D2 aren't similar (define (compare-domains d1 d2) (let loop ((p1 (domain-parts d1)) (p2 (domain-parts d2)) (ret 0)) (cond ((> (length p1) (length p2)) (loop (cdr p1) p2 (1+ ret))) ((< (length p1) (length p2)) (loop p1 (cdr p2) (1- ret))) ((and p1 p2) (if (string= (car p1) (car p2)) (loop (cdr p1) (cdr p2) ret) nil)) (t ret)))) (define (domain-above-p d1 d2) "Return true if domain name D1 is `above' domain name D2." (let ((value (compare-domains d1 d2))) (and value (< value 0)))) (define (domain-below-p d1 d2) "Return true if domain name D1 is `below' domain name D2." (let ((value (compare-domains d1 d2))) (and value (> value 0)))) (define (domain-equal-p d1 d2) "Return true if the domain names D1 and D2 are the same" (string= d1 d2)) (define (map-domains fun domain) "Call (FUN NAME) for each sub-domain of DOMAIN (starting with DOMAIN)." (when domain (fun domain) (map-domains fun (domain-above domain)))) (define (map-domains-downwards fun domain) "Call (FUN NAME) for each sub-domain of DOMAIN (ending with DOMAIN)." (let ((parts (nreverse (domain-parts domain)))) (let loop ((current (car parts)) (todo (cdr parts))) (fun current) (when todo (loop (concat (car todo) ?. current) (cdr todo))))))) librep-0.90.2/lisp/rep/mail/addr.jl0000644000175200017520000000241411245011153015777 0ustar chrischris;;;; mailaddr.jl -- Minor mail configuration ;;; Copyright (C) 1997 John Harper ;;; $Id$ ;;; This file is part of Jade. ;;; Jade is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2, or (at your option) ;;; any later version. ;;; Jade is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; You should have received a copy of the GNU General Public License ;;; along with Jade; see the file COPYING. If not, write to ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (define-structure rep.mail.addr () (open rep rep.regexp rep.system) (define-structure-alias mailaddr rep.mail.addr) (defvar mail-domain-name (if (string-match "^([^.]+\\.)[^.]+" (system-name)) (substring (system-name) (match-end 1)) (system-name)) "Mail domainname of the local site.") (defvar user-mail-address (concat (user-login-name) ?\@ mail-domain-name) "Address to put in From: headers of outgoing mail.")) librep-0.90.2/lisp/rep/lang/profiler.jl0000644000175200017520000000372611245011153016715 0ustar chrischris#| profiler.jl -- interface to low-level lisp profiler $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.lang.profiler (export call-in-profiler print-profile profile-interval) (open rep rep.lang.record-profile rep.data.symbol-table) (define (call-in-profiler thunk) (start-profiler) (unwind-protect (thunk) (stop-profiler))) (define (print-profile #!optional stream) ;; each element is (SYMBOL . (LOCAL . TOTAL)) (let ((profile '()) (total-samples 0)) (symbol-table-walk (lambda (key data) (setq profile (cons (cons key data) profile)) (setq total-samples (+ total-samples (car data)))) (fetch-profile)) (setq profile (sort profile (lambda (x y) (> (cadr x) (cadr y))))) (format (or stream standard-output) "%-32s %10s %10s\n\n" "Function Name" "Self" "Total") (mapc (lambda (cell) (let ((name (car cell)) (local (cadr cell)) (total (cddr cell))) (when (> local 0) (format (or stream standard-output) "%-32s %10d (%02.2d%%) %10d (%02.2d%%)\n" (symbol-name name) local (round (* (/ local total-samples) 100)) total (round (* (/ total total-samples) 100)))))) profile)))) librep-0.90.2/lisp/rep/lang/math.jl0000644000175200017520000000362311245011153016020 0ustar chrischris#| rep.lang.math bootstrap $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.lang.math)) (open-structures '(rep.lang.symbols rep.data)) ;; numeric functions (defun realp (x) "Return t if X is a real number." (numberp x)) (defun rationalp (x) "Return t if X is a (possibly inexact) rational number." (numberp x)) (defun inexactp (x) "Return t if X is an inexact number." (and (numberp x) (not (exactp x)))) (defun positivep (x) "Return t if X is greater than zero." (> x 0)) (defun negativep (x) "Return t if X is less than zero." (< x 0)) (defun oddp (x) "Return t if X is odd, i.e. (/= (mod X 2) 0)." (not (zerop (mod x 2)))) (defun evenp (x) "Return t if X is odd, i.e. (= (mod X 2) 0)." (zerop (mod x 2))) (defun abs (x) "Return the absolute value of X, i.e. (max X (- X))." (max x (- x))) (defun lcm args "Return the least common multiple of integers A and B." (if (null args) 1 (quotient (apply * (mapcar abs args)) (apply gcd args)))) (%define % remainder) (%define modulo mod) (%define lsh ash) ;; exports (export-bindings '(realp rationalp inexactp positivep negativep oddp evenp abs lcm % modulo lsh)) librep-0.90.2/lisp/rep/lang/interpreter.jl0000644000175200017520000004527011245011153017436 0ustar chrischris#| bootstrap for rep.lang.interpreter $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (open-structures '(rep.lang.symbols rep.data rep.system rep.io.streams rep.io.files)) (%define nil '() "The value of the boolean-false and end-of-list object.") (%define t 't "The symbol often used as the canonical boolean-true value.") (make-binding-immutable 'nil) (make-binding-immutable 't) (%define #F nil) (%define #T t) (make-binding-immutable '#F) (make-binding-immutable '#T) (%define #undefined '#undefined) (export-bindings '(nil t #F #T #undefined)) ;; function syntax (%define defmacro (cons 'macro (lambda (symbol . body) (cond ((bytecodep (car body)) (setq body (car body))) (t (setq body (list 'quote (cons 'lambda body))))) (list '%define symbol (list 'cons (list 'quote 'macro) (list 'make-closure body (symbol-name symbol)))))) "defmacro NAME LAMBDA-LIST [DOC-STRING] BODY... defmacro NAME BYTECODE-OBJECT Defines a macro called NAME with argument spec. LAMBDA-LIST, documentation DOC-STRING (optional) and body BODY. Macros are called with their arguments un-evaluated, they are expected to return a form which will be executed to provide the result of the expression. Note that macros are expanded at compile-time, and may be expanded an arbitrary number of times.") (defmacro defun (symbol . body) "defun NAME LAMBDA-LIST [DOC-STRING] BODY... defun NAME BYTECODE-OBJECT Defines a function called NAME with argument specification LAMBDA-LIST, documentation DOC-STRING (optional) and body BODY." (cond ((bytecodep (car body)) (setq body (car body))) (t (setq body (list 'quote (cons 'lambda body))))) (list '%define symbol (list 'make-closure body (symbol-name symbol)))) (defmacro defconst (symbol value . rest) "defconst NAME VALUE [DOC-STRING] Define a constant NAME whose (default) value is VALUE. If NAME is already bound an error is signalled. Constants are treated specially by the Lisp compiler, basically they are hard-coded into the byte-code." (list 'progn (list* '%define symbol (list 'quote value) rest) (list '%make-binding-immutable (list 'quote symbol)))) (defmacro defsubst (symbol . body) "Defines a function that will be compiled inline to any functions that call it. Otherwise exactly the same as defun." ;; These actions are also hard-coded into dump.jl (list* 'defun symbol body)) (defmacro function (arg) "#'ARG Return the closure from ARG, either a lambda-expression, or a symbol. When applied to a symbol, the symbol's value is returned." (if (symbolp arg) arg (list 'make-closure (list 'quote arg)))) (%define %make-binding-immutable make-binding-immutable) (export-bindings '(defmacro defun defconst defsubst function %make-binding-immutable)) ;; Binding syntax (defmacro let args "let [VAR] (BINDINGS...) BODY... Binds temporary values to symbols while BODY is being evaluated. Each of the BINDINGS is either a list `(SYMBOL FORMS...)' in which case the variable SYMBOL is bound to the result of evaluating `(progn FORMS...)', or a single symbol, in which case it is bound to the false value. If VAR is given, then the symbol VAR is bound to a function whose formal parameters are the same as the variables bound by the `let' form. Thus the execution of BODY... may be repeated by invoking VAR." ((lambda (fun vars values) (cond ((symbolp (car args)) ;; named let (setq fun (car args)) (setq args (cdr args)))) (setq vars (mapcar (lambda (x) (if (consp x) (car x) x)) (car args))) (setq values (mapcar (lambda (x) (if (consp x) (cons 'progn (cdr x)) nil)) (car args))) (cond (fun (list 'letrec (list (list fun (list* 'lambda vars (cdr args)))) (cons fun values))) (t (cons (list* 'lambda vars (cdr args)) values)))) nil nil nil)) (defmacro let* args "let (BINDINGS...) BODY... Similar to `let' except that the BINDINGS are installed as their values are computed, in the order they are written." (let loop ((rest (reverse (car args))) (body (cons 'progn (cdr args)))) (cond ((null rest) body) (t (loop (cdr rest) (list 'let (list (car rest)) body)))))) (defmacro letrec (bindings . body) "Similar to `let' and `let*' except that the values of the BINDINGS are evaluated such that all of the bound variables are in the scope. This means that `letrec' may be used to define mutually recursive functions." ((lambda (vars setters) (list* 'let vars (nconc setters body))) (mapcar (lambda (x) (cond ((consp x) (car x)) (t x))) bindings) (mapcar (lambda (x) (cond ((consp x) (list 'setq (car x) (cons 'progn (cdr x)))) (t (list 'setq x nil)))) bindings))) (defmacro let-fluids (bindings . body) "Similar to `let' except that the BINDINGS must refer to variables containing fluid objects. The fluids will be bound to new locations, not the variables containing the fluids." (let ((fluids nil) (values nil)) (mapc (lambda (x) (setq fluids (cons (car x) fluids)) (setq values (cons (cons 'progn (cdr x)) values))) bindings) (list 'with-fluids (cons 'list fluids) (cons 'list values) (list* 'lambda '() body)))) (export-bindings '(let let* letrec let-fluids)) ;; Conditional syntax (defmacro if (condition then #!rest else) "First the CONDITION form is evaluated, if it returns true the TRUE-FORM is evaluated and its result returned. Otherwise the result of an implicit progn on the ELSE forms is returned. If there are no ELSE forms the false value is returned." (cond (else (list 'cond (list condition then) (cons t else))) (t (list 'cond (list condition then))))) (defmacro case (key . clauses) "Each CLAUSE is `((ITEMS... ) FORMS...)'. Find the first CLAUSE with an ITEM matching (using `eql') the result of evaluating KEY (only evaluated once), then evaluate the associated FORMS in a `progn'. The final clause may have the form `(t FORMS...)', which always matches KEY if no other CLAUSE has already. Returns false if no clause matches. If any of the ITEMS appear more than once, then the behaviour is undefined." (let ((tem (gensym))) (let loop ((body nil) (rest clauses)) (if rest (let ((this (car rest))) (loop (cons (cond ((eq (car this) t) (cons 't (cdr this))) ((cdar this) (cons (list 'memql tem (list 'quote (car this))) (cdr this))) (t (cons (list 'eql tem (list 'quote (caar this))) (cdr this)))) body) (cdr rest))) (list 'let (list (list tem key)) (cons 'cond (nreverse body))))))) (defmacro when (condition #!rest forms) "Evaluates CONDITION, if it is true an implicit progn is performed with FORMS." (list 'if condition (cons 'progn forms))) (defmacro unless (condition #!rest forms) "Evaluates CONDITION, if it is nil an implicit progn is performed with FORMS." (list 'if (list 'not condition) (cons 'progn forms))) (defmacro or args "The first of the ARGS is evaluated, if it is true its value is the value of the `or' form and no more arguments are evaluated. Otherwise this step is repeated for the next member of ARGS. If all of the ARGS have been evaluated and none have a true value `()' is the value of the `or' form. If there are no ARGS the false value is returned." (if (null args) 'nil (cons 'cond (mapcar list args)))) (defmacro and args "The first of the ARGS is evaluated. If it is false no more of the ARGS are evaluated and the `and' statement evaluates to false. Otherwise the next member of ARGS is evaluated and its value tested. If none of the ARGS are false the computed value of the last member of ARGS is returned from the `and' form." (if (null args) 't (let loop ((rest (nreverse args)) (body nil)) (cond ((null rest) body) (t (loop (cdr rest) (if body (list 'cond (list (car rest) body)) (list 'cond (list (car rest)))))))))) (export-bindings '(if case when unless or and)) ;; set syntax (defmacro setq-default args "setq-default { VARIABLE FORM } ... Sets the default value of each VARIABLE to the value of its corresponding FORM evaluated, returns the value of the last evaluation. See also `setq'. Returns the value of the last FORM." (let loop ((rest args) (body nil)) (if (null rest) (cons 'progn (nreverse body)) (loop (cddr rest) (cons (list 'set-default (list 'quote (car rest)) (nth 1 rest)) body))))) ;; XXX it would be nice to do the same for setq.. might stress the ;; XXX interpreter somewhat..? :-( (defmacro define-special-variable (var #!optional value doc) "define-special-variable VARIABLE [VALUE [DOC]] Declares the symbol VARIABLE as a special variable, then unconditionally sets its value to VALUE (or false if VALUE isn't defined). If DOC is given it will be installed as the documentation string associated with VARIABLE." (list 'progn (list 'defvar var nil doc) (list 'setq var value))) (export-bindings '(setq-default define-special-variable)) ;; Misc syntax (defmacro do (vars test . body) "do VARS (TEST EXPR...) BODY... `do' is an iteration construct; VARS specifies a set of variable bindings to be created, how they are initialized and how they are updated on each iteration. TEST specifies the termination condition of the loop, any EXPR... forms are evaluated immediately prior to exiting the `do' construct. The BODY... forms specify the side effecting body of the loop. VARS is a list of variable clauses, each of which has the structure `(VARIABLE INIT STEP)' where VARIABLE is the name of a variable, INIT defines the initial value of its binding, and STEP defines how the next value of the binding is computed. An alternative form is `(VARIABLE INIT)', in this case the value of the binding does not change across loop iterations. Each iteration begins by evaluating TEST, if the result is false, then the BODY... expressions are evaluated, and the variables bound to new locations initialized to the results of evaluating the associated STEP forms. If the result of evaluating TEST is true then the EXPR... forms are evaluated, and the `do' construct returns the value of the last EXPR form evaluated. (do ((vec (make-vector 5)) (i 0 (1+ i))) ((= i 5) vec) (aset vec i i)) => [0 1 2 3 4]" (let ((tem (gensym))) (list 'let tem (mapcar (lambda (var) (list (car var) (nth 1 var))) vars) (list* 'if (car test) (cons 'progn (cdr test)) (append body (list (cons tem (mapcar (lambda (var) (if (cddr var) (caddr var) (car var))) vars)))))))) (defmacro while (condition . body) "while CONDITION BODY... `while' is an imperative looping construct. CONDITION is evaluated, if it produces a true value, then the sequence of BODY... forms are evaluated using an implicit `progn' statement, and control passes back to the beginning of the while form. When the VALUE of CONDITION is false, the while statement is exited, returning an undefined value." ((lambda (tem) (list 'let tem '() (list 'cond (list condition (cons 'progn body) (list tem))))) (gensym))) (defmacro prog1 (form1 . forms) "First evals FORM1 then FORMS, returns the value that FORM1 gave." (let ((tem (gensym))) (list (list* 'lambda (list tem) (append forms (list tem))) form1))) (defmacro prog2 args "prog2 FORM1 FORM2 [FORMS...] Evaluate FORM1 discarding its result, then evaluate FORM2 followed by `(progn FORMS...)'. Returns the result of evaluating FORM2." (list 'progn (car args) (cons 'prog1 (cdr args)))) (defmacro with-object (obj . body) "Evaluate OBJ and make its value ``current'' in some way meaningful for the data type, evaluate all BODY forms, then return to the old current value of whatever was changed. Return the value of the last BODY form evaluated." (list 'call-with-object obj (list* 'lambda '() body))) ;; hide compiler declarations (defmacro declare () "declare CLAUSES... Provide the compiler with extra information while compiling the forms that appear in the same lexical scope as the declaration. Each CLAUSE is a list, the first element of which is a symbol defining the type of declaration, the other elements relate to the declaration. See the `Compiler Declarations' node of the librep manual for details of the possible declaration types.") (export-bindings '(do while prog1 prog2 with-object declare)) ;; exception handling and syntax ;; Call and return value of THUNK with a catch for TAG (defun call-with-catch (tag thunk) (call-with-exception-handler thunk (lambda (data) (if (eq (car data) tag) (cdr data) (raise-exception data))))) ;; Call and return value of THUNK. PROT-THUNK will always be called ;; after THUNK terminates, exception or no exception (defun call-with-unwind-protect (thunk prot-thunk) (let (saved-data) (let ((ret (call-with-exception-handler thunk (lambda (data) (setq saved-data data))))) (prot-thunk) (if saved-data (raise-exception saved-data) ret)))) ;; HANDLERS is list of (ERROR-SPEC . HANDLER-FUN) HANDLER-FUN will be ;; called with a single arg, the list of error data (defun call-with-error-handlers (thunk . handlers) (call-with-exception-handler thunk (lambda (data) (if (not (eq (car data) 'error)) (raise-exception data) (let ((type (nth 1 data))) (let loop ((rest handlers)) (if (null rest) (raise-exception data) (let ((h-type (caar rest))) (if (or (and (listp h-type) (memq type h-type)) (eq h-type 'error) (eq h-type type)) ((cdar rest) (cdr data)) (loop (cdr rest))))))))))) (defmacro catch (tag . body) "Evaluate BODY in an implicit progn; non-local exits are allowed with `(throw TAG)'. The value of the `catch' form is either the value of the progn or the value given to any matching `throw' form." (list 'call-with-catch tag (list* 'lambda '() body))) (defun throw (tag #!optional value) "Performs a non-local exit to the `catch' form waiting for TAG and return VALUE from it." (raise-exception (cons tag value))) (defmacro unwind-protect (form . body) "Return the result of evaluating FORM. When execution leaves the dynamic extent of FORM evaluate `(progn BODY)' (even if exiting due to an exception within FORM). Note that when FORM is exited by calling a continuation, it is undefined whether or not BODY will be evaluated." (list 'call-with-unwind-protect (list 'lambda '() form) (list* 'lambda () body))) (defmacro condition-case (var form . handlers) "Evaluates FORM with error-handlers in place, if no errors occur return the value returned by FORM, else the value of whichever handler's body was evaluated. Each HANDLER is a list of `(ERROR BODY...)'. ERROR defines which types of errors the handler catches, either a symbol or a list of symbols. The special symbol `error' matches all types of errors. If VAR is true it's a symbol whose values is bound to `(ERROR-SYMBOL . DATA)' while the handler is evaluated (these are the arguments given to `signal' when the error was raised)." (list* 'call-with-error-handlers (list 'lambda '() form) (mapcar (lambda (h) (list 'cons (list 'quote (car h)) (list* 'lambda (and (symbolp var) (not (eq var 'nil)) (list var)) (cdr h)))) handlers))) ;; default error handler (defun default-error-handler (err data) (call-with-exception-handler (lambda () (beep) (write t (format nil "*** %s: %s" (or (get err 'error-message) err) (mapconcat (lambda (x) (format nil "%s" x)) data ", "))) ;; XXX ugh.. so kludgey.. (open-structures '(rep.lang.error-helper)) (declare (bound error-helper)) (error-helper err data)) (lambda (ex) ;; really don't want to have errors happening in here.. (unless (eq (car ex) 'error) (raise-exception ex))))) (defvar error-handler-function default-error-handler) (export-bindings '(call-with-catch call-with-unwind-protect call-with-error-handlers catch throw unwind-protect condition-case default-error-handler)) ;; Function to allow easy creation of autoload stubs (defmacro make-autoload (symbol-form file . rest) (list 'make-closure (list 'list* ''autoload symbol-form file (list 'quote rest)))) (defmacro autoload (symbol-form file #!rest extra) "Tell the evaluator that the value of SYMBOL will be initialised by loading FILE." (list '%define (nth 1 symbol-form) (list* 'make-autoload symbol-form file extra))) (defmacro autoload-macro (symbol-form file #!rest extra) "Tell the evaluator that the value of the macro SYMBOL will be initialised by loading FILE." (list '%define (nth 1 symbol-form) (list 'cons ''macro (list* 'make-autoload symbol-form file extra)))) (export-bindings '(make-autoload autoload autoload-macro)) ;; some scheme compatibility functions (%define call-with-current-continuation call/cc) (defun dynamic-wind (before thunk after) "Call THUNK without arguments, returning the result of this call. BEFORE and AFTER are also called (without arguments), whenever execution respectively enters or leaves the dynamic extent of the call to THUNK. In the simplest case (when call/cc isn't used to pass control in or out of THUNK) each function will be called exactly once." (before) (unwind-protect (call-with-barrier thunk nil before after) (after))) (export-bindings '(call-with-current-continuation dynamic-wind)) ;; misc (defun error (#!rest args) (signal 'error (list (apply format nil args)))) (defun identity (arg) "Return ARG." arg) (defmacro eval-when-compile (form) "FORM is evaluated at compile-time *only*. The evaluated value is inserted into the compiled program. When interpreted, nil is returned." (declare (unused form)) nil) ;; Hide interactive decls (defmacro interactive ()) (defun nop () "A do-nothing command." (interactive)) (autoload-macro 'define "rep/lang/define") (autoload-macro 'define-macro "rep/lang/define") (autoload-macro 'with-internal-definitions "rep/lang/define") (export-bindings '(error identity eval-when-compile nop interactive eval define define-macro with-internal-definitions)) ;; do this last since declare is defined in this file (declare (in-module rep.lang.interpreter)) librep-0.90.2/lisp/rep/lang/error-helper.jl0000644000175200017520000000537311245011153017501 0ustar chrischris#| rep.lang.error-helper -- give hints about what's causing common lisp errors $Id$ Copyright (C) 2001 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.lang.error-helper (export error-helper) (open rep rep.regexp rep.data.tables rep.structures) ;; map error symbols to helper functions (define helper-table (make-table eq-hash eq)) (define output-stream (make-fluid standard-error)) (define (define-helper name function) (table-set helper-table name function)) (define (helper-ref name) (table-ref helper-table name)) (define (for-each-structure fun) (fun 'rep (get-structure 'rep)) (structure-walk (lambda (name struct) (unless (or (not struct) (eq name 'rep) (string-match "^%" (symbol-name name))) (fun name struct))) (get-structure '%structures))) (define (output fmt . args) (write (fluid output-stream) #\() (apply format (fluid output-stream) fmt args) (write (fluid output-stream) "\)\n")) (define (void-value-helper symbol) (case symbol ((export compound-interface structure-interface) (output "You may have the interface clause (`export', etc) of a module declaration in the wrong position.")) ((open access) (output "You may have the configuration clause (`open', etc) of a module declaration in the wrong position.")) (t (let ((structs '())) (for-each-structure (lambda (name struct) (when (structure-exports-p struct symbol) (setq structs (cons name structs))))) (cond ((null structs) (output "You're accessing an undefined variable or function `%s'" symbol)) ((null (cdr structs)) (output "You probably need to open the module `%s'" (car structs))) (t (output "You probably need to open one of the modules %s" (mapconcat (lambda (x) (format nil "`%s'" x)) (nreverse structs) ", ")))))))) (define-helper 'void-value void-value-helper) (define (error-helper error-symbol data) (let ((helper (helper-ref error-symbol))) (when helper (apply helper data))))) librep-0.90.2/lisp/rep/lang/doc.jl0000644000175200017520000001425411245011153015636 0ustar chrischris#| lisp-doc.jl -- Accessing LISP doc strings $Id$ Copyright (C) 1993, 1994, 2000 John Harper This file is part of Librep. Librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.lang.doc (export describe-lambda-list describe-value doc-file-value-key doc-file-param-key doc-file-ref doc-file-set documentation document-variable add-documentation add-documentation-params) (open rep rep.structures) (defun describe-lambda-list (lambda-list) (let ((output (make-string-output-stream))) ;; Print the arg list (one at a time) (while (consp lambda-list) (let ((arg-name (symbol-name (or (caar lambda-list) (car lambda-list))))) ;; Unless the it's a lambda-list keyword, print in capitals (unless (memq (car lambda-list) '(#!optional #!key #!rest &optional &rest)) (setq arg-name (string-upcase arg-name))) (format output " %s" arg-name)) (setq lambda-list (cdr lambda-list))) (when (and lambda-list (symbolp lambda-list)) (format output " . %s" (string-upcase (symbol-name lambda-list)))) (get-output-stream-string output))) (defun describe-value (value #!optional name structure) "Print to standard-output a description of the lisp data object VALUE. If NAME is true, then it should be the symbol that is associated with VALUE." (let* ((type (cond ((special-form-p value) "Special Form") ((macrop value) ;; macros are stored as `(macro . FUNCTION)' (setq value (cdr value)) "Macro") ((subrp value) "Native Function") ((closurep value) "Function") (t "Variable")))) (when (closurep value) (unless structure (let ((tem (closure-structure value))) (when (structure-name tem) (setq structure (structure-name tem))))) (setq value (closure-function value))) ;; Check if it's been compiled. (when (bytecodep value) (setq type (concat "Compiled " type))) (when (and name structure (not (special-variable-p name)) (binding-immutable-p name (get-structure structure))) (setq type (concat "Constant " type))) (when (and name (special-variable-p name)) (setq type (concat "Special " type))) (format standard-output "%s: " type) (let ((arg-doc (cond ((eq (car value) 'lambda) (describe-lambda-list (cadr value))) ((symbolp name) (or (and structure (doc-file-ref (doc-file-param-key name structure))) (doc-file-ref (doc-file-param-key name))))))) (if arg-doc (format standard-output "\(%s%s\)\n" (or name value) arg-doc) (format standard-output "%s\n" (or name value)))))) ;;; GDBM doc-file access (defun make-key (prefix name #!optional structure) (if structure (concat prefix (symbol-name structure) #\# (symbol-name name)) (concat prefix (symbol-name name)))) (defun doc-file-value-key (name #!optional structure) (make-key nil name structure)) (defun doc-file-param-key (name #!optional structure) (make-key 0 name structure)) (defun doc-file-ref (key) (require 'rep.io.db.gdbm) (catch 'done (mapc (lambda (file) ;; turn off read-locking -- DOC files are normally ;; created before being installed, and reportedly ;; AFS often prevents normal users gaining locks (let ((db (gdbm-open file 'read nil '(no-lock)))) (when db (unwind-protect (let ((value (gdbm-fetch db key))) (when value (throw 'done value))) (gdbm-close db))))) documentation-files) nil)) (defun doc-file-set (key value) (require 'rep.io.db.gdbm) ;; XXX I'm not convinced that turning off locking is wise.. (let ((db (gdbm-open documentation-file 'append nil '(no-lock)))) (when db (unwind-protect (gdbm-store db key value 'replace) (gdbm-close db))))) ;;; Accessing doc strings (defun documentation-property (#!optional structure) (if structure (intern (concat "documentation#" (symbol-name structure))) 'documentation)) (defun documentation (symbol #!optional structure value) "Returns the documentation-string for SYMBOL." (catch 'exit (when (and (not structure) (closurep value)) (let ((tem (closure-structure value))) (when (structure-name tem) (setq structure (structure-name tem))))) ;; First check for in-core documentation (when value (let ((tem value)) (when (eq 'macro (car tem)) (setq tem (cdr tem))) (when (and (closurep tem) (eq (car (closure-function tem)) 'lambda)) (setq tem (nth 2 (closure-function tem))) (when (stringp tem) (throw 'exit tem))))) (let ((doc (or (and structure (get symbol (documentation-property structure))) (get symbol (documentation-property))))) (when doc (throw 'exit doc))) ;; Then for doc strings in the databases (or (and structure (doc-file-ref (doc-file-value-key symbol structure))) (doc-file-ref (doc-file-value-key symbol))))) (defun document-variable (symbol structure doc-string) "Sets the documentation property of SYMBOL to DOC-STRING." (put symbol (documentation-property structure) doc-string) symbol) (defun add-documentation (symbol structure string) "Adds a documentation string STRING to the file of such strings." (doc-file-set (doc-file-value-key symbol structure) string)) (defun add-documentation-params (name structure param-list) "Records that function NAME (a symbol) has argument list PARAM-LIST." (doc-file-set (doc-file-param-key name structure) (describe-lambda-list param-list)))) librep-0.90.2/lisp/rep/lang/define.jl0000644000175200017520000001703311245011153016321 0ustar chrischris;; define.jl -- Scheme define syntax ;; Copyright (C) 2000 John Harper ;; $Id$ ;; This file is part of librep. ;; librep is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; librep is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with librep; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (declare (unsafe-for-call/cc)) (declare (in-module rep.lang.interpreter)) (open-structures '(rep.lang.backquote)) ;; Commentary: ;; This attempts to implement Scheme's elegant block-structured ;; function definitions. It will scan leading `define' forms from all ;; `define', `let', `let*', and `lambda' special forms (and from any ;; macros in terms of these special forms) ;; Note that the rep interpreter and compiler support scheme-like ;; lambda lists natively, so things like (define (foo . bar) ..) will ;; work correctly ;; Note^2 that this doesn't work quite like Scheme define, in that the ;; outermost define always affects the global environment (unless ;; within a with-internal-definitions block) [the reason for this ;; ugliness is to avoid redefining lambda] ;; List of currently bound variables. Used to avoid expanding macros ;; that have been rebound locally (%define define-bound-vars (make-fluid '())) ;; returns (SYM DEF [DOC]) (defun define-parse (args) (if (consp (car args)) (define-parse `(,(caar args) (lambda ,(cdar args) ,@(cdr args)))) (list* (car args) (define-scan-form (cadr args)) (and (stringp (caddr args)) (list (caddr args)))))) (defun define-scan-internals (body) (let (defs) (while (eq (caar body) 'define) (setq defs (cons (define-parse (cdar body)) defs)) (setq body (cdr body))) (if defs (list* 'letrec (mapcar (lambda (def) (list (car def) (cadr def))) (nreverse defs)) (define-scan-body body)) (let ((new-body (define-scan-body body))) (if (null (cdr new-body)) (car new-body) (cons 'progn new-body)))))) (defun define-scan-body (body) (let ((new (mapcar define-scan-form body))) (if (equal new body) body new))) (defun define-macroexpand-1 (form) (if (memq (car form) (fluid define-bound-vars)) form (macroexpand-1 form macro-environment))) ;; This needs to handle all special forms. It also needs to handle any ;; macros that the compiler wants to see without being expanded.. (defun define-scan-form (form) (if (atom form) form (case (if (memq (car form) (fluid define-bound-vars)) '() (car form)) ((let) (if (and (eq (car form) 'let) (cadr form) (symbolp (cadr form))) ;; named let, expand (define-scan-form (define-macroexpand-1 form)) (let loop ((rest (cadr form)) (vars '()) (clauses '())) (cond ((null rest) (list 'let (nreverse clauses) (let-fluids ((define-bound-vars (nconc vars (fluid define-bound-vars)))) (define-scan-internals (cddr form))))) ((consp (car rest)) (loop (cdr rest) (cons (caar rest) vars) (cons (cons (caar rest) (define-scan-body (cdar rest))) clauses))) (t (loop (cdr rest) (cons (car rest) vars) (cons (car rest) clauses))))))) ((let*) (let-fluids ((define-bound-vars (fluid define-bound-vars))) (let loop ((rest (cadr form)) (clauses '())) (cond ((null rest) (list 'let* (nreverse clauses) (define-scan-internals (cddr form)))) ((consp (car rest)) (fluid-set define-bound-vars (cons (caar rest) (fluid define-bound-vars))) (loop (cdr rest) (cons (cons (caar rest) (define-scan-body (cdar rest))) clauses))) (t (fluid-set define-bound-vars (cons (car rest) (fluid define-bound-vars))) (loop (cdr rest) (cons (car rest) clauses))))))) ((letrec) (let-fluids ((define-bound-vars (nconc (mapcar (lambda (x) (or (car x) x)) (cadr form)) (fluid define-bound-vars)))) (list 'letrec (mapcar (lambda (x) (if (consp x) (cons (car x) (define-scan-body (cdr x))) x)) (cadr form)) (define-scan-internals (cddr form))))) ((let-fluids) (list 'let-fluids (mapcar (lambda (x) (if (consp x) (cons (car x) (define-scan-body (cdr x))) x)) (cadr form)) (define-scan-internals (cddr form)))) ((setq) (let loop ((rest (cdr form)) (out nil)) (if rest (loop (cddr rest) (cons (list (car rest) (define-scan-form (cadr rest))) out)) (cons (car form) (apply nconc (nreverse out)))))) ((cond) (cons 'cond (mapcar (lambda (clause) (define-scan-body clause)) (cdr form)))) ((case) (list* 'case (define-scan-form (nth 1 form)) (mapcar (lambda (clause) (cons (car clause) (define-scan-body (cdr clause)))) (nthcdr 2 form)))) ((condition-case) (let ((var (if (eq (cadr form) 'nil) nil (cadr form)))) (let-fluids ((define-bound-vars (cons var (fluid define-bound-vars)))) (list* 'condition-case (cadr form) (define-scan-body (cddr form)))))) ((catch unwind-protect progn) (cons (car form) (define-scan-body (cdr form)))) ((quote structure-ref) form) ((lambda) (let ((vars (let loop ((rest (cadr form)) (vars '())) (cond ((null rest) vars) ((memq (or (caar rest) (car rest)) '(#!optional #!key #!rest &optional &rest)) (loop (cdr rest) vars)) (t (loop (cdr rest) (cons (or (caar rest) (car rest)) vars)))))) (body (nthcdr 2 form)) (header nil)) ;; skip doc strings and interactive decls.. (while (or (stringp (car body)) (eq (caar body) 'interactive)) (setq header (cons (car body) header)) (setq body (cdr body))) `(lambda ,(cadr form) ,@(nreverse header) ,(let-fluids ((define-bound-vars (nconc vars (fluid define-bound-vars)))) (define-scan-internals body))))) ((defvar) (list* 'defvar (nth 1 form) (define-scan-form (nth 2 form)) (nthcdr 3 form))) ((structure define-structure declare) form) (t (let ((expansion (define-macroexpand-1 form))) (if (eq expansion form) (define-scan-body form) (define-scan-form expansion))))))) ;;;###autoload (defmacro define (#!rest args) (let ((def (define-parse args))) (let ((var (car def)) (value (cadr def)) (doc (caddr def))) (if (eq (car value) 'lambda) `(defun ,var ,(cadr value) ,@(and doc (list doc)) ,@(let ((body (cddr value))) (if (and (eq (car body) 'progn) (null (cdr body))) (cdar body) body))) (cons '%define def))))) ;;;###autoload (defmacro define-macro (#!rest args) (let ((def (define-parse args))) (let ((var (car def)) (value (cadr def)) (doc (caddr def))) (if (eq (car value) 'lambda) `(defmacro ,var ,(cadr value) ,@(and doc (list doc)) ,@(let ((body (cddr value))) (if (and (eq (car body) 'progn) (null (cdr body))) (cdar body) body))) ;; can only expand to defmacro forms (for the compiler's sake) (error "Macros must be constant lambdas: %s" (car def)))))) ;;;###autoload (defmacro with-internal-definitions (#!rest body) (define-scan-internals body)) librep-0.90.2/lisp/rep/lang/debugger.jl0000644000175200017520000001572411245011153016660 0ustar chrischris#| debug.jl -- Lisp debugger (well, single-stepper anyway) $Id$ Copyright (C) 1993, 1994, 2000 John Harper This file is part of Librep. Librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# ;; XXX extend this to support the structure inspection meta-commands ;; of the top-level repl (define-structure rep.lang.debugger () (open rep rep.system rep.structures rep.regexp rep.io.files rep.io.readline) (define emit-emacs-tokens (get-command-line-option "--emacs-debug")) ;;; the form stopped on (define obj (make-fluid)) (define depth (make-fluid)) (define frame-id (make-fluid)) (define bottom-frame-id (make-fluid)) (define last-printed-frame) (define last (make-fluid)) ;;; stack frame accessors (define (stack-frame-function x) (nth 0 x)) (define (stack-frame-args x) (nth 1 x)) (define (stack-frame-current-form x) (nth 2 x)) (define (stack-frame-environment x) (nth 3 x)) (define (stack-frame-structure x) (nth 4 x)) ;;; the debugger repl (defun debug-rep () (let ((print-escape t)) (when (fluid obj) (print-form) (print-emacs-form (fluid obj))) (while t (let ((input (readline (format nil "rep-db> "))) next-last) (cond ((string-match "^\\s*n" input) (fluid-set last do-next) (do-next)) ((string-match "^\\s*s" input) (fluid-set last do-step) (do-step)) ((string-match "^\\s*c" input) (fluid-set last do-continue) (do-continue)) ((string-match "^\\s*r\\w*\\s+" input) (do-set-result (eval (read-from-string (substring input (match-end)))))) ((string-match "^\\s*u" input) (setq next-last do-up) (do-up)) ((string-match "^\\s*d" input) (setq next-last do-down) (do-down)) ((string-match "^\\s*p\\w*\\s+" input) (condition-case data (format standard-error "%S\n" (eval-in-frame (read-from-string (substring input (match-end))))) (error (default-error-handler (car data) (cdr data))))) ((string-match "^\\s*b" input) (print-backtrace)) ((string-match "^\\s*f" input) (setq last-printed-frame t) (print-frame (fluid frame-id)) (if (fluid obj) (progn (print-form) (print-emacs-form (fluid obj))) (print-emacs-frame (fluid frame-id)))) ((string-match "^\\s*l" input) (print-locals)) ((string-match "^\\s*$" input) (if (fluid last) (progn ((fluid last)) (setq next-last (fluid last))) (write standard-error "Nothing to repeat\n"))) (t (write standard-error "\ commands: `n[ext]', `s[tep]', `c[ontinue]', `r[eturn] FORM', `p[rint] FORM', `b[acktrace]', `f[orm], `l[ocals]''\n"))) (fluid-set last next-last))))) ;;; local functions (defun print-frame (id) (let ((frame (stack-frame-ref id))) (if (null frame) (format standard-error "#%-3d #undefined\n" id) (unless (equal frame last-printed-frame) (let ((fun (stack-frame-function frame)) (args (stack-frame-args frame)) (location (lexical-origin (stack-frame-current-form frame)))) (if (null fun) (format standard-error "#%-3d #undefined\n" id) (format standard-error "#%-3d %s %S%s\n" id (or (cond ((closurep fun) (closure-name fun)) ((subrp fun) (subr-name fun)) ((eq (car fun) 'lambda) (list 'lambda (cadr fun) '...))) fun) (if (or (eq fun run-byte-code) (eq args #undefined)) '... args) (if location (format nil " at %s:%d" (file-name-nondirectory (car location)) (cdr location)) "")))))) (setq last-printed-frame frame))) (defun print-backtrace () (do ((i (fluid bottom-frame-id) (1- i))) ((< i 0)) (print-frame i))) (defun print-form () (let* ((form (if (= (fluid frame-id) (fluid bottom-frame-id)) (fluid obj) (stack-frame-current-form (stack-frame-ref (fluid frame-id))))) (location (lexical-origin form))) (if location (format standard-error "%d:\t%S\n" (cdr location) form) (format standard-error "\t%S\n" form)))) (defun print-emacs-form (form) (when emit-emacs-tokens (let ((location (lexical-origin form))) (when location (format standard-error "\032\032%s:%d:\n" (local-file-name (car location)) (cdr location)))))) (defun print-emacs-frame (id) (when emit-emacs-tokens (let* ((frame (stack-frame-ref id)) (location (and frame (lexical-origin (stack-frame-current-form frame))))) (when location (print-emacs-form location))))) (defun print-locals () (let ((frame (stack-frame-ref (fluid frame-id)))) (when frame (mapc (lambda (cell) (format standard-error "%16s %S\n" (symbol-name (cadr cell)) (cddr cell))) (stack-frame-environment frame))))) (defun eval-in-frame (form) (let ((frame (stack-frame-ref (fluid frame-id)))) (when frame (eval form (stack-frame-structure frame) (stack-frame-environment frame))))) (defun entry (debug-obj debug-depth debug-frame-id) (catch 'debug (let-fluids ((obj debug-obj) (depth debug-depth) (frame-id debug-frame-id) (bottom-frame-id debug-frame-id)) (print-frame debug-frame-id) (debug-rep)))) (defun exit (debug-val debug-depth debug-frame-id) (declare (unused debug-frame-id)) (unless (eq debug-val #undefined) (format standard-error "%s-> %S\n" (make-string debug-depth #\-) debug-val))) (defun error-entry (error-list debug-frame-id) (default-error-handler (car error-list) (cdr error-list)) (catch 'debug (let-fluids ((frame-id debug-frame-id) (bottom-frame-id debug-frame-id)) (print-frame debug-frame-id) (print-emacs-frame debug-frame-id) (debug-rep) nil))) (defun do-step () (throw 'debug (cons 1 (fluid obj)))) (defun do-set-result (value) (throw 'debug (cons 4 value))) (defun do-next () (throw 'debug (cons 2 (fluid obj)))) (defun do-continue () (throw 'debug (cons 3 (fluid obj)))) (defun do-up () (when (fluid frame-id) (fluid-set frame-id (max 0 (1- (fluid frame-id)))) (print-frame (fluid frame-id)) (print-emacs-frame (fluid frame-id)))) (defun do-down () (when (fluid frame-id) (fluid-set frame-id (1+ (fluid frame-id))) (print-frame (fluid frame-id)) (print-emacs-frame (fluid frame-id)))) ;;; initialize debug hooks (special variables) (setq debug-entry entry) (setq debug-exit exit) (setq debug-error-entry error-entry)) librep-0.90.2/lisp/rep/lang/compat-doc.jl0000644000175200017520000000332011245011153017107 0ustar chrischris#| compat-doc.jl -- the old documentation interfaces $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.lang.compat-doc (export describe-lambda-list describe-value doc-file-ref doc-file-set documentation document-var add-documentation add-documentation-params) (open rep rep.structures rep.lang.doc) ;; make this appear as the old module 'lisp-doc (define-structure-alias lisp-doc rep.lang.compat-doc) (define (infer-structure sym) (locate-binding sym (list *user-structure*))) (define (documentation symbol #!optional value) (rep.lang.doc#documentation symbol (infer-structure symbol) value)) (define (document-var symbol string) (document-variable symbol (infer-structure symbol) string)) (define (add-documentation symbol string) (rep.lang.doc#add-documentation symbol nil string)) (define (add-documentation-params name param-list) (rep.lang.doc#add-documentation-params name nil param-list))) librep-0.90.2/lisp/rep/lang/backquote.jl0000644000175200017520000001342311245011153017044 0ustar chrischris;;;; backquote.jl --- implement the ` Lisp construct ;;; $Id$ ;;; This file originated in GNU Emacs 19.34; ;;; Changes to it were: ;;; 1. Delete backquote-list* definition and replace all ;;; calls to this function with calls to primitive list* ;;; 3. Replace car-safe with car (car always safe in Jade) ;;; 4. Remove autoload cookies since Jade doesn't allow ;;; autoloaded macros ;;; 5. Remove the use of (` X) for `X, (, X) for ,X and (,@ X) ;;; for ,@X since Jade will parse the normal syntax correctly ;;; Copyright (C) 1990, 1992, 1994 Free Software Foundation, Inc. ;; Author: Rick Sladkey ;; Maintainer: FSF ;; Keywords: extensions, internal ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;;; Code: (declare (unsafe-for-call/cc)) (define-structure rep.lang.backquote (export backquote) (open rep) (defmacro backquote (arg) "Argument STRUCTURE describes a template to build. The whole structure acts as if it were quoted except for certain places where expressions are evaluated and inserted or spliced in. For example: b => (ba bb bc) ; assume b has this value `(a b c) => (a b c) ; backquote acts like quote `(a ,b c) => (a (ba bb bc) c) ; insert the value of b `(a ,@b c) => (a ba bb bc c) ; splice in the value of b Vectors work just like lists. Nested backquotes are permitted." (cdr (backquote-process arg))) ;; backquote-process returns a dotted-pair of a tag (0, 1, or 2) and ;; the backquote-processed structure. 0 => the structure is ;; constant, 1 => to be unquoted, 2 => to be spliced in. ;; The top-level backquote macro just discards the tag. (defun backquote-process (s) (cond ((vectorp s) (let ((n (backquote-process (append s ())))) (if (= (car n) 0) (cons 0 s) (cons 1 (cond ((eq (nth 1 n) 'list) (cons 'vector (nthcdr 2 n))) ((eq (nth 1 n) 'append) (cons 'vconcat (nthcdr 2 n))) (t (list 'apply '(function vector) (cdr n)))))))) ((atom s) (cons 0 (if (not (symbolp s)) s (list 'quote s)))) ((eq (car s) 'backquote-unquote) (cons 1 (nth 1 s))) ((eq (car s) 'backquote-splice) (cons 2 (nth 1 s))) ((eq (car s) 'backquote) (backquote-process (cdr (backquote-process (nth 1 s))))) (t (let ((rest s) item firstlist lst lists expression) ;; Scan this list-level, setting LISTS to a list of forms, ;; each of which produces a list of elements ;; that should go in this level. ;; The order of LISTS is backwards. ;; If there are non-splicing elements (constant or variable) ;; at the beginning, put them in FIRSTLIST, ;; as a list of tagged values (TAG . FORM). ;; If there are any at the end, they go in LIST, likewise. (while (consp rest) ;; Turn . (, foo) into (,@ foo). (if (eq (car rest) 'backquote-unquote) (setq rest (list (list 'backquote-splice (nth 1 rest))))) (setq item (backquote-process (car rest))) (cond ((= (car item) 2) ;; Put the nonspliced items before the first spliced item ;; into FIRSTLIST. (if (null lists) (setq firstlist lst lst nil)) ;; Otherwise, put any preceding nonspliced items into LISTS. (if lst (setq lists (cons (backquote-listify lst '(0 . nil)) lists))) (setq lists (cons (cdr item) lists)) (setq lst nil)) (t (setq lst (cons item lst)))) (setq rest (cdr rest))) ;; Handle nonsplicing final elements, and the tail of the list ;; (which remains in REST). (if (or rest lst) (setq lists (cons (backquote-listify lst (backquote-process rest)) lists))) ;; Turn LISTS into a form that produces the combined list. (setq expression (if (or (cdr lists) (eq (car (car lists)) 'backquote-splice)) (cons 'append (nreverse lists)) (car lists))) ;; Tack on any initial elements. (if firstlist (setq expression (backquote-listify firstlist (cons 1 expression)))) (if (eq (car expression) 'quote) (cons 0 (list 'quote s)) (cons 1 expression)))))) ;; backquote-listify takes (tag . structure) pairs from backquote-process ;; and decides between append, list, list*, and cons depending ;; on which tags are in the list. ;; this is just used to unwrap possibly quoted constants (defun backquote-eval (form) (if (eq (car form) 'quote) (cadr form) form)) (defun backquote-listify (lst old-tail) (let ((heads nil) (tail (cdr old-tail)) (list-tail lst) (item nil)) (if (= (car old-tail) 0) (setq tail (backquote-eval tail) old-tail nil)) (while (consp list-tail) (setq item (car list-tail)) (setq list-tail (cdr list-tail)) (if (or heads old-tail (/= (car item) 0)) (setq heads (cons (cdr item) heads)) (setq tail (cons (backquote-eval (cdr item)) tail)))) (cond (tail (if (null old-tail) (setq tail (list 'quote tail))) (if heads (let ((use-list* (or (cdr heads) (and (consp (car heads)) (eq (car (car heads)) 'backquote-splice))))) (cons (if use-list* 'list* 'cons) (append heads (list tail)))) tail)) (t (cons 'list heads))))) ) ;; backquote.el ends here librep-0.90.2/lisp/rep/io/streams.jl0000644000175200017520000000301411245011153016225 0ustar chrischris#| rep.io.streams bootstrap $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.io.streams)) (open-structures '(rep.lang.symbols rep.data rep.io.files)) ;; Setup format-hooks-alist to a few default'ish things (defvar format-hooks-alist (list (cons #\D file-name-directory) (cons #\F file-name-nondirectory))) (defun prin1-to-string (arg) "Return a string representing ARG." (format nil "%S" arg)) (defun read-from-string (string #!optional start) "Reads an object from STRING, starting at character number START (default is 0)." (read (make-string-input-stream string start))) (defun streamp (arg) "Returns true if ARG is some sort of I/O stream." (or (input-stream-p arg) (output-stream-p arg))) (export-bindings '(prin1-to-string read-from-string streamp)) librep-0.90.2/lisp/rep/io/files.jl0000644000175200017520000000547011245011153015661 0ustar chrischris#| rep.io.files bootstrap $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.io.files)) (open-structures '(rep.lang.symbols rep.data rep.system)) (defun file-name= (name1 name2) "Returns t when NAME1 and NAME2 both name the same file." (string= (canonical-file-name name1) (canonical-file-name name2))) (defun file-newer-than-file-p (file1 file2) "Returns t when FILE1 was modified more recently than FILE2." (time-later-p (file-modtime file1) (file-modtime file2))) (defun load-all (file #!optional callback) "Try to load files called FILE (or FILE.jl, etc) from all directories in the LISP load path (except the current directory)." (let loop ((dirs load-path)) ;; Normally the last entry in load-path is `.' We don't ;; want to use that. But can't just check if each item ;; is the current directory since sometimes rep is run ;; with REPLISPDIR=. (when dirs (when (or (cdr dirs) (not (member (car dirs) '("." "")))) (let ((full-name (expand-file-name file (car dirs)))) (when (or (file-exists-p full-name) (file-exists-p (concat full-name ".jl")) (file-exists-p (concat full-name ".jlc"))) (if callback (callback full-name) (load full-name nil t))))) (loop (cdr dirs))))) (defun call-after-load (library thunk) "Arrange for THUNK to be called immediately after the library of Lisp code LIBRARY has been read by the `load' function. Note that LIBRARY must exactly match the FILE argument to `load'." (let ((tem (assoc library after-load-alist))) (if tem (rplacd tem (cons thunk (cdr tem))) (setq after-load-alist (cons (cons library (list thunk)) after-load-alist))))) (defun eval-after-load (library form) "Arrange for FORM to be evaluated immediately after the library of Lisp code LIBRARY has been read by the `load' function. Note that LIBRARY must exactly match the FILE argument to `load'." (call-after-load library (lambda () (eval form (get-structure *user-structure*))))) (export-bindings '(file-name= file-newer-than-file-p load-all call-after-load eval-after-load)) librep-0.90.2/lisp/rep/io/file-handlers.jl0000644000175200017520000000421111245011153017264 0ustar chrischris#| rep.io.file-handlers bootstrap $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (in-module rep.io.file-handlers)) (open-structures '(rep.lang.symbols rep.io.files rep.module-system rep.data)) ;;; file-handler definition ;; load this from the `rep' structure (defun autoload-file-handler (symbol file) (define-file-handler symbol (make-autoload symbol file))) (defun define-file-handler (name proc) (structure-define (current-structure) name proc)) ;; replicated in files.c (defun file-handler-ref (name) (%structure-ref (current-structure) name)) (export-bindings '(autoload-file-handler define-file-handler file-handler-ref)) ;;; autoloads ;;; ::autoload-start:: (setq file-handler-alist (cons '("^/(([a-zA-Z0-9._-]+)@)?([a-zA-Z0-9._-]+):" . remote-file-handler) file-handler-alist)) (autoload-file-handler 'remote-file-handler "rep/io/file-handlers/remote") (put 'ftp 'remote-backend 'remote-ftp-handler) (autoload-file-handler 'remote-ftp-handler "rep/io/file-handlers/remote/ftp") (put 'rcp 'remote-backend 'remote-rcp-handler) (autoload-file-handler 'remote-rcp-handler "rep/io/file-handlers/remote/rcp") (put 'rep 'remote-backend 'remote-rep-handler) (autoload-file-handler 'remote-rep-handler "rep/io/file-handlers/remote/rep") (setq file-handler-alist (cons '("#tar\\b" . tar-file-handler) file-handler-alist)) (autoload-file-handler 'tar-file-handler "rep/io/file-handlers/tar") ;;; ::autoload-end:: librep-0.90.2/lisp/rep/i18n/xgettext.jl0000644000175200017520000001177511245011153016610 0ustar chrischris#| xgettext.jl -- helper functions for writing xgettext programs $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.i18n.xgettext (export current-file current-module set-included-definers set-helper register scan scan-list scan-file output-c-file output-pot-file) (open rep rep.io.files rep.regexp rep.system) (define current-file (make-fluid)) (define current-module (make-fluid)) (define found-strings (make-fluid)) (define included-definers (make-fluid t)) (define helper (make-fluid)) (define (set-included-definers lst) (fluid-set included-definers lst)) (define (set-helper h) (fluid-set helper h)) (define (register string) (let ((cell (assoc string (fluid found-strings)))) (if cell (unless (member (fluid current-file) (cdr cell)) (rplacd cell (cons (fluid current-file) (cdr cell)))) (fluid-set found-strings (cons (list string (fluid current-file)) (fluid found-strings)))))) (define (includedp name) (or (eq (fluid included-definers) t) (memq name (fluid included-definers)))) (define (scan form) (if (and (consp form) (eq (car form) '_) (stringp (nth 1 form))) (register (nth 1 form)) (when (and (car form) (macrop (car form))) (setq form (macroexpand form))) (when (consp form) (case (car form) ((quote)) ((setq setq-default %define) (do ((tem (cdr form) (cddr tem))) ((null (cdr tem))) (scan (cadr tem)))) ((let let* letrec let-fluids) (setq form (cdr form)) (when (symbolp (car form)) (setq form (cdr form))) (let loop ((vars (car form))) (when vars (scan-list (cdar vars)) (loop (cdr vars)))) (scan-list (cdr form))) ((function) (scan (cdr form))) ((cond) (mapc (lambda (f) (scan-list f)) (cdr form))) ((lambda) (scan-list (cddr form))) ((defun defmacro defsubst defvar defconst) (when (includedp (car form)) (let ((doc (nth 3 form))) (when (stringp doc) (register doc)))) (if (memq (car form) '(defun defmacro defsubst)) (scan-list (nthcdr 3 form)) (scan-list (nthcdr 2 form)))) ((define-structure) (let-fluids ((current-module (nth 1 form))) (scan-list (nthcdr 4 form)))) ((structure) (scan-list (nthcdr 3 form))) (t (if (fluid helper) ((fluid helper) form) (scan-list form))))))) (define (scan-list body) (mapc scan body)) (define (scan-file filename) (let ((file (open-file filename 'read))) (when file (unwind-protect (condition-case nil (let-fluids ((current-file filename)) (while t (let ((form (read file))) (scan form)))) (end-of-stream)) (close-file file))))) (defun output-strings (c-mode) (mapc (lambda (x) (let ((string (car x)) (files (cdr x))) (mapc (lambda (f) (format standard-output "%s %s %s\n" (if c-mode " /*" "#:") f (if c-mode "*/" ""))) files) (let* ((print-escape 'newlines) (out (format nil "%S" string)) (point 0)) (if c-mode (format standard-output " _(%s);\n\n" out) (while (and (< point (length out)) (string-match "\\\\n" out point)) (setq out (concat (substring out 0 (match-start)) "\\n\"\n\"" (substring out (match-end)))) (setq point (+ (match-end) 3))) (format standard-output "msgid %s\nmsgstr \"\"\n\n" out))))) (nreverse (fluid found-strings)))) (define (output-c-file) (write standard-output "\ /* SOME DESCRIPTIVE TITLE */ /* This file is intended to be parsed by xgettext. * It is not intended to be compiled. */ #if 0 void some_function_name() {\n\n") (output-strings t) (write standard-output "\ } #endif\n")) (define (output-pot-file) (format standard-output "\ # SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR Free Software Foundation, Inc. # FIRST AUTHOR , YEAR. # #, fuzzy msgid \"\" msgstr \"\" \"Project-Id-Version: PACKAGE VERSION\\n\" \"POT-Creation-Date: %s\\n\" \"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\\n\" \"Last-Translator: FULL NAME \\n\" \"Language-Team: LANGUAGE \\n\" \"MIME-Version: 1.0\\n\" \"Content-Type: text/plain; charset=CHARSET\\n\" \"Content-Transfer-Encoding: ENCODING\\n\"\n\n" (current-time-string nil "%Y-%m-%d %H:%M%z")) (output-strings nil))) librep-0.90.2/lisp/rep/data/trie.jl0000644000175200017520000000615211245011153016022 0ustar chrischris#| trie.jl -- data structure for encoding character lists as a tree $Id$ Copyright (C) 2002 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.data.trie (export make-trie trie-insert-string! trie-string-ref trie-contains-string? trie-foreach make-trie-from-file) (open rep rep.io.files rep.regexp) ;; tree nodes ;; each node is a list (node (CHAR . VALUE) ...) VALUE is typically ;; another tree (define (make-node) (list 'node)) (define (node-ref node key) (cdr (assq key (cdr node)))) (define (node-set! node key v) (let ((cell (assq key (cdr node)))) (if cell (rplacd cell v) (rplacd node (cons (cons key v) (cdr node)))))) ;; trees of tokens (define make-trie make-node) ;; returns the sub-tree of the last key, or false (define (trie-ref tree keys) (if (null keys) tree (let ((sub-tree (node-ref tree (car keys)))) (and sub-tree (trie-ref sub-tree (cdr keys)))))) (define (trie-insert-1! tree key) (let ((sub (node-ref tree key))) (if (not sub) (let ((new (make-node))) (node-set! tree key new) new) sub))) ;; returns the sub-tree of the last inserted token (define (trie-insert! tree keys) (if (not keys) tree (trie-insert! (trie-insert-1! tree (car keys)) (cdr keys)))) ;; string handling (defconst word-terminator eow) (define (trie-insert-string! tree string) (trie-insert-1! (trie-insert! tree (vector->list string)) word-terminator)) (define (trie-string-ref tree string) (trie-ref tree (vector->list string))) (define (trie-contains-string? tree string) (let ((end (trie-string-ref tree string))) (and (node-ref end word-terminator) t))) (define (trie-foreach tree callback) (define (iter tree tokens) (mapc (lambda (x) (if (eq (car x) word-terminator) (callback (apply concat (reverse tokens))) (iter (cdr x) (cons (car x) tokens)))) (cdr tree))) (iter tree '())) (define (make-trie-from-file filename #!key callback) (let ((file (open-file filename 'read)) (tree (make-trie))) (unwind-protect (let loop () (let ((string (read-line file))) (when string (when (string-match "\\s+$" string) (setq string (substring string 0 (match-start)))) (when callback (setq string (callback string))) (when string (trie-insert-string! tree string)) (loop)))) (close-file file)) tree))) librep-0.90.2/lisp/rep/data/symbol-table.jl0000644000175200017520000000352211245011153017447 0ustar chrischris#| symbol-table.jl -- use modules to provide efficient symbol tables $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# ;; Commentary: ;; Structures provide the most efficient means of maintaining mappings ;; from symbols to values (tables using eq hashing would be comparable, ;; but less efficient since they're more general). ;; However, I don't want to expose the first-class structure interface ;; to general code, hence these wrappers for making anonymous ;; structures (define-structure rep.data.symbol-table (export make-symbol-table symbol-table-ref symbol-table-set symbol-table-boundp symbol-table-walk) (open rep rep.structures) (define-structure-alias symbol-table rep.data.symbol-table) (define (make-symbol-table) (make-structure)) (define (symbol-table-ref table var) (and (structure-bound-p table var) (%structure-ref table var))) (define (symbol-table-set table var value) (structure-define table var value)) (define (symbol-table-boundp table var) (structure-bound-p table var)) (define (symbol-table-walk fun table) (structure-walk fun table))) librep-0.90.2/lisp/rep/data/string-util.jl0000644000175200017520000000620111245011153017333 0ustar chrischris;; string-util.jl -- some more string functions ;; $Id$ ;; Copyright (C) 2000 John Harper ;; This file is part of librep. ;; librep is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; librep is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with librep; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (declare (in-module rep.data)) (open-structures '(rep.lang.math)) ;;;###autoload (defun string-upper-case-p (x) "Return t if string X is upper case (contains no lower case characters and at least one upper-case character)." (let iter ((point 0) (seen-upper nil)) (if (>= point (length x)) seen-upper (let ((char (aref x point))) (if (lower-case-p char) nil (iter (1+ point) (or seen-upper (upper-case-p char)))))))) ;;;###autoload (defun string-lower-case-p (x) "Return t if string X is lower case (contains no upper case characters and at least one lower-case character)." (let iter ((point 0) (seen-lower nil)) (if (>= point (length x)) seen-lower (let ((char (aref x point))) (if (upper-case-p char) nil (iter (1+ point) (or seen-lower (lower-case-p char)))))))) ;;;###autoload (defun string-capitalized-p (x) "Returns t if string X is capitalized (first character is upper case)." (and (> (length x) 0) (upper-case-p (aref x 0)))) ;;;###autoload (defun string-upcase (x) "Return a new string, an upper case copy of string X." (translate-string (copy-sequence x) upcase-table)) ;;;###autoload (defun string-downcase (x) "Return a new string, a lower case copy of string X." (translate-string (copy-sequence x) downcase-table)) ;;;###autoload (defun capitalize-string (x) "Return a new string, a copy of X with its first character in upper case." (if (zerop (length x)) x (let ((new (copy-sequence x))) (aset new 0 (char-upcase (aref new 0))) new))) ;;;###autoload (defun mapconcat (fun sequence separator) "Call FUN for each member of SEQUENCE, concatenating the results. Between each pair of results, insert SEPARATOR. Return the resulting string." (cond ((null sequence) "") ((consp sequence) ;; avoid O(n) operations on lists (let loop ((rest (cdr sequence)) (frags (list (fun (car sequence))))) (if (null rest) (apply concat (nreverse frags)) (loop (cdr rest) (cons (fun (car rest)) (cons separator frags)))))) (t ;; use general sequence operations (let ((len (length sequence))) (if (= len 0) "" (let loop ((i 1) (frags (list (fun (elt sequence 0))))) (if (= i len) (apply concat (nreverse frags)) (loop (1+ i) (cons (fun (elt sequence i)) (cons separator frags)))))))))) librep-0.90.2/lisp/rep/data/sort.jl0000644000175200017520000000446511245011153016053 0ustar chrischris;;;; sort.jl -- Sorting functions ;;; Copyright (C) 1998 John Harper ;;; $Id$ ;;; This file is part of Jade. ;;; Jade is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2, or (at your option) ;;; any later version. ;;; Jade is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; You should have received a copy of the GNU General Public License ;;; along with Jade; see the file COPYING. If not, write to ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (declare (in-module rep.data) (unsafe-for-call/cc)) (open-structures '(rep.lang.math)) ;;;###autoload (defun sort (lst #!optional pred) "Sort LST destructively, but stably, returning the sorted list. If PRED is defined it is used to compare two objects, it should return t when the first is `less' than the second. By default the standard less-than function (`<') is used. The fact that the sort is stable means that sort keys which are equal will preserve their original position in relation to each other." (let ((len (length lst))) (if (< len 2) lst ;; default to sorting smaller to greater (unless pred (setq pred <)) (let ((mid (nthcdr (1- (quotient len 2)) lst))) (setq mid (prog1 (cdr mid) (rplacd mid nil))) ;; Now we have two separate lists, LST and MID; sort them.. (setq lst (sort lst pred) mid (sort mid pred)) ;; ..then merge them back together (let ((out-head nil) ;Start of the list being built (out nil) ;Cell whose cdr is next link tem) ;; While both lists have elements compare them (while (and lst mid) (setq tem (if (funcall pred (car mid) (car lst)) (prog1 mid (setq mid (cdr mid))) (prog1 lst (setq lst (cdr lst))))) (if out (progn (rplacd out tem) (setq out tem)) (setq out-head tem out tem))) ;; If either has elements left just append them (when (or lst mid) (if out (rplacd out (or lst mid)) (setq out-head (or lst mid)))) out-head))))) librep-0.90.2/lisp/rep/data/ring.jl0000644000175200017520000000776611245011153016032 0ustar chrischris#| ring.jl -- ring buffer support $Id$ Copyright (C) 1993, 1994, 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.data.ring (export ring-capacity ring-size make-ring ring-append ring-ref ring-replace ring->list add-to-ring get-from-ring set-ring-head) (open rep rep.data.datums) (define-structure-alias ring rep.data.ring) ;; default size of a ring buffer (defconst default-size 16) ;; key for datum access (define key (cons)) (define-datum-printer key (lambda (d s) (declare (unused d)) (write s "#"))) ;; A ring buffer of size N is defined by a vector with N+2 slots; the ;; first slot is used to store the size of the buffer, the second stores ;; the position of the next slot to be filled. (define (ring-capacity ring) "Returns the number of slots in the ring buffer RING." (- (length (datum-ref ring key)) 2)) (define (ring-size ring) "Returns the number of filled slots in the ring buffer RING." (aref (datum-ref ring key) 0)) (define (set-size ring size) (aset (datum-ref ring key) 0 size)) (define (get-pos ring) (aref (datum-ref ring key) 1)) (define (set-pos ring pos) (aset (datum-ref ring key) 1 pos)) (define (get-item ring pos) (aref (datum-ref ring key) (+ pos 2))) (define (set-item ring pos val) (aset (datum-ref ring key) (+ pos 2) val)) ;;; higher level public api (define (make-ring #!optional size) "Create a ring buffer that can contain SIZE values. If SIZE is not specified the default capacity `ring-default-size' is used." (unless size (setq size default-size)) (let ((ring (make-datum (make-vector (+ size 2)) key))) (set-size ring 0) (set-pos ring 0) ring)) (define (ring-append ring object) "Append OBJECT to the ring buffer RING. This may overwrite a previously added object." (set-item ring (get-pos ring) object) (let ((new-pos (mod (1+ (get-pos ring)) (ring-capacity ring)))) (unless (= (ring-size ring) (ring-capacity ring)) (set-size ring (1+ (ring-size ring)))) (set-pos ring new-pos))) (define (ring-ref ring #!optional depth) "Read an object from the ring buffer RING. If DEPTH is true it defines the object to access, the most recently added item is at depth zero, the next at depth one, and so on. If there is no item at DEPTH nil is returned." (unless depth (setq depth 0)) (if (>= depth (ring-capacity ring)) nil (get-item ring (mod (- (get-pos ring) (1+ depth)) (ring-capacity ring))))) (define (ring-replace ring object) "Replaces the most recently added object in ring buffer RING with OBJECT. If RING contains no items, add OBJECT as the first." (if (zerop (ring-size ring)) (add-to-ring ring object) (set-item ring (mod (1- (get-pos ring)) (ring-capacity ring)) object))) (define (ring->list ring) "Return the elements in ring buffer RING as a list, newest to oldest." (let ((size (ring-size ring)) (contents '())) (do ((i 0 (1+ i))) ((= i size) (nreverse contents)) (setq contents (cons (ring-ref ring i) contents))))) ;;; compatibility api (define (get-from-ring ring #!optional depth) (ring-ref ring (if depth (1- depth) 0))) (define add-to-ring ring-append) (define set-ring-head ring-replace)) librep-0.90.2/lisp/rep/data/records.jl0000644000175200017520000001232711245011153016521 0ustar chrischris#| records.jl -- record types $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# ;; Commentary: ;; This was inspired by the Scheme48 record interface (surprise, ;; surprise!). You do something like: ;; (define-record-type :pare ;; (kons x y) ; constructor ;; pare? ; predicate ;; (x kar set-kar!) ; fields w/ optional accessors ;; (y kdr)) ;and modifiers ;; the variable `:pare' is bound to the record type. This can be used ;; to redefine the printed representation of the record type (e.g. by ;; default `#<:pare>') using define-record-discloser: ;; (define-record-discloser :pare ;; (lambda (x) `(pare ,(kar x) ,(kdr x)))) ;; General syntax of define-record-type is: ;; (define-record-type ;; ( *) ;; [] ;; ( [ []])*) ;; * is a standard lambda list, the parameters should ;; match the 's to be initialized (define-structure rep.data.records (export make-record-type make-record-datum record-constructor record-accessor record-modifier record-predicate record-printer define-record-type define-record-discloser) (open rep rep.data.datums) (define-structure-alias records rep.data.records) ;;; record type structures (define (make-record-type name fields) (let ((rt (vector name fields nil))) (define-datum-printer rt (record-printer rt)) rt)) (define (record-type-name rt) (aref rt 0)) (define (record-type-fields rt) (aref rt 1)) (define (record-type-discloser rt) (aref rt 2)) (define (define-record-discloser rt x) (aset rt 2 x)) ;;; record mechanics (define (make-record rt) (make-datum (make-vector (length (record-type-fields rt))) rt)) (define make-record-datum make-datum) (define (field-index rt field) (do ((i 0 (1+ i)) (fields (record-type-fields rt) (cdr fields))) ((eq (car fields) field) i) (and (null fields) (error "No such field: %s, %s" (record-type-name rt) field)))) (define (field-ref rt record index) (aref (datum-ref record rt) index)) (define (field-set rt record index value) (aset (datum-ref record rt) index value)) ;;; interface implementations (define (record-constructor rt fields) (let ((indices (mapcar (lambda (field) (field-index rt field)) fields))) (lambda args (let ((record (make-record rt))) (let loop ((rest args) (ids indices)) (if (and rest ids) (progn (field-set rt record (car ids) (car rest)) (loop (cdr rest) (cdr ids))) record)))))) (define (make-record-constructor rt args field-names) (define (has-field-p field) (let loop ((rest args)) (cond ((null rest) nil) ((eq (or (caar rest) (car rest) rest) field) t) (t (loop (cdr rest)))))) (let loop ((rest field-names) (out '())) (if (null rest) `(lambda ,args (make-record-datum (vector ,@(nreverse out)) ,rt)) (loop (cdr rest) (cons (and (has-field-p (car rest)) (car rest)) out))))) (define (record-accessor rt field) (let ((index (field-index rt field))) (lambda (record) (field-ref rt record index)))) (define (record-modifier rt field) (let ((index (field-index rt field))) (lambda (record value) (field-set rt record index value)))) (define (record-predicate rt) (lambda (arg) (has-type-p arg rt))) (define (record-printer rt) (lambda (record stream) (if (record-type-discloser rt) (let ((out ((record-type-discloser rt) record))) (if (stringp out) (write stream out) (prin1 out stream))) (format stream "#<%s>" (record-type-name rt))))) ;;; syntax (defmacro define-record-type (rt constructor . fields) (let (names predicate-defs accessor-defs modifier-defs) (when (and fields (symbolp (car fields))) (setq predicate-defs `((define ,(car fields) (record-predicate ,rt)))) (setq fields (cdr fields))) (setq names (mapcar car fields)) (mapc (lambda (field) (when (cadr field) (setq accessor-defs (cons `(define ,(cadr field) (record-accessor ,rt ',(car field))) accessor-defs))) (when (caddr field) (setq modifier-defs (cons `(define ,(caddr field) (record-modifier ,rt ',(car field))) modifier-defs)))) fields) `(progn (define ,rt (make-record-type ',rt ',names)) (define ,(car constructor) ,(make-record-constructor rt (cdr constructor) names)) ,@predicate-defs ,@accessor-defs ,@modifier-defs)))) librep-0.90.2/lisp/rep/data/queues.jl0000644000175200017520000000703311245011153016365 0ustar chrischris#| queues.jl -- fifo queues $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.data.queues (export make-queue enqueue dequeue queue-empty-p queuep queue->list queue-length delete-from-queue) (open rep rep.data.datums rep.test.framework) (define-structure-alias queues rep.data.queues) (define type-id (cons)) (define-datum-printer type-id (lambda (q stream) (declare (unused q)) (write stream "#"))) ;; Each queue is (TAIL . HEAD). HEAD is the list of items, TAIL ;; points to the last cell in HEAD, or the empty list. (define (make-queue) (make-datum (cons) type-id)) (define (enqueue q x) (let ((cell (datum-ref q type-id)) (new (list x))) (if (null (cdr cell)) ;; empty queue (progn (rplacd cell new) (rplaca cell new)) ;; tail pointer is set (rplacd (car cell) new) (rplaca cell new)))) (define (dequeue q) (let ((cell (datum-ref q type-id))) (if (null (cdr cell)) (error "Can't dequeue from empty queue") (prog1 (car (cdr cell)) (if (not (eq (car cell) (cdr cell))) ;; at least one element left (rplacd cell (cdr (cdr cell))) ;; queue needs to be empty now (rplacd cell '()) (rplaca cell '())))))) (define (queue-empty-p q) (null (cdr (datum-ref q type-id)))) (define (queuep q) (has-type-p q type-id)) (define (queue->list q) (cdr (datum-ref q type-id))) (define (queue-length q) (length (queue->list q))) (define (delete-from-queue q x) (let ((cell (datum-ref q type-id))) (let loop ((ptr cell)) (if (null (cdr ptr)) ;; avoid pointing tail to itself.. (if (null (cdr cell)) (rplaca cell '()) (rplaca cell ptr)) (if (eq (cadr ptr) x) (progn (rplacd ptr (cddr ptr)) (loop ptr)) (loop (cdr ptr))))))) ;;; tests ;;###autoload (define-self-test 'rep.data.queues (lambda () (let ((queue (make-queue))) (test (queuep queue)) (test (queue-empty-p queue)) (test (null (queue->list queue))) (test (= (queue-length queue) 0)) (enqueue queue 1) (test (not (queue-empty-p queue))) (test (equal (queue->list queue) '(1))) (test (= (queue-length queue) 1)) (enqueue queue 2) (test (equal (queue->list queue) '(1 2))) (test (= (queue-length queue) 2)) (test (= (dequeue queue) 1)) (test (equal (queue->list queue) '(2))) (test (= (queue-length queue) 1)) (enqueue queue 3) (enqueue queue 4) (enqueue queue 5) (test (equal (queue->list queue) '(2 3 4 5))) (delete-from-queue queue 2) (test (equal (queue->list queue) '(3 4 5))) (delete-from-queue queue 4) (test (equal (queue->list queue) '(3 5))) (delete-from-queue queue 5) (test (equal (queue->list queue) '(3))) (delete-from-queue queue 3) (test (= (queue-length queue) 0)) (test (queue-empty-p queue)))))) librep-0.90.2/lisp/rep/data/objects.jl0000644000175200017520000000652111245011153016510 0ustar chrischris#| objects.jl -- very basic OO system $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.data.objects (export object object-lambda objectp) (open rep) ;; Commentary: ;; This module provides an extremely simple message-passing object ;; implementation, with support for single inheritance. The `object' ;; form expands to a lambda expression, hence it captures local ;; bindings for the method implementations. ;; Syntax is: ;; (object BASE-OBJECT METHOD...) ;; each METHOD is either ((METHOD-NAME . PARAM-LIST) BODY...), or ;; (METHOD-NAME FUNCTION). ;; PARAM-LIST currently isn't the full lambda spec, just a list of ;; symbols. The list can be dotted to a symbol to make a #!rest ;; parameter. All parameters are optional (i.e. default to nil) ;; Any unknown methods are passed off to BASE-OBJECT, or if that is ;; nil, an `unknown-method' error is signalled. ;; Each object has the variable `self' bound to the closure ;; representing itself. (In superclasses, `self' points to the ;; subclass originally called into) ;; Example: ;; (define obj (object nil ;; ((foo a b) (+ a b)) ;; (bar -))) ;; (obj 'foo 2 1) => 3 ;; (obj 'bar 2 1) => 1 ;; (obj 'baz 2 1) error--> unknown method: baz (define (make-let-bindings spec args-var) (let loop ((rest spec) (i 0) (out '())) (cond ((null rest) (nreverse out)) ((atom rest) (loop '() (1+ i) (cons `(,rest (nthcdr ,i ,args-var)) out))) ((memq (car rest) '(#!optional #!rest #!key &optional &rest)) (error "Lambda-list keywords aren't implemented for objects: %s" spec)) (t (loop (cdr rest) (1+ i) (cons `(,(car rest) (nth ,i ,args-var)) out)))))) (defmacro object-lambda (params . body) (let ((self (gensym))) `(letrec ((,self (lambda (,(car params) #!key (self ,self) ,@(cdr params)) ,@body))) ,self))) (defmacro object (base-object . methods) (let ((op (gensym)) (args (gensym)) (base (gensym))) `(let ((,base ,base-object)) (object-lambda (,op . ,args) (case ,op ,@(mapcar (lambda (method) (cond ((consp (car method)) ;; ((METHOD-NAME . PARAM-LIST) BODY...) `((,(caar method)) (let ,(make-let-bindings (cdar method) args) ,@(cdr method)))) ((symbolp (car method)) ;; (METHOD-NAME FUNCTION) `((,(car method)) (apply ,(cadr method) ,args))))) methods) (t (if ,base (apply ,base ,op #:self self ,args) (signal 'unknown-method (list ,op))))))))) (define objectp closurep) (put 'unknown-method 'error-message "Unknown method call")) librep-0.90.2/lisp/rep/vm/compiler/utils.jl0000644000175200017520000003060111245011153017536 0ustar chrischris#| utils.jl -- $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.vm.compiler.utils (export current-stack max-stack current-b-stack max-b-stack const-env inline-env defuns defvars defines output-stream silence-compiler compiler-error compiler-warning compiler-deprecated remember-function forget-function remember-variable remember-lexical-variable test-variable-ref test-variable-bind test-function-call increment-stack decrement-stack increment-b-stack decrement-b-stack get-lambda-vars compiler-constant-p compiler-constant-value constant-function-p constant-function-value note-declaration) (open rep rep.io.files rep.vm.compiler.modules rep.vm.compiler.bindings rep.vm.compiler.basic rep.vm.bytecodes) (define current-stack (make-fluid 0)) ;current stack requirement (define max-stack (make-fluid 0)) ;highest possible stack (define current-b-stack (make-fluid 0)) ;current binding stack req. (define max-b-stack (make-fluid 0)) ;highest possible binding stack (define const-env (make-fluid '())) ;alist of (NAME . CONST-DEF) (define inline-env (make-fluid '())) ;alist of (NAME . FUN-VALUE) (define defuns (make-fluid '())) ;alist of (NAME REQ OPT RESTP) ; for all functions/macros in the file (define defvars (make-fluid '())) ;all vars declared at top-level (define defines (make-fluid '())) ;all lex. vars. at top-level (defvar output-stream (make-fluid)) ;stream for compiler output ;; also: shadowing (defvar *compiler-warnings* '(unused bindings parameters misc deprecated)) (define silence-compiler (make-fluid nil)) ;;; Message output (define last-current-file t) (define last-current-fun t) (define (ensure-output-stream) (when (null (fluid output-stream)) (if (or batch-mode (not (featurep 'jade))) (fluid-set output-stream (stdout-file)) (declare (bound open-buffer)) (fluid-set output-stream (open-buffer "*compilation-output*")))) (when (and (featurep 'jade) (progn (declare (bound bufferp goto-buffer goto end-of-buffer current-buffer)) (and (bufferp (fluid output-stream)) (not (eq (current-buffer) (fluid output-stream)))))) (goto-buffer (fluid output-stream)) (goto (end-of-buffer)))) (define (abbreviate-file file) (let ((c-dd (file-name-as-directory (canonical-file-name default-directory))) (c-file (canonical-file-name file))) (if (string-head-eq c-file c-dd) (substring c-file (length c-dd)) file))) (define (file-prefix #!optional form) (unless form (setq form (fluid current-form))) (let ((origin (and form (lexical-origin form)))) (cond (origin (format nil "%s:%d: " (abbreviate-file (car origin)) (cdr origin))) ((fluid current-file) (format nil "%s: " (abbreviate-file (fluid current-file)))) (t "")))) (defun compiler-message (fmt #!key form #!rest args) (unless (fluid silence-compiler) (ensure-output-stream) (unless (and (eq last-current-fun (fluid current-fun)) (eq last-current-file (fluid current-file))) (if (fluid current-fun) (format (fluid output-stream) "%sIn function `%s':\n" (file-prefix form) (fluid current-fun)) (format (fluid output-stream) "%sAt top-level:\n" (file-prefix form)))) (apply format (fluid output-stream) (concat "%s" fmt #\newline) (file-prefix form) args) (setq last-current-fun (fluid current-fun)) (setq last-current-file (fluid current-file)))) (put 'compile-error 'error-message "Compilation mishap") (defun compiler-error (fmt #!key form #!rest data) (apply compiler-message fmt #:form form data) (signal 'compile-error (list (apply format nil fmt data)))) (defun compiler-warning (type fmt #!key form #!rest args) (when (memq type *compiler-warnings*) (apply compiler-message (concat "warning: " fmt) #:form form args))) (define deprecated-seen '()) (defun compiler-deprecated (id fmt #!rest args) (unless (memq id deprecated-seen) (apply compiler-warning 'deprecated (concat "deprecated - " fmt) args) (setq deprecated-seen (cons id deprecated-seen)))) ;;; Code to handle warning tests ;; Note that there's a function or macro NAME with lambda-list ARGS ;; in the current file (defun remember-function (name args #!optional body) (when body (let ((cell (assq name (fluid inline-env)))) ;; a function previously declared inline (when (and cell (not (cdr cell))) (rplacd cell (list* 'lambda args body))))) (if (assq name (fluid defuns)) (compiler-warning 'misc "function or macro `%s' defined more than once" name) (let ((count (vector 0 nil nil)) ;required, optional, rest (keys '()) (state 0)) ;; Scan the lambda-list for the number of required and optional ;; arguments, and whether there's a #!rest clause (while args (if (symbolp args) ;; (foo . bar) (aset count 2 t) (if (memq (car args) '(&optional &rest #!optional #!key #!rest)) (case (car args) ((&optional #!optional) (setq state 1) (aset count 1 0)) ((#!key) (setq state 'key)) ((&rest #!rest) (setq args nil) (aset count 2 t))) (if (numberp state) (aset count state (1+ (aref count state))) (setq keys (cons (or (caar args) (car args)) keys))))) (setq args (cdr args))) (fluid-set defuns (cons (list name (aref count 0) (aref count 1) (aref count 2) keys) (fluid defuns)))))) (defun forget-function (name) (let ((cell (assq name (fluid defuns)))) (fluid-set defuns (delq cell (fluid defuns))))) ;; Similar for variables (defun remember-variable (name) (cond ((memq name (fluid defines)) (compiler-error "variable `%s' was previously declared lexically" name)) ; ((memq name (fluid defvars)) (compiler-warning 'misc "variable `%s' defined more than once" name)) (t (fluid-set defvars (cons name (fluid defvars)))))) (defun remember-lexical-variable (name) (cond ((memq name (fluid defvars)) (compiler-error "variable `%s' was previously declared special" name)) ((memq name (fluid defines)) (compiler-warning 'misc "lexical variable `%s' defined more than once" name)) (t (fluid-set defines (cons name (fluid defines)))))) ;; Test that a reference to variable NAME appears valid (defun test-variable-ref (name) (when (and (symbolp name) (not (keywordp name)) (null (memq name (fluid defvars))) (null (memq name (fluid defines))) (not (has-local-binding-p name)) (null (assq name (fluid defuns))) (not (compiler-boundp name))) (compiler-warning 'bindings "referencing undeclared free variable `%s'" name))) ;; Test that binding to variable NAME appears valid (defun test-variable-bind (name) (cond ((assq name (fluid defuns)) (compiler-warning 'shadowing "binding to `%s' shadows function" name)) ((has-local-binding-p name) (compiler-warning 'shadowing "binding to `%s' shadows earlier binding" name)) ((and (compiler-boundp name) (functionp (compiler-symbol-value name))) (compiler-warning 'shadowing "binding to `%s' shadows pre-defined value" name)))) ;; Test a call to NAME with NARGS arguments ;; XXX functions in comp-fun-bindings aren't type-checked ;; XXX this doesn't handle #!key params (defun test-function-call (name nargs) (when (symbolp name) (catch 'return (let ((decl (assq name (fluid defuns)))) (when (and (null decl) (or (assq name (fluid inline-env)) (compiler-boundp name))) (setq decl (or (cdr (assq name (fluid inline-env))) (compiler-symbol-value name))) (when (or (subrp decl) (and (closurep decl) (eq (car (closure-function decl)) 'autoload))) (throw 'return)) (when (eq (car decl) 'macro) (setq decl (cdr decl))) (when (closurep decl) (setq decl (closure-function decl))) (unless (bytecodep decl) (remember-function name (nth 1 decl))) (setq decl (assq name (fluid defuns)))) (if (null decl) (unless (or (has-local-binding-p name) (memq name (fluid defvars)) (memq name (fluid defines)) (locate-variable name)) (compiler-warning 'misc "calling undeclared function `%s'" name)) (let ((required (nth 1 decl)) (optional (nth 2 decl)) (rest (nth 3 decl)) (keys (nth 4 decl))) (if (< nargs required) (compiler-warning 'parameters "%d %s required by `%s'; %d supplied" required (if (= required 1) "argument" "arguments") name nargs) (when (and (null rest) (null keys) (> nargs (+ required (or optional 0)))) (compiler-warning 'parameters "too many arguments to `%s' (%d given, %d used)" name nargs (+ required (or optional 0))))))))))) ;;; stack handling ;; Increment the current stack size, setting the maximum stack size if ;; necessary (defmacro increment-stack (#!optional n) (list 'when (list '> (list 'fluid-set 'current-stack (if n (list '+ '(fluid current-stack) n) (list '1+ '(fluid current-stack)))) '(fluid max-stack)) '(fluid-set max-stack (fluid current-stack)))) ;; Decrement the current stack usage (defmacro decrement-stack (#!optional n) (list 'fluid-set 'current-stack (if n (list '- '(fluid current-stack) n) (list '1- '(fluid current-stack))))) (defun increment-b-stack () (fluid-set current-b-stack (1+ (fluid current-b-stack))) (when (> (fluid current-b-stack) (fluid max-b-stack)) (fluid-set max-b-stack (fluid current-b-stack)))) (defun decrement-b-stack () (fluid-set current-b-stack (1- (fluid current-b-stack)))) ;; Remove all keywords from a lambda list ARGS, returning the list of ;; variables that would be bound (in the order they would be bound) (defun get-lambda-vars (args) (let (vars) (while args (if (symbolp args) (setq vars (cons args vars)) (unless (memq (car args) '(#!optional #!key #!rest &optional &rest)) (setq vars (cons (or (caar args) (car args)) vars)))) (setq args (cdr args))) (nreverse vars))) ;;; constant forms ;; Return t if FORM is a constant (defun compiler-constant-p (form) (cond ((consp form) ;; XXX this is wrong, but easy..! (eq (car form) 'quote)) ((symbolp form) (or (keywordp form) (assq form (fluid const-env)) (compiler-binding-immutable-p form))) ;; Assume self-evaluating (t t))) ;; If FORM is a constant, return its value (defun compiler-constant-value (form) (cond ((consp form) ;; only quote (nth 1 form)) ((symbolp form) (cond ((keywordp form) form) ((compiler-binding-immutable-p form) (compiler-symbol-value form)) (t (cdr (assq form (fluid const-env)))))) (t form))) (defun constant-function-p (form) (setq form (compiler-macroexpand form)) (and (memq (car form) '(lambda function)) ;; XXX this is broken (compiler-binding-from-rep-p (car form)))) (defun constant-function-value (form) (setq form (compiler-macroexpand form)) (cond ((eq (car form) 'lambda) form) ((eq (car form) 'function) (nth 1 form)))) ;;; declarations (defun note-declaration (form) (mapc (lambda (clause) (let ((handler (get (or (car clause) clause) 'compiler-decl-fun))) (if handler (handler clause) (compiler-warning 'misc "unknown declaration: `%s'" clause)))) form)) (defun declare-inline (form) (mapc (lambda (name) (when (symbolp name) (unless (assq name (fluid inline-env)) (fluid-set inline-env (cons (cons name nil) (fluid inline-env)))))) (cdr form))) (put 'inline 'compiler-decl-fun declare-inline) ) librep-0.90.2/lisp/rep/vm/compiler/src.jl0000644000175200017520000000632511245011153017173 0ustar chrischris#| src.jl -- source code program transforms $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.vm.compiler.src (export coalesce-constants mash-constants source-code-transform) (open rep rep.vm.compiler.utils rep.vm.compiler.modules rep.vm.compiler.lap rep.vm.compiler.bindings rep.vm.bytecodes) ;;; Constant folding (defun foldablep (name) (unless (has-local-binding-p name) (let ((fun (get-procedure-handler name 'compiler-foldablep))) (and fun (fun name))))) (defun quote-constant (value) (if (or (symbolp value) (consp value)) (list 'quote value) value)) ;; This assumes that FORM is a list, and its car is one of the functions ;; in the comp-constant-functions list (defun fold-constants (form) (catch 'exit (let ((args (mapcar (lambda (arg) (when (consp arg) (setq arg (compiler-macroexpand arg))) (when (and (consp arg) (foldablep (car arg))) (setq arg (fold-constants arg))) (if (compiler-constant-p arg) (compiler-constant-value arg) ;; Not a constant, abort, abort (throw 'exit form))) (cdr form)))) ;; Now we have ARGS, the constant [folded] arguments from FORM (quote-constant (apply (compiler-symbol-value (car form)) args))))) (defun coalesce-constants (folder forms) (when forms (let loop ((result '()) (first (car forms)) (rest (cdr forms))) (cond ((null rest) (nreverse (cons first result))) ((and (compiler-constant-p first) rest (compiler-constant-p (car rest))) (loop result (quote-constant (folder (compiler-constant-value first) (compiler-constant-value (car rest)))) (cdr rest))) (t (loop (cons first result) (car rest) (cdr rest))))))) (defun mash-constants (folder forms) (let ((consts (filter compiler-constant-p forms)) (non-consts (filter (lambda (x) (not (compiler-constant-p x))) forms))) (if consts (cons (quote-constant (apply folder (mapcar compiler-constant-value consts))) non-consts) non-consts))) ;;; Entry point (defun source-code-transform (form) (let (tem) ;; first try constant folding (when (and (consp form) (foldablep (car form))) (setq form (fold-constants form))) ;; then look for a specific tranformer (when (and (symbolp (car form)) (setq tem (get-procedure-handler (car form) 'compiler-transform-property))) (setq form (tem form))) form))) librep-0.90.2/lisp/rep/vm/compiler/rep.jl0000644000175200017520000012235711245011153017176 0ustar chrischris#| rep.jl -- inliners for many rep language features $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.vm.compiler.rep () (open rep rep.lang.doc rep.vm.bytecodes rep.vm.compiler.modules rep.vm.compiler.utils rep.vm.compiler.basic rep.vm.compiler.inline rep.vm.compiler.lap rep.vm.compiler.bindings) ;; List of side-effect-free functions. They should always return the ;; same value when given the same inputs. Used when constant folding. (define constant-functions '(+ - * / % mod max min 1+ 1- car cdr assoc assq rassoc rassq nth nthcdr last member memq arrayp aref substring concat length elt lognot not logior logxor logand equal = /= > < >= <= ash zerop null atom consp listp numberp integerp stringp vectorp bytecodep functionp macrop special-form-p subrp sequencep string-head-eq string-equal string-lessp string-match string-looking-at quote-regexp complete-string time-later-p alpha-char-p upper-case-p lower-case-p digit-char-p alphanumericp space-char-p char-upcase char-downcase quotient floor ceiling truncate round exp log sin cos tan asin acos atan sqrt expt prin1-to-string read-from-string assoc-regexp string= string< nop identity caar cdar cadr cddr caaar cdaar cadar cddar caadr cdadr caddr cdddr positivep negativep oddp evenp abs lcm % modulo lsh string-upper-case-p string-lower-case-p string-capitalized-p)) ;; List of symbols, when the name of the function called by a top-level ;; form is one of these that form is compiled. (define top-level-compiled '(if cond when unless let let* letrec catch unwind-protect condition-case progn prog1 prog2 while and or case define-structure structure)) ;; List of symbols, when the car of a top-level form is a member of this ;; list, don't macroexpand the form before compiling. (define top-level-unexpanded '(defun defmacro defvar defconst defsubst %define require declare eval-when-compile define-structure structure)) ;;; pass 1 support (defun pass-1 (forms) (add-progns (pass-1* forms))) (defun pass-1* (forms) (lift-progns (mapcar do-pass-1 forms))) ;; flatten progn forms into their container (defun lift-progns (forms) (let loop ((rest (reverse forms)) (out '())) (cond ((null rest) out) ((eq (caar rest) 'progn) (loop (cdr rest) (append (cdar rest) out))) (t (loop (cdr rest) (cons (car rest) out)))))) ;; merge `non-top-level' forms into progn blocks. These will then ;; get compiled into single run-byte-code forms (defun add-progns (forms) (let loop ((rest forms)) (cond ((null rest) forms) ((memq (caar rest) top-level-unexpanded) (loop (cdr rest))) (t (unless (eq (caar rest) 'progn) (rplaca rest (list 'progn (car rest)))) (if (and (cadr rest) (not (memq (caadr rest) top-level-unexpanded))) (progn (rplaca rest (nconc (car rest) (list (cadr rest)))) (rplacd rest (cddr rest)) (loop rest)) (loop (cdr rest))))))) (defun do-pass-1 (form) (let-fluids ((current-form form)) (unless (or (memq (car form) top-level-unexpanded) (memq (car form) top-level-compiled)) (setq form (compiler-macroexpand form (lambda (in out) (or (eq in out) (memq (car out) top-level-unexpanded) (memq (car out) top-level-compiled)))))) (case (car form) ((defun) (remember-function (nth 1 form) (nth 2 form) (nthcdr 3 form))) ((defmacro) (remember-function (nth 1 form) (nth 2 form)) (note-macro-def (nth 1 form) (cons 'lambda (nthcdr 2 form)))) ((defsubst) (fluid-set inline-env (cons (cons (nth 1 form) (cons 'lambda (nthcdr 2 form))) (fluid inline-env)))) ((defvar) (remember-variable (nth 1 form))) ((defconst) (remember-variable (nth 1 form)) (fluid-set const-env (cons (cons (nth 1 form) (nth 2 form)) (fluid const-env)))) ((%define) (remember-lexical-variable (nth 1 form))) ((require) (if (compiler-constant-p (cadr form)) (note-require (compiler-constant-value (cadr form))) ;; hmm.. (eval form))) ((declare) (note-declaration (cdr form))) ((eval-when-compile) (if (and (eq (car (nth 1 form)) 'require) (compiler-constant-p (cadr (nth 1 form)))) (note-require (compiler-constant-value (cadr (nth 1 form)))) (eval (nth 1 form)))) ((progn) (setq form (cons 'progn (pass-1* (cdr form))))) ;; put bare forms into progns so they can be merged in pass-1 (t (unless (memq (car form) top-level-unexpanded) (setq form (list 'progn form))))) form)) ;;; pass 2 support (defun pass-2 (forms) (let loop ((rest forms) (out '())) (if (null rest) (nreverse out) (loop (cdr rest) (cons (do-pass-2 (car rest)) out))))) (defun do-pass-2 (form) (let-fluids ((current-form form)) (case (car form) ((defun defsubst) (let ((tmp (assq (nth 1 form) (fluid macro-env)))) (let-fluids ((current-fun (nth 1 form))) ;;(format standard-error "[%s]\n" (fluid current-fun)) (when tmp (rplaca tmp nil) (rplacd tmp nil)) (list 'defun (nth 1 form) (compile-lambda (cons 'lambda (nthcdr 2 form)) (nth 1 form)))))) ((defmacro) (let ((code (compile-lambda (cons 'lambda (nthcdr 2 form)) (nth 1 form))) (tmp (assq (nth 1 form) (fluid macro-env)))) (let-fluids ((current-fun (nth 1 form))) (if tmp (rplacd tmp (make-closure code)) (compiler-error "compiled macro `%s' wasn't in environment" (nth 1 form))) (list 'defmacro (nth 1 form) code)))) ((defconst) (let ((doc (nth 3 form))) (when (and *compiler-write-docs* (stringp doc)) (add-documentation (nth 1 form) (fluid current-module) doc) (setq form (delq doc form))) (unless (memq (nth 1 form) (fluid defvars)) (remember-variable (nth 1 form))) (unless (assq (nth 1 form) (fluid const-env)) (compiler-warning 'bindings "unknown constant `%s'" (nth 1 form)))) form) ((defvar) (let ((value (nth 2 form)) (doc (nth 3 form))) (when (and (listp value) (not (compiler-constant-p value))) ;; Compile the definition. A good idea? (rplaca (nthcdr 2 form) (compile-form (nth 2 form)))) (when (and *compiler-write-docs* (stringp doc)) (add-documentation (nth 1 form) nil doc) (setq form (delq (nth 3 form) form))) (unless (memq (nth 1 form) (fluid defvars)) (remember-variable (nth 1 form)))) form) ((%define) (let ((sym (nth 1 form)) (value (nth 2 form)) (doc (nth 3 form))) (unless (memq sym (fluid defines)) (remember-lexical-variable (compiler-constant-value sym))) (when (and *compiler-write-docs* (stringp doc)) (add-documentation sym (fluid current-module) doc) (setq form (delq doc form))) (when (and (listp value) (not (compiler-constant-p value))) ;; Compile the definition. A good idea? (rplaca (nthcdr 2 form) (compile-form (nth 2 form)))) form)) ((define-structure) (compile-top-level-define-structure form)) ((structure) (compile-top-level-structure form)) ((eval-when-compile) nil) (t (if (memq (car form) top-level-compiled) (compile-form form) form))))) ;;; Source code transformations. These are basically macros that are only ;;; used at compile-time. ;; tells the constant-folder which functions can be removed (defun foldablep (name) (memq name constant-functions)) (defun trans-setq (form) (let (lst) (setq form (cdr form)) (while form (unless (consp (cdr form)) (compiler-error "odd number of args to setq")) (setq lst (cons `(set ',(car form) ,(nth 1 form)) lst)) (setq form (nthcdr 2 form))) (cons 'progn (nreverse lst)))) (put 'setq 'rep-compile-transform trans-setq) (defun trans-defvar (form) (let ((name (nth 1 form)) (value (nth 2 form)) (doc (nth 3 form))) (remember-variable name) (when (and (compiler-constant-p doc) (stringp (compiler-constant-value doc)) *compiler-write-docs*) (add-documentation name nil (compiler-constant-value doc)) (setq doc nil)) `(progn ,@(and doc (list `(put ',name 'variable-documentation ,doc))) (make-variable-special ',name) (unless (boundp ',name) (setq ,name ,value))))) (put 'defvar 'rep-compile-transform trans-defvar) (defun trans-require (form) (let ((feature (nth 1 form))) (when (compiler-constant-p feature) (note-require (compiler-constant-value feature))) ;; Must transform to something other than (require FEATURE) to ;; prevent infinite regress `(funcall require ,feature))) (put 'require 'rep-compile-transform trans-require) (defun trans-/= (form) `(not (= ,@(cdr form)))) (put '/= 'rep-compile-transform trans-/=) ;;; Functions which compile non-standard functions (ie special-forms) ;; module compilers from compiler-modules (put 'structure 'rep-compile-fun compile-structure) (put 'define-structure 'rep-compile-fun compile-define-structure) (put 'structure-ref 'rep-compile-fun compile-structure-ref) (defun compile-declare (form) (note-declaration (cdr form)) (compile-constant nil)) (put 'declare 'rep-compile-fun compile-declare) (defun compile-quote (form) (compile-constant (car (cdr form)))) (put 'quote 'rep-compile-fun compile-quote) (defun compile-function (form) (compile-form-1 (cadr form))) (put 'function 'rep-compile-fun compile-function) (defun compile-lambda-form (form) (compile-lambda-constant form)) (put 'lambda 'rep-compile-fun compile-lambda-form) (defun compile-while (form) (let ((top-label (make-label)) (test-label (make-label))) (emit-insn `(jmp ,test-label)) (fix-label top-label) (compile-body (nthcdr 2 form)) (emit-insn '(pop)) (decrement-stack) (fix-label test-label) (compile-form-1 (nth 1 form)) (emit-insn `(jpt ,top-label)))) (put 'while 'rep-compile-fun compile-while) (defun compile-%define (form) (compile-constant (nth 1 form)) (compile-form-1 (nth 2 form)) (emit-insn '(%define)) (decrement-stack)) (put '%define 'rep-compile-fun compile-%define) ;; Compile mapc specially if we can open code the function call (defun compile-mapc (form) (let ((fun (nth 1 form)) (lst (nth 2 form))) (if (constant-function-p fun) ;; We can open code the function (let ((top-label (make-label)) (test-label (make-label))) (setq fun (constant-function-value fun)) (compile-form-1 lst) (emit-insn `(jmp ,test-label)) (fix-label top-label) (emit-insn '(dup)) (increment-stack) (emit-insn '(car)) (compile-lambda-inline fun nil 1) (emit-insn '(pop)) (decrement-stack) (emit-insn '(cdr)) (fix-label test-label) ;; I don't have a jump-if-t-but-never-pop instruction, so ;; make one out of "jpt TOP; nil". If I ever get a peep hole ;; optimiser working, the nil should be fodder for it.. (emit-insn `(jtp ,top-label)) (emit-insn '(push ()))) ;; The function must be called, so just use the mapc opcode (compile-form-1 fun) (compile-form-1 lst) (emit-insn '(mapc)) (decrement-stack)))) (put 'mapc 'rep-compile-fun compile-mapc) (defun compile-progn (form #!optional return-follows) (compile-body (cdr form) return-follows)) (put 'progn 'rep-compile-fun compile-progn) (defun compile-prog1 (form) (compile-form-1 (nth 1 form)) (compile-body (nthcdr 2 form)) (emit-insn '(pop)) (decrement-stack)) (put 'prog1 'rep-compile-fun compile-prog1) (defun compile-set (form) (let ((sym (nth 1 form)) (val (nth 2 form))) (if (compiler-constant-p sym) ;; use setq (progn (setq sym (compiler-constant-value sym)) (unless (symbolp sym) (compiler-error "trying to set value of a non-symbol: %s" sym)) (compile-form-1 val) (emit-insn '(dup)) (increment-stack) (emit-varset sym) (note-binding-modified sym) (decrement-stack)) ;; need to preserve left-right evaluation order (compile-form-1 sym) (compile-form-1 val) (emit-insn '(set)) (decrement-stack)))) (put 'set 'rep-compile-fun compile-set) ;; compile let* specially to coalesce all bindings into a single frame (defun compile-let* (form #!optional return-follows) (let ((lst (car (cdr form)))) (call-with-frame (lambda () (emit-insn '(init-bind)) (increment-b-stack) (while (consp lst) (cond ((consp (car lst)) (let ((tmp (car lst))) (compile-body (cdr tmp)) (test-variable-bind (car tmp)) (note-binding (car tmp)) (emit-binding (car tmp)))) (t (emit-insn '(push ())) (increment-stack) (test-variable-bind (car lst)) (note-binding (car lst)) (emit-binding (car lst)))) (decrement-stack) (setq lst (cdr lst))) (compile-body (nthcdr 2 form) return-follows) (emit-insn '(unbind)) (decrement-b-stack))))) (put 'let* 'rep-compile-fun compile-let*) ;; let can be compiled straight from its macro definition ;; compile letrec specially to handle tail recursion elimination (defun compile-letrec (form #!optional return-follows) (let ((bindings (car (cdr form)))) (call-with-frame (lambda () (push-state) (emit-insn '(init-bind)) (increment-b-stack) ;; create the bindings, should really be to void values, but use nil.. (mapc (lambda (cell) (let ((var (or (car cell) cell))) (test-variable-bind var) (compile-constant nil) (note-binding var) (emit-binding var) (decrement-stack))) bindings) ;; then set them to their values (mapc (lambda (cell) (let ((var (or (car cell) cell))) (compile-body (cdr cell) nil var) (emit-varset var) (decrement-stack))) bindings) ;; Test if we can inline it away. ;; Look for forms like (letrec ((foo (lambda (..) body..))) (foo ..)) ;; where `foo' only appears in inlinable tail calls in body (when (catch 'no (unless (= (length bindings) 1) (throw 'no t)) (let ((var (or (caar bindings) (car bindings))) (value (cdar bindings))) (unless (and (binding-tail-call-only-p var) value (not (cdr value)) (eq (caar value) 'lambda)) (throw 'no t)) (setq value (car value)) (let ((body (nthcdr 2 form))) (unless (= (length body) 1) (throw 'no t)) (setq body (car body)) (when (and (eq (car body) (get-language-property 'compiler-sequencer)) (= (length body) 2)) (setq body (cadr body))) (unless (eq (car body) var) (throw 'no t)) ;; okay, let's go (let-fluids ((silence-compiler t)) (reload-state) ;; XXX what if this clashes? (remember-function var (cadr value)) (compile-lambda-inline value (cdr body) nil return-follows var) (forget-function var) nil)))) ;; no, keep on the usual track (compile-body (nthcdr 2 form) return-follows) (emit-insn '(unbind)) (decrement-b-stack)) (pop-state))))) (put 'letrec 'rep-compile-fun compile-letrec) (defun compile-let-fluids (form) (let ((bindings (cadr form)) (body (cddr form))) (call-with-frame (lambda () (fluid-set lexically-pure nil) ;; compile each fluid, value pair onto the stack (mapc (lambda (cell) (compile-form-1 (car cell)) (compile-body (cdr cell))) bindings) (emit-insn '(init-bind)) (increment-b-stack) (mapc (lambda (unused) (declare (unused unused)) (emit-insn '(fluid-bind)) (decrement-stack 2)) bindings) (compile-body body) (emit-insn '(unbind)) (decrement-b-stack))))) (put 'let-fluids 'rep-compile-fun compile-let-fluids) (defun compile-defun (form) (remember-function (nth 1 form) (nth 2 form)) (compile-constant (nth 1 form)) (compile-lambda-constant (cons 'lambda (nthcdr 2 form)) (nth 1 form)) (emit-insn '(%define)) (decrement-stack)) (put 'defun 'rep-compile-fun compile-defun) (defun compile-defmacro (form) (remember-function (nth 1 form) (nth 2 form)) (compile-constant (nth 1 form)) (compile-constant 'macro) (compile-lambda-constant (cons 'lambda (nthcdr 2 form)) (nth 1 form)) (emit-insn '(cons)) (emit-insn '(%define)) (decrement-stack)) (put 'defmacro 'rep-compile-fun compile-defmacro) (defun compile-cond (form #!optional return-follows) (let ((end-label (make-label)) (need-trailing-nil t)) (setq form (cdr form)) (while (consp form) (let* ((subl (car form)) (condition (car subl)) (next-label (make-label))) ;; See if we can squash a constant condition to t or nil (when (compiler-constant-p condition) (setq condition (not (not (compiler-constant-value condition))))) (cond ((eq condition t) ;; condition t -- always taken (if (consp (cdr subl)) ;; There's something besides the condition (progn (compile-body (cdr subl) return-follows) (decrement-stack)) (if (eq condition (car subl)) (emit-insn '(push t)) (compile-form-1 (car subl) #:return-follows return-follows) (decrement-stack))) (when (consp (cdr form)) ;;(compiler-warning ;; 'misc "unreachable conditions after t in cond statement") ;; Ignore the rest of the statement (setq form nil)) (setq need-trailing-nil nil)) ((eq condition nil) ;; condition nil -- never taken (when (cdr subl) ;;(compiler-warning ;; 'misc "unreachable forms after nil in cond statement") )) (t ;; non t-or-nil condition (compile-form-1 (car subl) #:return-follows (and return-follows (null (cdr subl)) (null (cdr form)))) (decrement-stack) (if (consp (cdr subl)) ;; Something besides the condition (if (cdr form) ;; This isn't the last condition list (progn (emit-insn `(jn ,next-label)) (compile-body (cdr subl) return-follows) (decrement-stack) (emit-insn `(jmp ,end-label)) (fix-label next-label)) ;; It is the last condition list, use the result ;; of this condition for the return value when it's ;; nil (emit-insn `(jnp ,end-label)) (compile-body (cdr subl) return-follows) (decrement-stack) (setq need-trailing-nil nil)) ;; No action to take (if (cdr form) ;; This isn't the last condition list (emit-insn `(jtp ,end-label)) ;; This is the last condition list, since there's no ;; action to take, just fall out the bottom, with the ;; condition as value. (setq need-trailing-nil nil)))))) (setq form (cdr form))) (when need-trailing-nil (emit-insn '(push ()))) (increment-stack) (fix-label end-label))) (put 'cond 'rep-compile-fun compile-cond) (defun compile-case (form #!optional return-follows) (let ((end-label (make-label)) (had-default nil)) (setq form (cdr form)) (unless form (compiler-error "no key value in case statement")) ;; XXX if key is constant optimise case away.. (compile-form-1 (car form)) (setq form (cdr form)) (while (consp form) (unless (consp form) (compiler-error "badly formed clause in case statement")) (let ((cases (caar form)) (forms (cdar form)) (next-label (make-label))) (cond ((consp cases) (emit-insn '(dup)) (increment-stack) (if (consp (cdr cases)) ;; >1 possible case (progn (compile-constant cases) (emit-insn '(memql))) ;; only one case, use eql (compile-constant (car cases)) (emit-insn '(eql))) (decrement-stack) (emit-insn `(jn ,next-label)) (decrement-stack)) ((eq cases t) (setq had-default t)) (t (compiler-error "badly formed clause in case statement" #:form cases))) (compile-body forms return-follows) (decrement-stack) (emit-insn `(jmp ,end-label)) (fix-label next-label) (setq form (cdr form)))) (unless had-default (emit-insn '(push ()))) (increment-stack) (fix-label end-label) (emit-insn '(swap)) (emit-insn '(pop)))) (put 'case 'rep-compile-fun compile-case) (defun compile-catch (form) (let ((catch-label (make-label)) (start-label (make-label)) (end-label (make-label))) (let-fluids ((lexically-pure nil)) ;; jmp start (emit-insn `(jmp ,start-label)) ;; catch: ;; catch TAG ;; ejmp end (increment-stack) ;enter with one arg on stack (fix-label catch-label) (compile-form-1 (nth 1 form)) (emit-insn '(catch)) (decrement-stack) (emit-insn `(ejmp ,end-label)) (decrement-stack) ;; start: ;; push #catch ;; binderr ;; FORMS... ;; unbind ;; end: (fix-label start-label) (push-label-addr catch-label) (emit-insn '(binderr)) (increment-b-stack) (decrement-stack) (compile-body (nthcdr 2 form)) (emit-insn '(unbind)) (decrement-b-stack) (fix-label end-label)))) (put 'catch 'rep-compile-fun compile-catch) (defun compile-unwind-pro (form) (let ((cleanup-label (make-label)) (start-label (make-label)) (end-label (make-label))) (let-fluids ((lexically-pure nil)) ;; jmp start (emit-insn `(jmp ,start-label)) ;; cleanup: ;; CLEANUP-FORMS ;; pop ;; ejmp end ;; [overall, stack +1] (increment-stack 2) (fix-label cleanup-label) (compile-body (nthcdr 2 form)) (emit-insn '(pop)) (emit-insn `(ejmp ,end-label)) (decrement-stack 2) ;; start: ;; push #cleanup ;; binderr ;; FORM ;; unbind ;; nil ;; jmp cleanup ;; [overall, stack +2] (fix-label start-label) (push-label-addr cleanup-label) (emit-insn '(binderr)) (increment-b-stack) (decrement-stack) (compile-form-1 (nth 1 form)) (emit-insn '(unbind)) (decrement-b-stack) (emit-insn '(push ())) (decrement-stack) (emit-insn `(jmp ,cleanup-label)) ;; end: (fix-label end-label)))) (put 'unwind-protect 'rep-compile-fun compile-unwind-pro) (defun compile-condition-case (form) (let ((cleanup-label (make-label)) (start-label (make-label)) (end-label (make-label)) (handlers (nthcdr 3 form))) (let-fluids ((lexically-pure nil)) ;; jmp start ;; cleanup: (emit-insn `(jmp ,start-label)) (fix-label cleanup-label) (increment-stack) ;reach here with one item on stack (if (consp handlers) (call-with-frame (lambda () (if (and (nth 1 form) (not (eq (nth 1 form) 'nil))) (let ((var (nth 1 form))) (when (spec-bound-p var) (compiler-error "condition-case can't bind to special variable `%s'" var)) (test-variable-bind var) (note-binding var) ;; XXX errorpro instruction always heap binds.. (tag-binding var 'heap-allocated)) ;; something always gets bound (let ((tem (gensym))) (note-binding tem) (tag-binding tem 'heap-allocated) ;; avoid `unused variable' warnings (note-binding-referenced tem))) ;; Loop over all but the last handler (while (consp (cdr handlers)) (if (consp (car handlers)) (let ((next-label (make-label))) ;; push CONDITIONS ;; errorpro ;; jtp next ;; HANDLER ;; jmp end ;; next: (compile-constant (car (car handlers))) (emit-insn '(errorpro)) (decrement-stack) (emit-insn `(jtp ,next-label)) (decrement-stack) (compile-body (cdr (car handlers))) (emit-insn `(jmp ,end-label)) (fix-label next-label)) (compiler-error "badly formed condition-case handler: `%s'" (car handlers) #:form handlers)) (setq handlers (cdr handlers))) ;; The last handler (if (consp (car handlers)) (let ((pc-label (make-label))) ;; push CONDITIONS ;; errorpro ;; ejmp pc ;; pc: HANDLER ;; jmp end (compile-constant (car (car handlers))) (emit-insn '(errorpro)) (decrement-stack) (emit-insn `(ejmp ,pc-label)) (fix-label pc-label) (decrement-stack) (compile-body (cdr (car handlers))) (emit-insn `(jmp ,end-label))) (compiler-error "badly formed condition-case handler: `%s'" (car handlers) #:form (car handlers))))) (compiler-error "no handlers in condition-case")) (decrement-stack) ;; start: ;; push cleanup ;; binderr ;; FORM (fix-label start-label) (push-label-addr cleanup-label) (emit-insn '(binderr)) (increment-b-stack) (decrement-stack) (compile-form-1 (nth 2 form)) ;; end: ;; unbind ;unbind error handler or VAR (fix-label end-label) (emit-insn '(unbind)) (decrement-b-stack)))) (put 'condition-case 'rep-compile-fun compile-condition-case) (defun compile-list (form) (do ((args (cdr form) (cdr args)) (count 0 (1+ count))) ((null args) ;; merge the arguments into a single list (compile-constant '()) (do ((i 0 (1+ i))) ((= i count)) (emit-insn '(cons)) (decrement-stack))) (compile-form-1 (car args)))) (put 'list 'rep-compile-fun compile-list) (defun compile-list* (form) (do ((args (cdr form) (cdr args)) (count 0 (1+ count))) ((null args) ;; merge the arguments into a single list (do ((i 0 (1+ i))) ((>= i (1- count))) (emit-insn '(cons)) (decrement-stack))) (compile-form-1 (car args)))) (put 'list* 'rep-compile-fun compile-list*) ;; Funcall normally translates to a single call instruction. However, ;; if the function being called is a constant lambda expression, open ;; code it. (defun compile-funcall (form #!optional return-follows) (let* ((fun (nth 1 form)) (args (nthcdr 2 form)) (arg-count 0) (open-code (constant-function-p fun))) (unless open-code (compile-form-1 fun)) (while args (compile-form-1 (car args)) (setq args (cdr args) arg-count (1+ arg-count))) (if open-code (progn (compile-lambda-inline (constant-function-value fun) nil arg-count return-follows) ;; We push one less value than when using 'call (if (zerop arg-count) (increment-stack) (decrement-stack (1- arg-count)))) (emit-insn `(call ,arg-count)) (note-function-call-made) (decrement-stack arg-count)))) (put 'funcall 'rep-compile-fun compile-funcall) (defun compile-apply (form) (compile-form-1 (nth 1 form)) (do ((args (nthcdr 2 form) (cdr args)) (count 0 (1+ count))) ((null args) ;; merge the arguments into a single list (do ((i 0 (1+ i))) ((>= i (1- count))) (emit-insn '(cons)) (decrement-stack))) (compile-form-1 (car args))) (emit-insn '(apply)) (decrement-stack)) (put 'apply 'rep-compile-fun compile-apply) (defun compile-nth (form) (let ((insn (cdr (assq (nth 1 form) byte-nth-insns)))) (if insn (progn (compile-form-1 (nth 2 form)) (emit-insn (list insn))) (compile-2-args form)))) (put 'nth 'rep-compile-fun compile-nth) (put 'nth 'rep-compile-opcode 'nth) (defun compile-nthcdr (form) (let ((insn (assq (nth 1 form) byte-nthcdr-insns))) (if insn (progn (compile-form-1 (nth 2 form)) (when (cdr insn) (emit-insn (list (cdr insn))))) (compile-2-args form)))) (put 'nthcdr 'rep-compile-fun compile-nthcdr) (put 'nthcdr 'rep-compile-opcode 'nthcdr) (defun compile-minus (form) (if (/= (length form) 2) (compile-binary-op form) (compile-form-1 (car (cdr form))) (emit-insn '(neg)))) (put '- 'rep-compile-fun compile-minus) (put '- 'rep-compile-opcode 'sub) (defun compile-make-closure (form) (when (nthcdr 3 form) (compiler-warning 'parameters "more than two parameters to `%s'; rest ignored" (car form))) (compile-form-1 (nth 1 form)) (compile-form-1 (nth 2 form)) (emit-insn '(make-closure)) (note-closure-made) (decrement-stack)) (put 'make-closure 'rep-compile-fun compile-make-closure) (defun compile-log (form) (cond ((nthcdr 3 form) (compiler-warning 'parameters "more than two parameters to `log'; rest ignored")) ((nthcdr 2 form) ;; dual argument form of log. compiles to (compile-form-1 (nth 1 form)) (emit-insn '(log)) (compile-form-1 (nth 2 form)) (emit-insn '(log)) (emit-insn '(div)) (decrement-stack)) ((nthcdr 1 form) ;; single argument form (compile-form-1 (nth 1 form)) (emit-insn '(log))) (t (compiler-warning 'parameters "too few parameters to `log'")))) (put 'log 'rep-compile-fun compile-log) (defun get-form-opcode (form) (cond ((symbolp form) (get form 'rep-compile-opcode)) ;; must be a structure-ref ((eq (car form) 'structure-ref) (get (caddr form) 'rep-compile-opcode)) (t (compiler-error "don't know opcode for `%s'" form)))) ;; Instruction with no arguments (defun compile-0-args (form) (when (cdr form) (compiler-warning 'parameters "all parameters to `%s' ignored" (car form))) (emit-insn (list (get-form-opcode (car form)))) (increment-stack)) ;; Instruction taking 1 arg on the stack (defun compile-1-args (form) (when (nthcdr 2 form) (compiler-warning 'parameters "more than one parameter to `%s'; rest ignored" (car form))) (compile-form-1 (nth 1 form)) (emit-insn (list (get-form-opcode (car form))))) ;; Instruction taking 2 args on the stack (defun compile-2-args (form) (when (nthcdr 3 form) (compiler-warning 'parameters "more than two parameters to `%s'; rest ignored" (car form))) (compile-form-1 (nth 1 form)) (compile-form-1 (nth 2 form)) (emit-insn (list (get-form-opcode (car form)))) (decrement-stack)) ;; Instruction taking 3 args on the stack (defun compile-3-args (form) (when (nthcdr 4 form) (compiler-warning 'parameters "More than three parameters to `%s'; rest ignored" (car form))) (compile-form-1 (nth 1 form)) (compile-form-1 (nth 2 form)) (compile-form-1 (nth 3 form)) (emit-insn (list (get-form-opcode (car form)))) (decrement-stack 2)) ;; Compile a form `(OP ARG1 ARG2 ARG3 ...)' into as many two argument ;; instructions as needed (PUSH ARG1; PUSH ARG2; OP; PUSH ARG3; OP; ...) (defun compile-binary-op (form) (let ((opcode (get-form-opcode (car form)))) (setq form (cdr form)) (unless (>= (length form) 2) (compiler-error "too few arguments to binary operator `%s'" (car form))) (compile-form-1 (car form)) (setq form (cdr form)) (while (consp form) (compile-form-1 (car form)) (emit-insn (list opcode)) (decrement-stack) (setq form (cdr form))))) ;; Used for >, >=, < and <= (defun compile-transitive-relation (form) (cond ((<= (length form) 2) (compiler-error "too few args to relation `%s'" (car form))) ((= (length form) 3) (let ((opcode (get-form-opcode (car form)))) ;; Simple case, only two arguments, i.e. `(OP ARG1 ARG2)' into: ;; PUSH ARG1; PUSH ARG2; OP; (compile-form-1 (nth 1 form)) (compile-form-1 (nth 2 form)) (emit-insn (list opcode)) (decrement-stack))) (t ;; Tricky case, >2 args, ;; Originally I did `(OP ARG1 ARG2 ARG3... ARGN)' as: ;; PUSH ARG1; PUSH ARG2; DUP; SWAP2; OP; JNP Fail; ;; PUSH ARG3; DUP; SWAP2; OP; JNP Fail; ;; ... ;; PUSH ARGN; OP; JMP End; ;; Fail: ;; SWAP; POP; ;; End: ;; But that doesn't always evaluate all arguments.. (compile-funcall (cons 'funcall form))))) ;;; Opcode properties for the generic instructions, in a progn for compiled ;;; speed (progn (put 'cons 'rep-compile-fun compile-2-args) (put 'cons 'rep-compile-opcode 'cons) (put 'car 'rep-compile-fun compile-1-args) (put 'car 'rep-compile-opcode 'car) (put 'cdr 'rep-compile-fun compile-1-args) (put 'cdr 'rep-compile-opcode 'cdr) (put 'rplaca 'rep-compile-fun compile-2-args) (put 'rplaca 'rep-compile-opcode 'rplaca) (put 'rplacd 'rep-compile-fun compile-2-args) (put 'rplacd 'rep-compile-opcode 'rplacd) (put 'aset 'rep-compile-fun compile-3-args) (put 'aset 'rep-compile-opcode 'aset) (put 'aref 'rep-compile-fun compile-2-args) (put 'aref 'rep-compile-opcode 'aref) (put 'length 'rep-compile-fun compile-1-args) (put 'length 'rep-compile-opcode 'length) (put '+ 'rep-compile-fun compile-binary-op) (put '+ 'rep-compile-opcode 'add) (put '* 'rep-compile-fun compile-binary-op) (put '* 'rep-compile-opcode 'mul) (put '/ 'rep-compile-fun compile-binary-op) (put '/ 'rep-compile-opcode 'div) (put 'remainder 'rep-compile-fun compile-2-args) (put 'remainder 'rep-compile-opcode 'rem) (put 'mod 'rep-compile-fun compile-2-args) (put 'mod 'rep-compile-opcode 'mod) (put 'lognot 'rep-compile-fun compile-1-args) (put 'lognot 'rep-compile-opcode 'lnot) (put 'not 'rep-compile-fun compile-1-args) (put 'not 'rep-compile-opcode 'not) (put 'logior 'rep-compile-fun compile-binary-op) (put 'logior 'rep-compile-opcode 'lor) (put 'logxor 'rep-compile-fun compile-binary-op) (put 'logxor 'rep-compile-opcode 'lxor) (put 'logand 'rep-compile-fun compile-binary-op) (put 'logand 'rep-compile-opcode 'land) (put 'ash 'rep-compile-fun compile-2-args) (put 'ash 'rep-compile-opcode 'ash) (put 'equal 'rep-compile-fun compile-2-args) (put 'equal 'rep-compile-opcode 'equal) (put 'eq 'rep-compile-fun compile-2-args) (put 'eq 'rep-compile-opcode 'eq) (put '= 'rep-compile-fun compile-transitive-relation) (put '= 'rep-compile-opcode 'num-eq) (put '> 'rep-compile-fun compile-transitive-relation) (put '> 'rep-compile-opcode 'gt) (put '< 'rep-compile-fun compile-transitive-relation) (put '< 'rep-compile-opcode 'lt) (put '>= 'rep-compile-fun compile-transitive-relation) (put '>= 'rep-compile-opcode 'ge) (put '<= 'rep-compile-fun compile-transitive-relation) (put '<= 'rep-compile-opcode 'le) (put '1+ 'rep-compile-fun compile-1-args) (put '1+ 'rep-compile-opcode 'inc) (put '1- 'rep-compile-fun compile-1-args) (put '1- 'rep-compile-opcode 'dec) (put 'zerop 'rep-compile-fun compile-1-args) (put 'zerop 'rep-compile-opcode 'zerop) (put 'null 'rep-compile-fun compile-1-args) (put 'null 'rep-compile-opcode 'not) (put 'atom 'rep-compile-fun compile-1-args) (put 'atom 'rep-compile-opcode 'atom) (put 'consp 'rep-compile-fun compile-1-args) (put 'consp 'rep-compile-opcode 'consp) (put 'listp 'rep-compile-fun compile-1-args) (put 'listp 'rep-compile-opcode 'listp) (put 'numberp 'rep-compile-fun compile-1-args) (put 'numberp 'rep-compile-opcode 'numberp) (put 'stringp 'rep-compile-fun compile-1-args) (put 'stringp 'rep-compile-opcode 'stringp) (put 'vectorp 'rep-compile-fun compile-1-args) (put 'vectorp 'rep-compile-opcode 'vectorp) (put 'throw 'rep-compile-fun compile-2-args) (put 'throw 'rep-compile-opcode 'throw) (put 'boundp 'rep-compile-fun compile-1-args) (put 'boundp 'rep-compile-opcode 'boundp) (put 'symbolp 'rep-compile-fun compile-1-args) (put 'symbolp 'rep-compile-opcode 'symbolp) (put 'get 'rep-compile-fun compile-2-args) (put 'get 'rep-compile-opcode 'get) (put 'put 'rep-compile-fun compile-3-args) (put 'put 'rep-compile-opcode 'put) (put 'signal 'rep-compile-fun compile-2-args) (put 'signal 'rep-compile-opcode 'signal) (put 'quotient 'rep-compile-fun compile-2-args) (put 'quotient 'rep-compile-opcode 'quotient) (put 'reverse 'rep-compile-fun compile-1-args) ; new 12/7/94 (put 'reverse 'rep-compile-opcode 'reverse) (put 'nreverse 'rep-compile-fun compile-1-args) (put 'nreverse 'rep-compile-opcode 'nreverse) (put 'assoc 'rep-compile-fun compile-2-args) (put 'assoc 'rep-compile-opcode 'assoc) (put 'assq 'rep-compile-fun compile-2-args) (put 'assq 'rep-compile-opcode 'assq) (put 'rassoc 'rep-compile-fun compile-2-args) (put 'rassoc 'rep-compile-opcode 'rassoc) (put 'rassq 'rep-compile-fun compile-2-args) (put 'rassq 'rep-compile-opcode 'rassq) (put 'last 'rep-compile-fun compile-1-args) (put 'last 'rep-compile-opcode 'last) (put 'mapcar 'rep-compile-fun compile-2-args) (put 'mapcar 'rep-compile-opcode 'mapcar) (put 'member 'rep-compile-fun compile-2-args) (put 'member 'rep-compile-opcode 'member) (put 'memq 'rep-compile-fun compile-2-args) (put 'memq 'rep-compile-opcode 'memq) (put 'delete 'rep-compile-fun compile-2-args) (put 'delete 'rep-compile-opcode 'delete) (put 'delq 'rep-compile-fun compile-2-args) (put 'delq 'rep-compile-opcode 'delq) (put 'delete-if 'rep-compile-fun compile-2-args) (put 'delete-if 'rep-compile-opcode 'delete-if) (put 'delete-if-not 'rep-compile-fun compile-2-args) (put 'delete-if-not 'rep-compile-opcode 'delete-if-not) (put 'copy-sequence 'rep-compile-fun compile-1-args) (put 'copy-sequence 'rep-compile-opcode 'copy-sequence) (put 'sequencep 'rep-compile-fun compile-1-args) (put 'sequencep 'rep-compile-opcode 'sequencep) (put 'functionp 'rep-compile-fun compile-1-args) (put 'functionp 'rep-compile-opcode 'functionp) (put 'special-form-p 'rep-compile-fun compile-1-args) (put 'special-form-p 'rep-compile-opcode 'special-form-p) (put 'subrp 'rep-compile-fun compile-1-args) (put 'subrp 'rep-compile-opcode 'subrp) (put 'eql 'rep-compile-fun compile-2-args) (put 'eql 'rep-compile-opcode 'eql) (put 'max 'rep-compile-fun compile-binary-op) (put 'max 'rep-compile-opcode 'max) (put 'min 'rep-compile-fun compile-binary-op) (put 'min 'rep-compile-opcode 'min) (put 'filter 'rep-compile-fun compile-2-args) (put 'filter 'rep-compile-opcode 'filter) (put 'macrop 'rep-compile-fun compile-1-args) (put 'macrop 'rep-compile-opcode 'macrop) (put 'bytecodep 'rep-compile-fun compile-1-args) (put 'bytecodep 'rep-compile-opcode 'bytecodep) (put 'closurep 'rep-compile-fun compile-1-args) (put 'closurep 'rep-compile-opcode 'closurep) (put 'thread-forbid 'rep-compile-fun compile-0-args) (put 'thread-forbid 'rep-compile-opcode 'forbid) (put 'thread-permit 'rep-compile-fun compile-0-args) (put 'thread-permit 'rep-compile-opcode 'permit) (put 'fluid 'rep-compile-fun compile-1-args) (put 'fluid 'rep-compile-opcode 'fluid-ref) (put 'fluid-set 'rep-compile-fun compile-2-args) (put 'fluid-set 'rep-compile-opcode 'fluid-set) (put 'caar 'rep-compile-fun compile-1-args) (put 'caar 'rep-compile-opcode 'caar) (put 'cadr 'rep-compile-fun compile-1-args) (put 'cadr 'rep-compile-opcode 'cadr) (put 'cdar 'rep-compile-fun compile-1-args) (put 'cdar 'rep-compile-opcode 'cdar) (put 'cddr 'rep-compile-fun compile-1-args) (put 'cddr 'rep-compile-opcode 'cddr) (put 'caddr 'rep-compile-fun compile-1-args) (put 'caddr 'rep-compile-opcode 'caddr) (put 'cadddr 'rep-compile-fun compile-1-args) (put 'cadddr 'rep-compile-opcode 'cadddr) (put 'floor 'rep-compile-fun compile-1-args) (put 'floor 'rep-compile-opcode 'floor) (put 'ceiling 'rep-compile-fun compile-1-args) (put 'ceiling 'rep-compile-opcode 'ceiling) (put 'truncate 'rep-compile-fun compile-1-args) (put 'truncate 'rep-compile-opcode 'truncate) (put 'round 'rep-compile-fun compile-1-args) (put 'round 'rep-compile-opcode 'round) (put 'exp 'rep-compile-fun compile-1-args) (put 'exp 'rep-compile-opcode 'exp) (put 'sin 'rep-compile-fun compile-1-args) (put 'sin 'rep-compile-opcode 'sin) (put 'cos 'rep-compile-fun compile-1-args) (put 'cos 'rep-compile-opcode 'cos) (put 'tan 'rep-compile-fun compile-1-args) (put 'tan 'rep-compile-opcode 'tan) (put 'sqrt 'rep-compile-fun compile-1-args) (put 'sqrt 'rep-compile-opcode 'sqrt) (put 'expt 'rep-compile-fun compile-2-args) (put 'expt 'rep-compile-opcode 'expt) ;; some pseudonyms (put 'string= 'rep-compile-fun compile-2-args) (put 'string= 'rep-compile-opcode 'equal) (put 'string< 'rep-compile-fun compile-transitive-relation) (put 'string< 'rep-compile-opcode 'lt) (put '% 'rep-compile-fun compile-2-args) (put '% 'rep-compile-opcode 'rem) (put 'modulo 'rep-compile-fun compile-2-args) (put 'modulo 'rep-compile-opcode 'mod) (put 'lsh 'rep-compile-fun compile-2-args) (put 'lsh 'rep-compile-opcode 'ash)) ;; setup properties to tell the compiler where to look for symbols ;; in the `rep' package (unless (get 'rep 'compiler-handler-property) (put 'rep 'compiler-handler-property 'rep-compile-fun) (put 'rep 'compiler-transform-property 'rep-compile-transform) (put 'rep 'compiler-sequencer 'progn) (put 'rep 'compiler-pass-1 pass-1) (put 'rep 'compiler-pass-2 pass-2) (put 'rep 'compiler-foldablep foldablep))) librep-0.90.2/lisp/rep/vm/compiler/no-lang.jl0000644000175200017520000000265711245011153017743 0ustar chrischris#| no-lang.jl -- minimal environment for when modules don't import a lang $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.vm.compiler.no-lang () (open rep rep.vm.compiler.modules rep.vm.compiler.rep) ;; setup properties to tell the compiler where to look for symbols ;; in the `no-lang' package (put 'no-lang 'compiler-handler-property 'no-lang-compile-fun) ;;; no pass-1 or pass-2 handlers means no compilation! ;;; module compilers ;; module compilers from compiler-modules (put 'structure 'no-lang-compile-fun compile-structure) (put 'define-structure 'no-lang-compile-fun compile-define-structure) (put 'structure-ref 'no-lang-compile-fun compile-structure-ref)) librep-0.90.2/lisp/rep/vm/compiler/modules.jl0000644000175200017520000003324411245011153020054 0ustar chrischris#| modules.jl -- module handling for the compiler $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.vm.compiler.modules (export current-module macro-env variable-ref-p locate-variable compiler-symbol-value compiler-boundp compiler-binding-from-rep-p compiler-binding-immutable-p get-procedure-handler get-language-property compiler-macroexpand compiler-macroexpand-1 compile-module-body note-require note-macro-def compile-structure compile-define-structure compile-top-level-structure compile-top-level-define-structure compile-structure-ref compile-function compile-module) (open rep rep.structures rep.vm.compiler.basic rep.vm.compiler.bindings rep.vm.compiler.utils rep.vm.compiler.lap) (define macro-env (make-fluid '())) ;alist of (NAME . MACRO-DEF) (define default-macro-env (make-fluid '())) ;;; module environment of form being compiled ;; the name of the module being compiled in (define current-module (make-fluid *user-structure*)) ;; if true, the namespace of the module being compiled in; only ;; set when compiling code outside a module definition (define current-structure (make-fluid (get-structure (fluid current-module)))) (define current-language (make-fluid 'rep)) ;; the names of the currently open and accessed modules (define open-modules (make-fluid (and (fluid current-structure) (structure-imports (fluid current-structure))))) (define accessed-modules (make-fluid (and (fluid current-structure) (structure-accessible (fluid current-structure))))) ;;; functions (define (find-structure name) (condition-case nil (intern-structure name) (file-error nil))) ;; return t if the module called STRUCT exports a variable called VAR (defun module-exports-p (struct var) (and (symbolp var) (cond ((symbolp struct) (let ((tem (find-structure struct))) (and tem (structure-exports-p tem var)))) ((structurep struct) (structure-exports-p struct var))))) ;; return t if ARG is a structure reference form (defun structure-ref-p (arg) (and (eq (car arg) 'structure-ref) (memq (locate-variable 'structure-ref) '(rep rep.module-system)))) ;; return t if ARG refers to a variable (defun variable-ref-p (arg) (or (symbolp arg) (structure-ref-p arg))) ;; return the name of the structure exporting VAR to the current ;; structure, or nil (defun locate-variable (var) (if (structure-ref-p var) (nth 1 var) (let loop ((rest (fluid open-modules))) (if rest (if (module-exports-p (car rest) var) (car rest) (loop (cdr rest))) ;; it's not exported by any opened modules, if we have a handle ;; on the current module (i.e. we're compiling code not in ;; a module definition) try looking in that (if (and (symbolp var) (fluid current-structure) (structure-bound-p (fluid current-structure) var)) (fluid current-module) nil))))) (defun variable-stem (var) (if (consp var) (nth 2 var) ;structure-ref var)) (defun symbol-value-1 (var) (cond ((and (symbolp var) (special-variable-p var)) (symbol-value var)) ((and (symbolp var) (fluid current-structure) (structure-bound-p (fluid current-structure) var)) (%structure-ref (fluid current-structure) var)) ((has-local-binding-p var) nil) (t (let* ((struct (locate-variable var)) (module (and struct (find-structure struct)))) (and module (structure-bound-p module (variable-stem var)) (%structure-ref module (variable-stem var))))))) ;; if possible, return the value of variable VAR, else return nil (defun compiler-symbol-value (var) (let ((value (symbol-value-1 var))) ;; if the value is an autoload, try to load it (if (and (closurep value) (eq (car (closure-function value)) 'autoload)) (load-autoload value) value))) (defun compiler-boundp (var) (and (symbolp var) (or (locate-variable var) (and (special-variable-p var) (boundp var))))) ;; return t if the binding of VAR comes from the rep (built-ins) module (defun compiler-binding-from-rep-p (var) (if (structure-ref-p var) (eq (nth 1 var) 'rep) (and (not (has-local-binding-p var)) (eq (locate-variable var) 'rep)))) ;; return t if the binding of VAR is a known constant ;; (not including those in comp-constant-env) (defun compiler-binding-immutable-p (var) (and (not (has-local-binding-p var)) (let ((struct (locate-variable var))) (and struct (binding-immutable-p (variable-stem var) (find-structure struct)))))) (defun get-language-property (prop) (and (fluid current-language) (get (fluid current-language) prop))) (defun get-procedure-handler (name prop-name) (unless (has-local-binding-p name) (let* ((struct (locate-variable name)) (prop (and struct (get struct prop-name)))) (if (and prop (symbolp prop)) (get (variable-stem name) prop) prop)))) (defun compiler-macroexpand-1 (form) (when (and (consp form) (symbolp (car form)) (not (has-local-binding-p (car form)))) (let* ((def (assq (car form) (fluid macro-env))) ;; make # pass us any inner expansions (macro-environment compiler-macroexpand-1)) (if def (setq form (apply (cdr def) (cdr form))) (setq def (compiler-symbol-value (car form))) (when (and (eq (car def) 'macro) (functionp (cdr def))) (when (and (closurep (cdr def)) (eq (car (closure-function (cdr def))) 'autoload)) (setq def (load-autoload (cdr def)))) (setq form (apply (cdr def) (cdr form))))))) form) (defun compiler-macroexpand (form #!optional pred) (let loop ((in form)) (let ((out (compiler-macroexpand-1 in))) ;;(format standard-error "in: %S, out: %S\n" in out) (if ((or pred eq) in out) out (loop out))))) ;; if OPENED or ACCESSED are `t', the current values are used (defun call-with-module-env (thunk opened accessed) (let-fluids ((macro-env (fluid default-macro-env)) (current-module (fluid current-module)) (current-structure (fluid current-structure)) (current-language (fluid current-language)) (open-modules (if (eq opened t) (fluid open-modules) opened)) (accessed-modules (if (eq accessed t) (fluid accessed-modules) accessed)) (const-env nil) (inline-env nil) (defuns nil) (defvars (fluid defvars)) (defines nil) (lexically-pure t) (output-stream nil)) (thunk))) (defun compile-module-body-1 (body) (find-language-module) (let ;; find language pass-1 and pass-2 compilers ((pass-1 (get-language-property 'compiler-pass-1)) (pass-2 (get-language-property 'compiler-pass-2))) ;; pass 1. remember definitions in the body for pass 2 (when pass-1 (setq body (pass-1 body))) ;; pass 2. the actual compilation (when pass-2 (setq body (pass-2 body))) ;; return the compiled representation of the body body)) (defun compile-module-body (body opened accessed) (call-with-module-env (lambda () (compile-module-body-1 body)) opened accessed)) (defun note-require (feature) (unless (or (memq feature (fluid open-modules)) (and (fluid current-structure) (eval `(featurep ',feature) (fluid current-structure)))) ;; XXX this is broken; there's no way to tell if we're trying ;; XXX to load a module, or a bare file. (cond ((get-structure feature) ;; structure already loaded.. (fluid-set open-modules (cons feature (fluid open-modules)))) ((fluid current-structure) ;; try to require it.. (eval `(require ',feature) (fluid current-structure)) (when (get-structure feature) (fluid-set open-modules (cons feature (fluid open-modules))))) ;; no current structure, try to load the file ;; as a module.. ((intern-structure feature) (fluid-set open-modules (cons feature (fluid open-modules)))) (t (compiler-warning "unable to require `%s'" feature))))) ;; XXX enclose macro defs in the *user-structure*, this is different ;; to with interpreted code (defun note-macro-def (name body) (fluid-set macro-env (cons (cons name (let ((closure (make-closure body))) (set-closure-structure closure (get-structure *user-structure*)) closure)) (fluid macro-env)))) (defun call-with-structure (thunk struct) (let-fluids ((current-module (structure-name struct)) (current-structure struct) (current-language nil)) (let-fluids ((open-modules (and (fluid current-structure) (structure-imports (fluid current-structure)))) (accessed-modules (and (fluid current-structure) (structure-accessible (fluid current-structure))))) (find-language-module) (thunk)))) (defun find-language-module () ;; scan all opened modules for a known language (catch 'out (mapc (lambda (struct) (if (get struct 'compiler-module) (progn (or (intern-structure (get struct 'compiler-module)) (compiler-error "unable to load module `%s'" (get struct 'compiler-module))) (fluid-set current-language struct) (throw 'out)))) (fluid open-modules)) (fluid-set current-language 'no-lang))) ;;; declarations ;; (declare (in-module STRUCT)) (defun declare-in-module (form) (fluid-set current-module (cadr form)) (fluid-set current-structure (intern-structure (fluid current-module)))) (put 'in-module 'compiler-decl-fun declare-in-module) ;; (declare (language LANG)) (defun declare-language (form) (fluid-set current-language (cadr form))) (put 'language 'compiler-decl-fun declare-language) ;;; module compilers (defun compile-structure (form) (compile-structure-def nil (cadr form) (cddr form))) (defun compile-define-structure (form) (compile-structure-def (cadr form) (caddr form) (cdddr form))) (defun compile-top-level-structure (form) (compile-structure-def nil (cadr form) (cddr form) t)) (defun compile-top-level-define-structure (form) (compile-structure-def (cadr form) (caddr form) (cdddr form) t)) (defun compile-structure-def (name sig body #!optional top-level) (let ((opened '(rep.module-system)) (accessed '()) (config (car body)) header) (setq body (cdr body)) (unless (listp (car config)) (setq config (list config))) (mapc (lambda (clause) (case (car clause) ((open) (setq opened (nconc (reverse (cdr clause)) opened)) (setq header (cons clause header))) ((access) (setq accessed (nconc (reverse (cdr clause)) accessed)) (setq header (cons clause header))) (t (setq header (cons clause header))))) config) (setq header (cons '(open rep.module-system) (nreverse header))) (let-fluids ((current-structure nil) (current-module name)) (call-with-module-env (lambda () (setq body (compile-module-body-1 body)) (if top-level (if name `(define-structure ,name ,sig ,config ,@body) `(structure ,sig ,config ,@body)) (compile-form-1 '%make-structure) (compile-form-1 `(%parse-interface ',sig)) (if header (progn (compile-constant `(lambda () ,@header)) (emit-insn '(enclose))) (compile-constant nil)) (if body ;; compile non-top-level structure bodies, so that ;; they can access the active bindings (compile-lambda-constant `(lambda () ,@body)) (compile-constant nil)) (when name (compile-constant name)) (emit-insn `(call ,(if name 4 3))) (note-function-call-made) (decrement-stack (if name 4 3)))) opened accessed)))) (defun compile-structure-ref (form) (let ((struct (nth 1 form)) (var (nth 2 form))) (or (memq struct (fluid accessed-modules)) (memq struct (fluid open-modules)) (compiler-error "referencing non-accessible structure `%s'" struct)) (or (module-exports-p struct var) (compiler-error "referencing private variable `%s#%s'" struct var)) (compile-constant struct) (compile-constant var) (emit-insn '(structure-ref)) (decrement-stack))) ;;; exported top-level functions (defun compile-function (function #!optional name) "Compiles the body of the function FUNCTION." (interactive "aFunction to compile:") (let-fluids ((defuns nil) (defvars nil) (defines nil) (current-fun function) (output-stream nil)) (let ((body (closure-function function))) (unless (bytecodep body) (call-with-structure (lambda () (set-closure-function function (compile-lambda body name))) (closure-structure function))) function))) (defun compile-module (struct) "Compiles all function bindings in the module named STRUCT." (interactive "SModule name:") (let ((struct (intern-structure struct))) (when struct (structure-walk (lambda (var value) (when (closurep value) (compile-function value var))) struct))))) librep-0.90.2/lisp/rep/vm/compiler/lap.jl0000644000175200017520000000611611245011153017156 0ustar chrischris#| lap.jl -- intermediate code management $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.vm.compiler.lap (export intermediate-code emit-insn make-label push-label-addr fix-label prefix-label push-state pop-state reload-state saved-state) (open rep rep.vm.compiler.utils rep.vm.compiler.bindings) (define saved-state (make-fluid)) ;; list of (INSN . [ARG]), (TAG . REFS) (define intermediate-code (make-fluid '())) ;; Output one opcode and its optional argument (define (emit-insn insn) (when (consp insn) ;; so the peepholer can safely modify code (setq insn (copy-sequence insn))) (fluid-set intermediate-code (cons insn (fluid intermediate-code)))) ;; Create a new label (define make-label gensym) ;; Arrange for the address of LABEL to be pushed onto the stack (define (push-label-addr label) (emit-insn `(push-label ,label)) (increment-stack)) ;; Set the address of the label LABEL to the current pc (define fix-label emit-insn) (define (prefix-label label) (fluid-set intermediate-code (nconc (list label) (fluid intermediate-code)))) (define (push-state) (fluid-set saved-state (cons (list (cons intermediate-code (fluid intermediate-code)) (cons spec-bindings (fluid spec-bindings)) (cons lex-bindings (mapcar (lambda (x) (copy-sequence x)) (fluid lex-bindings))) (cons lexically-pure (fluid lexically-pure)) (cons current-stack (fluid current-stack)) (cons max-stack (fluid max-stack)) (cons current-b-stack (fluid current-b-stack)) (cons max-b-stack (fluid max-b-stack))) (fluid saved-state)))) (define (pop-state) (fluid-set saved-state (cdr (fluid saved-state)))) ;; reload lex-bindings value, preserving eq-ness of cells (define (reload-lex-bindings saved) (let loop ((rest (fluid lex-bindings))) (if (eq (caar rest) (caar saved)) (progn (fluid-set lex-bindings rest) (do ((old rest (cdr old)) (new saved (cdr new))) ((null old)) (rplacd (car old) (cdr (car new))))) (loop (cdr rest))))) (define (reload-state) (mapc (lambda (cell) (if (eq (car cell) lex-bindings) (reload-lex-bindings (cdr cell)) (fluid-set (car cell) (cdr cell)))) (car (fluid saved-state))))) librep-0.90.2/lisp/rep/vm/compiler/inline.jl0000644000175200017520000001715411245011153017664 0ustar chrischris#| inline.jl -- function inlining $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.vm.compiler.inline (export compile-lambda-inline compile-tail-call) (open rep rep.vm.compiler.utils rep.vm.compiler.basic rep.vm.compiler.modules rep.vm.compiler.lap rep.vm.compiler.bindings) (define inline-depth (make-fluid 0)) ;depth of lambda-inlining (defconst max-inline-depth 64) (defun push-inline-args (lambda-list args #!optional pushed-args-already tester) (let ((arg-count 0)) (if (not pushed-args-already) ;; First of all, evaluate each argument onto the stack (while (consp args) (compile-form-1 (car args)) (setq args (cdr args) arg-count (1+ arg-count))) ;; Args already on stack (setq args nil arg-count pushed-args-already)) ;; Now the interesting bit. The args are on the stack, in ;; reverse order. So now we have to scan the lambda-list to ;; see what they should be bound to. (let ((state 'required) (args-left arg-count) (bind-stack '())) (mapc tester (get-lambda-vars lambda-list)) (while lambda-list (cond ((symbolp lambda-list) (setq bind-stack (cons (cons lambda-list args-left) bind-stack)) (setq args-left 0)) ((consp lambda-list) (case (car lambda-list) ((#!optional &optional) (setq state 'optional)) ((#!rest &rest) (setq state 'rest)) ;; XXX implement keyword params ((#!key) (compiler-error "can't inline `#!key' parameters")) (t (case state ((required) (if (zerop args-left) (compiler-error "required arg `%s' missing" (car lambda-list)) (setq bind-stack (cons (car lambda-list) bind-stack) args-left (1- args-left)))) ((optional) (if (zerop args-left) (let ((def (cdar lambda-list))) (if def (compile-form-1 (car def)) (emit-insn '(push ()))) (increment-stack)) (setq args-left (1- args-left))) (setq bind-stack (cons (or (caar lambda-list) (car lambda-list)) bind-stack))) ((rest) (setq bind-stack (cons (cons (car lambda-list) args-left) bind-stack) args-left 0 state '*done*))))))) (setq lambda-list (cdr lambda-list))) (when (> args-left 0) (compiler-warning 'parameters "%d unused %s to lambda expression" args-left (if (= args-left 1) "parameter" "parameters"))) (cons args-left bind-stack)))) (defun pop-inline-args (bind-stack args-left setter) ;; Bind all variables (while bind-stack (if (consp (car bind-stack)) (progn (compile-constant '()) (unless (null (cdr (car bind-stack))) (do ((i 0 (1+ i))) ((= i (cdr (car bind-stack)))) (emit-insn '(cons)) (decrement-stack))) (setter (car (car bind-stack)))) (setter (car bind-stack))) (decrement-stack) (setq bind-stack (cdr bind-stack))) ;; Then pop any args that weren't used. (while (> args-left 0) (emit-insn '(pop)) (decrement-stack) (setq args-left (1- args-left)))) ;; This compiles an inline lambda, i.e. FUN is something like ;; (lambda (LAMBDA-LIST...) BODY...) ;; If PUSHED-ARGS-ALREADY is true it should be a count of the number ;; of arguments pushed onto the stack (in reverse order). In this case, ;; ARGS is ignored (defun compile-lambda-inline (fun args #!optional pushed-args-already return-follows name) (setq fun (compiler-macroexpand fun)) (when (>= (fluid-set inline-depth (1+ (fluid inline-depth))) max-inline-depth) (fluid-set inline-depth 0) (compiler-error "can't inline more than %d nested functions" max-inline-depth)) (let* ((lambda-list (nth 1 fun)) (body (nthcdr 2 fun)) (out (push-inline-args lambda-list args pushed-args-already test-variable-bind)) (args-left (car out)) (bind-stack (cdr out))) (call-with-frame (lambda () ;; Set up the body for compiling, skip any interactive form or ;; doc string (while (and (consp body) (or (stringp (car body)) (and (consp (car body)) (eq (car (car body)) 'interactive)))) (setq body (cdr body))) ;; Now we have a list of things to bind to, in the same order ;; as the stack of evaluated arguments. The list has items ;; SYMBOL, (SYMBOL . ARGS-TO-BIND), or (SYMBOL . nil) (if bind-stack (progn (emit-insn '(init-bind)) (increment-b-stack) (pop-inline-args bind-stack args-left (lambda (x) (note-binding x) (emit-binding x))) (call-with-lambda-record name lambda-list 0 (lambda () (fix-label (lambda-label (current-lambda))) (set-lambda-inlined (current-lambda) t) (compile-body body return-follows))) (emit-insn '(unbind)) (decrement-b-stack)) ;; Nothing to bind to. Just pop the evaluated args and ;; evaluate the body (while (> args-left 0) (emit-insn '(pop)) (decrement-stack) (setq args-left (1- args-left))) (call-with-lambda-record name lambda-list 0 (lambda () (fix-label (lambda-label (current-lambda))) (set-lambda-inlined (current-lambda) t) (compile-body body return-follows)))))) (fluid-set inline-depth (1- (fluid inline-depth))))) (define (pop-between top bottom) (or (and (>= top bottom) (>= bottom 0)) (break) (error "Invalid stack pointers: %d, %d" top bottom)) (when (/= top bottom) (if (= bottom 0) (emit-insn '(pop-all)) (do ((sp top (1- sp))) ((= sp bottom)) (emit-insn '(pop)))))) (define (unbind-between top bottom) (cond ((= bottom -1) (emit-insn '(unbindall-0))) ((= bottom 0) (unless (<= top bottom) (emit-insn '(unbindall)))) (t (do ((bp top (1- bp))) ((<= bp bottom)) (emit-insn '(unbind)))))) (defun compile-tail-call (lambda-record args) (let* ((out (push-inline-args (lambda-args lambda-record) args nil test-variable-ref)) (args-left (car out)) (bind-stack (cdr out))) (call-with-frame (lambda () (if (catch 'foo (mapc (lambda (var) (when (binding-enclosed-p var) (throw 'foo t))) (get-lambda-vars (lambda-args lambda-record))) nil) ;; some of the parameter bindings may have been captured, ;; so rebind all of them (progn (unbind-between (fluid current-b-stack) ;; the 1- is so that the frame of ;; the function itself is also removed (1- (lambda-bp lambda-record))) (emit-insn '(init-bind)) (pop-inline-args bind-stack args-left emit-binding)) ;; none of the bindings are captured, so just modify them (pop-inline-args bind-stack args-left emit-varset) (unbind-between (fluid current-b-stack) (lambda-bp lambda-record))) ;; force the stack pointer to what it should be (pop-between (fluid current-stack) (lambda-sp lambda-record)) (emit-insn `(jmp ,(lambda-label lambda-record)))))))) librep-0.90.2/lisp/rep/vm/compiler/bindings.jl0000644000175200017520000002473311245011153020204 0ustar chrischris#| bindings.jl -- handling variable bindings $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.vm.compiler.bindings (export lex-bindings spec-bindings lexically-pure unsafe-for-call/cc call-with-frame spec-bound-p has-local-binding-p tag-binding binding-tagged-p note-binding note-bindings emit-binding emit-varset emit-varref note-binding-modified binding-modified-p binding-enclosed-p note-binding-referenced binding-referenced-p note-function-call-made binding-tail-call-only-p note-closure-made allocate-bindings) (open rep rep.vm.compiler.utils rep.vm.compiler.lap rep.vm.compiler.basic) (define spec-bindings (make-fluid '())) ;list of bound variables (define lex-bindings (make-fluid '())) ;alist of bound variables (define lexically-pure (make-fluid t)) ;any dynamic state? (define unsafe-for-call/cc (make-fluid nil)) (define (spec-bound-p var) (or (memq var (fluid defvars)) (special-variable-p var) (memq var (fluid spec-bindings)))) (define (lexical-binding var) (assq var (fluid lex-bindings))) (define (lexically-bound-p var) (let ((cell (lexical-binding var))) (and cell (not (cell-tagged-p 'no-location cell))))) (define (has-local-binding-p var) (or (memq var (fluid spec-bindings)) (lexical-binding var))) (define (cell-tagged-p tag cell) (memq tag (cdr cell))) (define (tag-cell tag cell) (unless (cell-tagged-p tag cell) (rplacd cell (cons tag (cdr cell))))) ;; note that the outermost binding of symbol VAR has state TAG (define (tag-binding var tag) (let ((cell (lexical-binding var))) (when cell (tag-cell tag cell)))) ;; note that the outermost binding of symbol VAR has state TAG (define (untag-binding var tag) (let ((cell (lexical-binding var))) (when cell (when (cell-tagged-p tag cell) (rplacd cell (delq tag (cdr cell))))))) ;; return t if outermost binding of symbol VAR has state TAG (define (binding-tagged-p var tag) (let ((cell (lexical-binding var))) (and cell (cell-tagged-p tag cell)))) ;; install a new binding contour, such that THUNK can add any bindings ;; (lexical and special), then when THUNK exits, the bindings are removed (define (call-with-frame thunk) (let ((old-d (length (fluid lex-bindings)))) (let-fluids ((spec-bindings (fluid spec-bindings)) (lexically-pure (fluid lexically-pure))) (prog1 (thunk) ;; check for unused variables (do ((new-d (length (fluid lex-bindings)) (1- new-d)) (new (fluid lex-bindings) (cdr new))) ((= new-d old-d) (fluid-set lex-bindings new)) (unless (or (cell-tagged-p 'referenced (car new)) (cell-tagged-p 'no-location (car new)) (cell-tagged-p 'maybe-unused (car new))) (compiler-warning 'unused "unused variable `%s'" (caar new)))))))) ;; note that symbol VAR has been bound (define (note-binding var #!optional without-location) (if (spec-bound-p var) (progn ;; specially bound (dynamic scope) (fluid-set spec-bindings (cons var (fluid spec-bindings))) (fluid-set lexically-pure nil)) ;; assume it's lexically bound otherwise (fluid-set lex-bindings (cons (list var) (fluid lex-bindings))) (when without-location (tag-binding var 'no-location))) ;; XXX handled by `modified' tag? ; (when (eq var (fluid lambda-name)) ; (fluid-set lambda-name nil)) ) (defmacro note-bindings (vars) (list 'mapc 'note-binding vars)) ;; note that the outermost binding of VAR has been modified (define (note-binding-modified var) (let ((cell (lexical-binding var))) (when cell (tag-cell 'modified cell) (when (cell-tagged-p 'across-funcall cell) (tag-cell 'exposed cell))))) (define (binding-modified-p var) (binding-tagged-p var 'modified)) (define (binding-enclosed-p var) (binding-tagged-p var 'enclosed)) (define (note-binding-referenced var #!optional for-tail-call) (tag-binding var 'referenced) (unless for-tail-call (tag-binding var 'not-tail-call-only))) (define (binding-referenced-p var) (binding-tagged-p var 'referenced)) ;; if a function call is made, it could be to call/cc (define (note-function-call-made) (mapc (lambda (cell) (tag-cell 'across-funcall cell)) (fluid lex-bindings))) (define (binding-tail-call-only-p var) (not (binding-tagged-p var 'not-tail-call-only))) ;; note that all current lexical bindings have been enclosed (define (note-closure-made) (mapc (lambda (cell) (tag-cell 'enclosed cell)) (fluid lex-bindings))) (define (emit-binding var) (if (spec-bound-p var) (progn (emit-insn `(push ,var)) (increment-stack) (emit-insn '(spec-bind)) (decrement-stack)) (emit-insn `(lex-bind ,var ,(fluid lex-bindings))))) (define (emit-varset sym) (test-variable-ref sym) (cond ((spec-bound-p sym) (emit-insn `(push ,sym)) (increment-stack) (emit-insn '(%set)) (decrement-stack)) ((lexically-bound-p sym) ;; The lexical address is known. Use it to avoid scanning (emit-insn `(lex-set ,sym ,(fluid lex-bindings)))) (t ;; No lexical binding, but not special either. Just ;; update the global value (emit-insn `(setg ,sym))))) (define (emit-varref form #!optional in-tail-slot) (cond ((spec-bound-p form) ;; Specially bound (emit-insn `(push ,form)) (increment-stack) (emit-insn '(ref)) (decrement-stack)) ((lexically-bound-p form) ;; We know the lexical address, so use it (emit-insn `(lex-ref ,form ,(fluid lex-bindings))) (note-binding-referenced form in-tail-slot)) (t ;; It's not bound, so just update the global value (emit-insn `(refg ,form))))) ;; allocation of bindings, either on stack or in heap (define (heap-binding-p cell) (or (cell-tagged-p 'captured cell) (and (not (fluid unsafe-for-call/cc)) (cell-tagged-p 'exposed cell)) ;; used to tag bindings unconditionally on the heap (cell-tagged-p 'heap-allocated cell))) ;; heap addresses count up from the _most_ recent binding (define (heap-address var bindings) (let loop ((rest bindings) (i 0)) (cond ((null rest) (error "No heap address for %s" var)) ((or (not (heap-binding-p (car rest))) (cell-tagged-p 'no-location (car rest))) (loop (cdr rest) i)) ((eq (caar rest) var) i) (t (loop (cdr rest) (1+ i)))))) ;; slot addresses count up from the _least_ recent binding (define (slot-address var bindings base) (let loop ((rest bindings)) (cond ((eq rest base) (error "No slot address for %s, %s" var bindings)) ((eq (caar rest) var) (let loop-2 ((rest (cdr rest)) (i 0)) (cond ((eq rest base) i) ((or (heap-binding-p (car rest)) (cell-tagged-p 'no-location (car rest))) (loop-2 (cdr rest) i)) (t (loop-2 (cdr rest) (1+ i)))))) (t (loop (cdr rest)))))) (define (identify-captured-bindings asm lex-env) (mapc (lambda (insn) (case (car insn) ((lex-ref lex-set) (let ((cell (assq (nth 1 insn) lex-env))) (when cell (tag-cell 'captured cell)))) ((push-bytecode) (identify-captured-bindings (nth 1 insn) (nth 2 insn))))) (assembly-code asm))) ;; Extra pass over the output pseudo-assembly code; converts ;; pseudo-instructions accessing lexical bindings into real ;; instructions accessing either the heap or the slot registers (define (allocate-bindings-1 asm base-env) (let ((max-slot 0)) (let loop ((rest (assembly-code asm))) (when rest (case (caar rest) ((lex-bind lex-ref lex-set) (let* ((var (nth 1 (car rest))) (bindings (nth 2 (car rest))) (cell (assq var bindings))) (if (heap-binding-p cell) (rplaca rest (case (caar rest) ((lex-bind) (list 'bind)) ((lex-ref) (list 'refn (heap-address var bindings))) ((lex-set) (list 'setn (heap-address var bindings))))) (let ((slot (slot-address var bindings base-env))) (setq max-slot (max max-slot (1+ slot))) (rplaca rest (case (caar rest) ((lex-bind lex-set) (list 'slot-set slot)) ((lex-ref) (list 'slot-ref slot)))))))) ((push-bytecode) (let ((asm (nth 1 (car rest))) (env (nth 2 (car rest))) (doc (nth 3 (car rest))) (interactive (nth 4 (car rest)))) (allocate-bindings-1 asm env) (rplaca rest (list 'push (assemble-assembly-to-subr asm doc interactive)))))) (loop (cdr rest)))) (assembly-slots-set asm max-slot) asm)) (define (allocate-bindings asm) (identify-captured-bindings asm (fluid lex-bindings)) (allocate-bindings-1 asm (fluid lex-bindings))) ;; declarations ;; (declare (bound VARIABLE)) (define (declare-bound form) (let loop ((vars (cdr form))) (when vars (note-binding (car vars) t) (loop (cdr vars))))) (put 'bound 'compiler-decl-fun declare-bound) ;; (declare (special VARIABLE)) (define (declare-special form) (let loop ((vars (cdr form))) (when vars (fluid-set spec-bindings (cons (car vars) (fluid spec-bindings))) (loop (cdr vars))))) (put 'special 'compiler-decl-fun declare-special) ;; (declare (heap-allocated VARS...)) (define (declare-heap-allocated form) (let loop ((vars (cdr form))) (when vars (tag-binding (car vars) 'heap-allocated) (loop (cdr vars))))) (put 'heap-allocated 'compiler-decl-fun declare-heap-allocated) (define (declare-unused form) (let loop ((vars (cdr form))) (when vars (tag-binding (car vars) 'maybe-unused) (loop (cdr vars))))) (put 'unused 'compiler-decl-fun declare-unused) (define (declare-unsafe-for-call/cc) (fluid-set unsafe-for-call/cc t)) (put 'unsafe-for-call/cc 'compiler-decl-fun declare-unsafe-for-call/cc)) librep-0.90.2/lisp/rep/vm/compiler/basic.jl0000644000175200017520000003421511245011153017464 0ustar chrischris#| basic.jl -- basic compilation $Id$ Copyright (C) 2000 John Harper This file is part of librep. librep is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. librep is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with librep; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (declare (unsafe-for-call/cc)) (define-structure rep.vm.compiler.basic (export current-file current-fun current-form lambda-records lambda-name lambda-args lambda-depth lambda-bindings lambda-bp lambda-sp lambda-label lambda-stack lambda-inlined set-lambda-inlined current-lambda call-with-lambda-record assembly-code assembly-code-set assembly-slots assembly-slots-set compile-constant compile-form-1 compile-body compile-lambda compile-lambda-constant compile-form assemble-assembly-to-form assemble-assembly-to-subr) (open rep rep.lang.doc rep.data.records rep.vm.compiler.utils rep.vm.compiler.bindings rep.vm.compiler.modules rep.vm.compiler.src rep.vm.compiler.inline rep.vm.compiler.lap rep.vm.peephole rep.vm.assembler) (defvar *compiler-write-docs* nil "When t all doc-strings are appended to the doc file and replaced with their position in that file.") (defvar *compiler-no-low-level-optimisations* nil) (defvar *compiler-debug* nil) (define current-file (make-fluid)) ;the file being compiled (define current-fun (make-fluid)) ;the function being compiled (define current-form (make-fluid)) ;the current cons-like form (define-record-type :assembly (make-assembly code max-stack max-b-stack slots) assemblyp (code assembly-code assembly-code-set) (max-stack assembly-max-stack assembly-max-stack-set) (max-b-stack assembly-max-b-stack assembly-max-b-stack-set) (slots assembly-slots assembly-slots-set)) (define-record-type :lambda-record (make-lambda-record name args depth sp bp label) lambda-record-p (name lambda-name) ;name of the lambda exp or () (args lambda-args) ;arg spec of the lambda (depth lambda-depth) ;depth of physical bytecode (sp lambda-sp) ;value of current-stack at top (bp lambda-bp) ;value of current-b-stack at top (label lambda-label) ;label for code (after binding init) ;; t when inlined (from a letrec) (inlined lambda-inlined set-lambda-inlined)) ;; list of lambda records (define lambda-stack (make-fluid)) ;;; lambda management (define (find-lambda name) (let loop ((rest (fluid lambda-stack))) (cond ((null rest) nil) ((eq (lambda-name (car rest)) name) (car rest)) (t (loop (cdr rest)))))) (define (call-with-lambda-record name args depth-delta thunk) (let* ((label (make-label)) (depth (if (fluid lambda-stack) (+ (lambda-depth (current-lambda)) depth-delta) 0)) (lr (make-lambda-record name args depth (fluid current-stack) (fluid current-b-stack) label))) (let-fluids ((lambda-stack (cons lr (fluid lambda-stack)))) (thunk)))) (define (current-lambda) (or (car (fluid lambda-stack)) (error "No current lambda!"))) ;;; driver function ;; stop macroexpanding if we come across a function with a special handler (defun macroexpand-pred (in out) (or (eq in out) (and (variable-ref-p (car out)) (get-procedure-handler (car out) 'compiler-handler-property)))) (define (compile-constant value) (emit-insn `(push ,value)) (increment-stack)) (define (inlinable-call-p fun return-follows) (let ((tem (find-lambda fun))) (and tem (or (lambda-inlined tem) (and (fluid lexically-pure) return-follows (not (binding-modified-p fun)))) (= (lambda-depth tem) (lambda-depth (current-lambda))) (lambda-label tem)))) ;; Compile one form so that its value ends up on the stack when interpreted (defun compile-form-1 (form #!key return-follows in-tail-slot) (cond ((eq form '()) (emit-insn '(push ())) (increment-stack)) ((eq form t) (emit-insn '(push t)) (increment-stack)) ((symbolp form) ;; A variable reference (let (val) (test-variable-ref form) (cond ((keywordp form) (compile-constant form)) ((setq val (assq form (fluid const-env))) ;; A constant from this file (compile-constant (cdr val))) ((compiler-binding-immutable-p form) ;; A known constant (compile-constant (compiler-symbol-value form))) (t ;; Not a constant (emit-varref form in-tail-slot) (increment-stack))))) ((consp form) (let-fluids ((current-form form)) (let ((new (source-code-transform form))) (if (consp new) (setq form new) (compile-form-1 new) (setq form nil))) (unless (null form) ;; A subroutine application of some sort (let (fun) (cond ;; Check if there's a special handler for this function ((and (variable-ref-p (car form)) (setq fun (get-procedure-handler (car form) 'compiler-handler-property))) (fun form return-follows)) (t ;; Expand macros (test-function-call (car form) (length (cdr form))) (if (not (eq (setq fun (compiler-macroexpand form macroexpand-pred)) form)) ;; The macro did something, so start again (compile-form-1 fun #:return-follows return-follows) ;; No special handler, so do it ourselves (setq fun (car form)) (cond ;; XXX assumes usual rep binding of `lambda' ((and (consp fun) (eq (car fun) 'lambda)) ;; An inline lambda expression (compile-lambda-inline (car form) (cdr form) nil return-follows)) ;; Assume a normal function call ((inlinable-call-p fun return-follows) ;; an inlinable tail call (note-binding-referenced fun t) (compile-tail-call (find-lambda fun) (cdr form)) ;; fake it, the next caller will pop the (non-existant) ;; return value (increment-stack)) ((and (symbolp fun) (cdr (assq fun (fluid inline-env))) (not (find-lambda fun))) ;; A call to a function that should be open-coded (compile-lambda-inline (cdr (assq fun (fluid inline-env))) (cdr form) nil return-follows fun)) (t (compile-form-1 fun #:in-tail-slot (inlinable-call-p fun return-follows)) (setq form (cdr form)) (let ((i 0)) (while (consp form) (compile-form-1 (car form)) (setq i (1+ i) form (cdr form))) (emit-insn `(call ,i)) (note-function-call-made) (decrement-stack i))))))))))) (t ;; Not a variable reference or a function call; so what is it? (compile-constant form)))) ;; Compile a list of forms, the last form's evaluated value is left on ;; the stack. If the list is empty nil is pushed. (defun compile-body (body #!optional return-follows name) (if (null body) (progn (emit-insn '(push ())) (increment-stack)) (while (consp body) (if (and (null (cdr body)) (constant-function-p (car body)) name) ;; handle named lambdas specially so we track name of current fun (compile-lambda-constant (constant-function-value (car body)) name) (compile-form-1 (car body) #:return-follows (if (cdr body) nil return-follows))) (when (cdr body) (emit-insn '(pop)) (decrement-stack)) (setq body (cdr body))))) ;;; creating assembly code (define (call-with-initial-env thunk) (let-fluids ((current-stack 0) (max-stack 0) (current-b-stack 0) (max-b-stack 0) (intermediate-code '()) (lexically-pure t)) (thunk))) (define (get-assembly) (let ((asm (make-assembly (nreverse (fluid intermediate-code)) (fluid max-stack) (fluid max-b-stack) 0))) asm)) ;; returns (ASM MAX-STACK MAX-B-STACK) (define (compile-form-to-asm form #!optional start-label) (call-with-initial-env (lambda () ;; Do the high-level compilation (when start-label (fix-label start-label)) (compile-form-1 form #:return-follows t) (emit-insn '(return)) (let ((asm (get-assembly))) (allocate-bindings asm) asm)))) (defun compile-lambda-spec (in) (let loop ((rest in) (state 'required) (vars '())) (cond ((null rest) ;; emit the bindings now (do ((rest vars (cdr rest))) ((null rest)) (note-binding (car rest)) (emit-binding (car rest)) (decrement-stack))) ((symbolp rest) (test-variable-bind rest) (emit-insn '(rest-arg)) (increment-stack) (loop '() nil (cons rest vars))) (t (case (car rest) ((#!optional) (loop (cdr rest) 'optional vars)) ((#!key) (loop (cdr rest) 'key vars)) ((#!rest) (loop (cdr rest) 'rest vars)) ((&optional) (compiler-deprecated '&optional "&optional in lambda list") (loop (cdr rest) 'optional vars)) ((&rest) (compiler-deprecated '&rest "&rest in lambda list") (loop (cdr rest) 'rest vars)) (t (let ((var (or (caar rest) (car rest))) (default (cdar rest)) (pushed 0)) (test-variable-bind var) (when (eq state 'key) (compile-constant (make-keyword var)) (setq pushed (1+ pushed))) (emit-insn (case state ((required) '(required-arg)) ((optional) (if default '(optional-arg*) '(optional-arg))) ((key) (if default '(keyword-arg*) '(keyword-arg))) ((rest) '(rest-arg)))) (if (and (memq state '(optional key)) default) (progn (increment-stack (- 2 pushed)) (let ((label (make-label))) (emit-insn `(jt ,label)) (decrement-stack 2) (compile-form-1 (car default)) (fix-label label))) (decrement-stack pushed) (increment-stack)) (loop (cdr rest) state (cons var vars))))))))) ;; From LST, `(lambda (ARGS) BODY ...)' returns an assembly code object (defun compile-lambda-to-asm (lst #!optional name) (let ((args (nth 1 lst)) (body (nthcdr 2 lst))) (call-with-initial-env (lambda () (call-with-lambda-record name args +1 (lambda () (call-with-frame (lambda () (compile-lambda-spec args) (fix-label (lambda-label (current-lambda))) (compile-body body t) (emit-insn '(return)) (get-assembly))))))))) (define (optimize-assembly asm) (when *compiler-debug* (format standard-error "lap-0 code: %S\n\n" (assembly-code asm))) ;; Unless disabled, run the peephole optimiser (unless *compiler-no-low-level-optimisations* (let ((tem (peephole-optimizer (assembly-code asm)))) (assembly-code-set asm (car tem)) (assembly-max-stack-set asm (+ (assembly-max-stack asm) (cdr tem))))) (when *compiler-debug* (format standard-error "lap-1 code: %S\n\n" (assembly-code asm)))) (define (assemble-assembly-to-form asm) (optimize-assembly asm) (let ((object-code (assemble (assembly-code asm)))) ;(CODE . CONSTS) (list 'run-byte-code (car object-code) (cdr object-code) (+ (assembly-max-stack asm) (ash (assembly-max-b-stack asm) 10) (ash (assembly-slots asm) 20))))) (define (assemble-assembly-to-subr asm #!optional doc interactive) (optimize-assembly asm) (let ((object-code (assemble (assembly-code asm)))) ;(CODE . CONSTS) (make-byte-code-subr (car object-code) (cdr object-code) (+ (assembly-max-stack asm) (ash (assembly-max-b-stack asm) 10) (ash (assembly-slots asm) 20)) (and (not *compiler-write-docs*) doc) interactive))) (define (compile-form form) "Compile the Lisp form FORM into a byte code form." (call-with-lambda-record nil '() +1 (lambda () (assemble-assembly-to-form (compile-form-to-asm form (lambda-label (current-lambda))))))) ;;; compiling lambdas ;; From LST, `(lambda (ARGS) [DOC-STRING] BODY ...)' returns a byte-code ;; vector (defun compile-lambda (lst #!optional name) (let ((args (nth 1 lst)) (body (nthcdr 2 lst)) doc interactive) (when (stringp (car body)) (setq doc (car body)) (setq body (cdr body))) (when (eq (car (car body)) 'interactive) ;; If we have (interactive), set the interactive spec to t ;; so that it's not ignored (setq interactive (or (car (cdr (car body))) t) body (cdr body)) ;; See if it might be a good idea to compile the interactive decl (when (consp interactive) (setq interactive (compile-form interactive)))) (when (and *compiler-write-docs* doc name) (add-documentation name (fluid current-module) doc) (add-documentation-params name (fluid current-module) args)) (let ((asm (compile-lambda-to-asm `(lambda ,args ,@body) name))) (allocate-bindings asm) (assemble-assembly-to-subr asm doc interactive)))) (defun compile-lambda-constant (lst #!optional name) (let ((args (nth 1 lst)) (body (nthcdr 2 lst)) doc interactive) (when (stringp (car body)) (setq doc (car body)) (setq body (cdr body))) (when (eq (car (car body)) 'interactive) ;; If we have (interactive), set the interactive spec to t ;; so that it's not ignored (setq interactive (or (car (cdr (car body))) t) body (cdr body)) ;; See if it might be a good idea to compile the interactive decl (when (consp interactive) (setq interactive (compile-form interactive)))) (when (and *compiler-write-docs* doc name) (add-documentation name (fluid current-module) doc) (add-documentation-params name (fluid current-module) args)) ;; push a pseudo instruction. All details of the bindings may ;; not yet be known. So allocate-bindings function will recursively ;; call itself for pushed bytecode (emit-insn `(push-bytecode ,(compile-lambda-to-asm `(lambda ,args ,@body) name) ,(fluid lex-bindings) ,doc ,interactive)) (emit-insn '(enclose)) (increment-stack) (note-closure-made)))) librep-0.90.2/lisp/rep/io/file-handlers/tilde.jl0000644000175200017520000000741711245011153020400 0ustar chrischris#| tilde.jl -- File handler for tilde expansion $Id$ Copyright (C) 1998 John Harper This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.io.file-handlers.tilde () (open rep rep.regexp rep.system rep.io.files rep.io.file-handlers) (defun tilde-expand (file-name) (if (string-looking-at "~([^/]*)/?" file-name) (concat (if (/= (match-start 1) (match-end 1)) ;; ~USER/... (user-home-directory (substring file-name (match-start 1) (match-end 1))) ;; ~/.. (user-home-directory)) (substring file-name (match-end))) file-name)) (defun tilde-file-handler (op #!rest args) (cond ((eq op 'file-name-absolute-p)) ;~FOO always absolute ((eq op 'expand-file-name) ;; Slightly tricky. It's necessary to remove the tilde, call ;; expand-file-name, then reapply the tilde. This is to ensure ;; that things like "~/foo/../bar" expand to "~/bar" (let ((file-name (car args))) (if (string-looking-at "(~[^/]*/)." file-name) (concat (substring file-name (match-start 1) (match-end 1)) (expand-file-name (substring file-name (match-end 1)) ".")) file-name))) ((memq op '(file-name-nondirectory file-name-directory file-name-as-directory directory-file-name)) ;; Functions of a single file name that we leave alone. By re-calling ;; OP the standard action will occur since this handler is now ;; blocked for OP. (apply (symbol-value op) args)) ((memq op '(local-file-name canonical-file-name open-file write-buffer-contents read-file-contents insert-file-contents delete-file delete-directory make-directory file-exists-p file-regular-p file-readable-p file-writable-p file-directory-p file-symlink-p file-owner-p file-nlinks file-size file-modes file-modes-as-string set-file-modes file-modtime directory-files read-symlink make-symlink)) ;; All functions which only have a single file name (their first ;; argument). Expand the tilde expression then re-call OP. (apply (symbol-value op) (tilde-expand (car args)) (cdr args))) ((eq op 'copy-file-to-local-fs) (apply copy-file (tilde-expand (car args)) (cdr args))) ((eq op 'copy-file-from-local-fs) ;; file to expand is second argument (copy-file (car args) (tilde-expand (cadr args)))) ((eq op 'copy-file) ;; both names need expanding (copy-file (tilde-expand (car args)) (tilde-expand (cadr args)))) (t ;; Anything else shouldn't have happened (error "Can't expand ~ in %s" (cons op args))))) (define-file-handler 'tilde-file-handler tilde-file-handler) ;; Runtime initialisation (progn ;; Install the handler (setq file-handler-alist (cons '("^~" . tilde-file-handler) file-handler-alist)) ;; Fix the initial default-directory; replacing $HOME by ~ if possible (when (string-looking-at (concat (quote-regexp (canonical-file-name (user-home-directory))) "(/(.+))?$") (canonical-file-name default-directory)) (setq-default default-directory (expand-last-match "~/\\2"))))) librep-0.90.2/lisp/rep/io/file-handlers/tar.jl0000644000175200017520000004207011245011153020057 0ustar chrischris;; tar-file-handler.jl -- pretend that tar files are (read-only) directories ;; Copyright (C) 1999 John Harper ;; $Id: tar.jl,v 1.18 2001/03/22 21:43:45 jsh Exp $ ;; This file is part of librep. ;; librep is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; librep is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with librep; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;; Commentary: ;; This allows tar files to be handled as directories, append `#tar' to ;; the end of the file name to mark that the tar file should be treated ;; in this way. By default it knows how to deal with .tar, .tar.gz, ;; .tgz, .tar.Z, .taz, .tar.bz2 suffixes ;; This is pretty slow when reading more than one file, since each ;; file is uncompressed separately (i.e. uncompressing the entire tar ;; file each time. It would be better to untar the entire contents ;; somewhere, and then clean up later..) (declare (unsafe-for-call/cc)) (define-structure rep.io.file-handlers.tar () (open rep rep.io.files rep.io.file-handlers rep.io.processes rep.regexp rep.system rep.util.date) ;; Warning! ;; Before using any more tar options, make sure that the `emulate-gnu-tar' ;; script can support them. ;; configuration (defvar tarfh-gnu-tar-program "tar" "Location of GNU tar program.") (defvar tarfh-alternative-gnu-tar-programs (list "gnutar" "gtar" (expand-file-name "emulate-gnu-tar" exec-directory))) ;; Initialised to the current tar version (defvar tarfh-gnu-tar-version nil) ;; alist mapping file suffixes to GNU tar compression options (defvar tarfh-compression-modes '(("\\.t?gz$" . "--gzip") ("\\.(taz|Z)$" . "--compress") ("\\.bz2" . "--bzip2") ("\\.xz" . "--xz") ("\\.(lz|lzma)$" . "--lzma"))) ;; Hairy regexp matching tar `--list --verbose' output (defvar tarfh-list-regexp (concat "([a-zA-Z-]+)\\s+(\\w+)/([a-zA-Z0-9_,]+)\\s+(\\d+)\\s+" ;; GNU tar output "([0-9-]+\\s+[0-9:]+" ;; solaris tar output "|\\w\\w\\w\\s+\\d+\\s+\\d+:\\d+\\s+\\d+)" "\\s+([^\n]+)")) ;; Map list file types to symbols (defvar tarfh-list-type-alist '((?- . file) (?d . directory) (?l . symlink) (?p . pipe) (?s . socket) (?b . device) (?c . device))) (defvar tarfh-max-cached-dirs 5 "Total number of tar listings to cache.") (defvar tarfh-largest-cached-file 1048576 "Size of the largest cachable tar file.") ;; Cached tar listings (define tarfh-dir-cache nil) ;; guards tarfh-created file handles (define tarfh-fh-guardian (make-guardian)) ;; Interface to tar program (defun tarfh-check-tar-program () (catch 'out (mapc (lambda (prog) (let* ((output (make-string-output-stream)) (process (make-process output))) (when (zerop (call-process process nil prog "--version")) (setq output (get-output-stream-string output)) (when (string-looking-at "(tar )?[(]?GNU tar[)]?\\s*(.*?)\\s*\n" output) (setq tarfh-gnu-tar-program prog) (setq tarfh-gnu-tar-version (expand-last-match "\\2")) (throw 'out t))))) (cons tarfh-gnu-tar-program tarfh-alternative-gnu-tar-programs)) (error "Can't find/execute GNU tar"))) (defun tarfh-call-tar (input-file output op tar-file #!rest args) ;; XXX handle non-local files by copying ;; XXX but then again, that's a bad idea in gaolled code.. (when (file-exists-p tar-file) (setq tar-file (local-file-name tar-file)) (unless tarfh-gnu-tar-version (tarfh-check-tar-program)) (let* ((process (make-process output)) (mode (cdr (assoc-regexp tar-file tarfh-compression-modes))) (all-args `(,op ,@(and mode (list mode)) "--file" ,tar-file ,@args))) (zerop (apply call-process process input-file tarfh-gnu-tar-program all-args))))) ;; extracting files (with caching) (define cached-file nil) ;name of file (define cached-dir nil) ;directory containing tar contents (defun tarfh-copy-out (tarfile file-name dest-file) (unless (and cached-file (file-name= cached-file tarfile)) ;; no cached copy.. (unless (> (file-size tarfile) tarfh-largest-cached-file) (empty-file-cache) (condition-case nil (let ((dir-name (concat (make-temp-name) "-rep-tarfh"))) (make-directory dir-name) (set-file-modes dir-name #o700) (tarfh-call-tar nil nil "--extract" tarfile "-C" dir-name) (setq cached-file tarfile) (setq cached-dir dir-name)) (file-error)))) (if (and cached-file (file-name= cached-file tarfile)) (copy-file (expand-file-name file-name cached-dir) dest-file) ;; still no cached copy, so read from the file (let ((file (open-file dest-file 'write))) (when file (unwind-protect (tarfh-call-tar nil file "--extract" tarfile "--to-stdout" file-name) (close-file file)))))) (defun empty-file-cache () (when cached-file ;; delete the old file in the background.. (system (format nil "nice rm -rf '%s' & >/dev/null 2>&1 number (substring string (match-start 4) (match-end 4)))) (modtime (substring string (match-start 5) (match-end 5))) (name (substring string (match-start 6) (match-end 6))) symlink file-name) (when (string-match " -> " name) (setq symlink (substring name (match-end))) (setq name (substring name 0 (match-start)))) (setq file-name (expand-file-name name "")) (vector name file-name size modtime (cdr (assq (aref mode-string 0) tarfh-list-type-alist)) nil mode-string user group symlink)) (error "can't parse tar file listing line (GNU or Solaris tar required): %s" (substring string point)))) (defun tarfh-file-get-modtime (file-struct) (when (stringp (aref file-struct tarfh-file-modtime)) (require 'date) (let ((date (parse-date (aref file-struct tarfh-file-modtime)))) (when date (aset file-struct tarfh-file-modtime (aref date date-vec-epoch-time))))) (aref file-struct tarfh-file-modtime)) (defun tarfh-file-get-modes (file-struct) (unless (aref file-struct tarfh-file-modes) (let* ((string (aref file-struct tarfh-file-modes-string)) (tuple-function (lambda (point tuple) (+ (ash (+ (if (/= (aref string point) ?-) 4 0) (if (/= (aref string (1+ point)) ?-) 2 0) (if (lower-case-p (aref string (+ point 2))) 1 0)) (* tuple 3)) (if (memq (aref string (+ point 2)) '(?s ?S ?t ?T)) (ash #o1000 tuple) 0))))) (aset file-struct tarfh-file-modes (+ (tuple-function 1 2) (tuple-function 4 1) (tuple-function 7 0))))) (aref file-struct tarfh-file-modes)) (defun tarfh-directory-files (tarfile dir) (let ((entry (tarfh-lookup-file tarfile dir)) re files tem) (when entry (setq dir (aref entry tarfh-file-name))) (setq dir (file-name-as-directory dir)) (setq re (concat (quote-regexp dir) "([^/]+)")) (mapc (lambda (e) (when (string-looking-at re (aref e tarfh-file-name)) (setq tem (expand-last-match "\\1")) (unless (member tem files) (setq files (cons tem files))))) (aref (car tarfh-dir-cache) tarfh-cache-entries)) files)) (defun tarfh-directory-exists-p (tarfile name) (catch 'out (let ((cache (tarfh-tarfile-cached-p tarfile))) (setq name (expand-file-name (file-name-as-directory name) "")) (when cache (mapc (lambda (entry) (when (string-head-eq (aref entry tarfh-file-name) name) (throw 'out t))) (aref cache tarfh-cache-entries)) nil)))) (defun tarfh-file-owner-p (file) ;; XXX maybe just return t always? (string= (user-login-name) (aref file tarfh-file-user))) (defun tarfh-tarfile-cached-p (tarfile) (setq tarfile (canonical-file-name tarfile)) (catch 'exit (mapc (lambda (dir-entry) (when (string= tarfile (aref dir-entry tarfh-cache-tarfile)) (throw 'exit dir-entry))) tarfh-dir-cache))) (defun tarfh-get-file (tarfile filename) (let (entry) (setq tarfile (canonical-file-name tarfile)) (setq filename (expand-file-name filename "")) (setq entry (tarfh-tarfile-cached-p tarfile)) (if (not (and entry (equal (aref entry tarfh-cache-modtime) (file-modtime tarfile)))) (progn ;; Cache TARFILE (when entry (setq tarfh-dir-cache (delq entry tarfh-dir-cache)) (setq entry nil)) (when (>= (length tarfh-dir-cache) tarfh-max-cached-dirs) ;; delete the least-recently-used entry (setcdr (nthcdr (1- (length tarfh-dir-cache)) tarfh-dir-cache) nil)) ;; add the new (empty) entry for the directory to be read. (setq entry (vector tarfile (file-modtime tarfile) nil)) (setq tarfh-dir-cache (cons entry tarfh-dir-cache)) (tarfh-call-tar nil (lambda (o) (tarfh-output-function o entry)) "--list" tarfile "--verbose") (aset entry tarfh-cache-entries (nreverse (aref entry tarfh-cache-entries)))) ;; entry is still valid, move it to the front of the list (setq tarfh-dir-cache (cons entry (delq entry tarfh-dir-cache)))) ;; ENTRY now has the valid dircache directory structure (catch 'return (mapc (lambda (f) (when (string= (aref f tarfh-file-name) filename) (throw 'return f))) (aref entry tarfh-cache-entries))))) ;; similar to remote-ftp-get-file, but symbolic links are followed (defun tarfh-lookup-file (tarfile file) (let ((file-struct (tarfh-get-file tarfile file))) (while (and file-struct (eq (aref file-struct tarfh-file-type) 'symlink)) (let ((link (aref file-struct tarfh-file-symlink))) (setq file (expand-file-name link (file-name-directory file))) (setq file-struct (tarfh-get-file tarfile file)))) file-struct)) (defun tarfh-invalidate-tarfile (tarfile) (setq tarfile (canonical-file-name tarfile)) (let ((entry (tarfh-tarfile-cached-p tarfile))) (when entry (setq tarfh-dir-cache (delq entry tarfh-dir-cache))))) (defun tarfh-empty-cache () "Discard all cached TAR directory entries." (interactive) (setq tarfh-dir-cache nil)) (defun tarfh-after-gc () (let (fh) (while (setq fh (tarfh-fh-guardian)) (when (file-binding fh) (close-file fh))))) (add-hook 'after-gc-hook tarfh-after-gc) ;; file handler (defun tarfh-split-filename (name) (unless (string-match "#tar/?" name) (error "Can't find #tar in %s" name)) (cons (substring name 0 (match-start)) (substring name (match-end)))) (defun tar-file-handler (op #!rest args) (cond ((filep (car args)) ;; an open file handle (let ((split (tarfh-split-filename (file-binding (car args))))) (tarfh-handler (car split) (cdr split) op args))) ((eq op 'file-name-absolute-p) (file-name-absolute-p (car args))) ((eq op 'local-file-name) nil) ((eq op 'expand-file-name) (expand-file-name (car args) "")) ((memq op '(file-name-nondirectory file-name-directory file-name-as-directory directory-file-name)) (apply (symbol-value op) args)) ((memq op '(write-buffer-contents delete-file delete-directory make-directory set-file-modes make-symlink copy-file-from-local-fs copy-file)) (signal 'file-error (list "TAR files are read-only" op args))) ((memq op '(canonical-file-name open-file read-file-contents copy-file-to-local-fs insert-file-contents file-exists-p file-regular-p file-readable-p file-writable-p file-directory-p file-symlink-p file-owner-p file-nlinks file-size file-modes file-modes-as-string file-modtime directory-files read-symlink)) (let ((split (tarfh-split-filename (car args)))) (tarfh-handler (car split) (cdr split) op args))) (t (error "Unknown file op in TAR handler: %s %S" op args)))) (defun tarfh-handler (tarfile rel-file op args) (cond ((eq op 'canonical-file-name) ;; XXX implement this by resolving symlinks (car args)) ((filep (car args)) ;; Operations on file handles (cond ((memq op '(seek-file flush-file write-buffer-contents read-file-contents insert-file-contents)) ;; Just pass these through to the underlying file (apply (symbol-value op) (file-bound-stream (car args)) (cdr args))) ((eq op 'close-file) (let* ((file (car args)) (local-file (file-handler-data file))) (close-file (file-bound-stream file)) (delete-file local-file))) (t (error "Unsupported TAR op on file-handler: %s %s" op args)))) ((memq op '(copy-file write-buffer-contents copy-file-from-local-fs rename-file delete-file delete-directory make-directory set-file-modes)) (signal 'file-error (list "TAR fh is read-only" op args))) ((eq op 'directory-files) (tarfh-directory-files tarfile rel-file)) (t ;; All functions taking a single argument (let ((file (if (eq op 'file-symlink-p) (tarfh-get-file tarfile rel-file) (tarfh-lookup-file tarfile rel-file)))) (cond ((memq op '(read-file-contents insert-file-contents copy-file-to-local-fs)) ;; Need to get the file to the local fs (let ((local-name (if (eq op 'copy-file-to-local-fs) (nth 1 args) (make-temp-name)))) (or file (signal 'file-error (list "Unknown file:" (car args)))) (tarfh-copy-out tarfile (aref file tarfh-file-full-name) local-name) (unless (eq op 'copy-file-to-local-fs) (unwind-protect (funcall (symbol-value op) local-name) (delete-file local-name))) t)) ((eq op 'open-file) (let ((type (nth 1 args)) (local-file (make-temp-name)) local-fh) (when (memq type '(read append)) ;; Need to transfer the file initially (tarfh-copy-out tarfile (aref file tarfh-file-full-name) local-file)) ;; Open the local file (setq local-fh (make-file-from-stream (car args) (open-file local-file type) 'tar-file-handler)) (set-file-handler-data local-fh local-file) (tarfh-fh-guardian local-fh) local-fh)) ((eq op 'file-exists-p) (or file (tarfh-directory-exists-p tarfile rel-file))) ((eq op 'file-regular-p) (and file (eq (aref file tarfh-file-type) 'file))) ((eq op 'file-directory-p) (if file (eq (aref file tarfh-file-type) 'directory) (tarfh-directory-exists-p tarfile rel-file))) ((eq op 'file-symlink-p) (and file (eq (aref file tarfh-file-type) 'symlink))) ((eq op 'file-size) (and file (aref file tarfh-file-size))) ((eq op 'file-modes) (and file (tarfh-file-get-modes file))) ((eq op 'file-modes-as-string) (and file (aref file tarfh-file-modes-string))) ((eq op 'file-nlinks) 1) ((eq op 'file-modtime) (if file (tarfh-file-get-modtime file) (cons 0 0))) ((eq op 'file-owner-p) (and file (tarfh-file-owner-p file))) ((eq op 'file-readable-p) (and file (/= (logand (tarfh-file-get-modes file) (if (tarfh-file-owner-p file) #o400 #o004)) 0))) ((eq op 'file-writable-p) nil) ((eq op 'read-symlink) (and file (or (aref file tarfh-file-symlink) (signal 'file-error (list "File isn't a symlink:" (car args)))))) (t (error "Unsupported TAR op: %s %s" op args))))))) ;;;###autoload (setq file-handler-alist (cons '("#tar\\b" . tar-file-handler) file-handler-alist)) ;;;###autoload (autoload-file-handler 'tar-file-handler 'rep.io.file-handlers.tar) (define-file-handler 'tar-file-handler tar-file-handler)) librep-0.90.2/lisp/rep/io/file-handlers/remote.jl0000644000175200017520000000704411245011153020566 0ustar chrischris#| remote.jl -- Remote file access $Id$ Copyright (C) 1998 John Harper This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.io.file-handlers.remote () (open rep rep.io.files rep.io.file-handlers rep.io.file-handlers.remote.utils) ;;; Configuration ;; A symbol defines a backend type if its `remote-backend' property ;; is a function to call as (FUNCTION SPLIT-NAME-OR-NIL OP ARG-LIST) (defvar remote-auto-backend-alist nil "An alist of (HOST-REGEXP . BACKEND-TYPE) defining how remote files are accessed on specific hosts.") (defvar remote-default-backend 'ftp "Backend used for otherwise unspecified hosts.") ;;; Entry point (defun remote-file-handler (op #!rest args) (cond ((filep (car args)) ;; A previously opened file handle. The backend should have stashed ;; it's handler function in the first slot the file's handler-data ;; (a vector) (let ((split (remote-split-filename (file-binding (car args))))) (funcall (aref (file-handler-data (car args)) 0) split op args))) ((eq op 'file-name-absolute-p)) ;remote files are absolute? ((eq op 'local-file-name) ;; can't get a local file name nil) (t (let ;; Chop up the file name ((split (remote-split-filename (if (eq op 'copy-file-from-local-fs) ;; remote file is 2nd arg (nth 1 args) (car args))))) (cond ;; Handle all file name manipulations ;; XXX This isn't such a good idea since it presumes that remote ;; XXX systems use the same file naming conventions as locally. ((eq op 'expand-file-name) (remote-join-filename (car split) (nth 1 split) (expand-file-name (nth 2 split) "."))) ((eq op 'file-name-nondirectory) (file-name-nondirectory (nth 2 split))) ((eq op 'file-name-directory) (remote-join-filename (car split) (nth 1 split) (file-name-directory (nth 2 split)))) ((eq op 'file-name-as-directory) (remote-join-filename (car split) (nth 1 split) (if (string= (nth 2 split) "") "" (file-name-as-directory (nth 2 split))))) ((eq op 'directory-file-name) (remote-join-filename (car split) (nth 1 split) (directory-file-name (nth 2 split)))) (t ;; Anything else, pass off to a backend (let ((backend (get (or (cdr (assoc-regexp (nth 1 split) remote-auto-backend-alist t)) remote-default-backend) 'remote-backend))) (funcall (if (symbolp backend) (file-handler-ref backend) backend) split op args)))))))) (define-file-handler 'remote-file-handler remote-file-handler) ;;; Initialise handler ;;;###autoload (setq file-handler-alist (cons '("^/(([a-zA-Z0-9._-]+)@)?([a-zA-Z0-9._-]+):" . remote-file-handler) file-handler-alist)) ;;;###autoload (autoload-file-handler 'remote-file-handler 'rep.io.file-handlers.remote) ) librep-0.90.2/lisp/rep/io/file-handlers/remote/utils.jl0000644000175200017520000000503211245011153021721 0ustar chrischris#| remote-util.jl -- Remote file access common functions $Id$ Copyright (C) 1998 John Harper This file is part of Jade. Jade is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Jade is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |# (define-structure rep.io.file-handlers.remote.utils (export remote-get-user remote-split-filename remote-join-filename remote-register-file-handle) (open rep rep.system rep.regexp rep.io.files) (defvar remote-host-user-alist nil "Alist of (HOST-REGEXP . USER-NAME) matching host names to usernames. Only used when no username is given in a filename.") (defvar remote-default-user (user-login-name) "Default username to use for file-transfer when none is specified, either explicitly, or by the remote-ftp-host-user-alist variable.") ;; Remote filename syntax (defconst remote-file-regexp "^/(([a-zA-Z0-9._-]+)@)?([a-zA-Z0-9._-]+):") ;; guards remote file handles (closes them if necessary) (define remote-fh-guardian (make-guardian)) (defun remote-get-user (host) (or (cdr (assoc-regexp host remote-host-user-alist)) remote-default-user)) ;; Return (USER-OR-NIL HOST FILE) (defun remote-split-filename (filename) (unless (string-match remote-file-regexp filename) (error "Malformed remote file specification: %s" filename)) (let ((host (substring filename (match-start 3) (match-end 3))) (file (substring filename (match-end)))) (list (and (match-start 2) (substring filename (match-start 2) (match-end 2))) host file))) ;; Create a remote file name. USER may be nil (defun remote-join-filename (user host file) (concat ?/ (and user (concat user ?@)) host ?: file)) (defun remote-register-file-handle (fh) (remote-fh-guardian fh)) (defun remote-after-gc () (do ((fh (remote-fh-guardian) (remote-fh-guardian))) ((not fh)) (when (file-binding fh) (close-file fh)))) (add-hook 'after-gc-hook remote-after-gc)) librep-0.90.2/lisp/rep/io/file-handlers/remote/rep.jl0000644000175200017520000006645011245011153021362 0ustar chrischris;;;; remote-rep.jl -- Remote file access via the rep-remote program ;;; Copyright (C) 1999 John Harper ;;; $Id$ ;;; This file is part of librep. ;;; librep is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2, or (at your option) ;;; any later version. ;;; librep is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; You should have received a copy of the GNU General Public License ;;; along with librep; see the file COPYING. If not, write to ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (declare (unsafe-for-call/cc)) (define-structure rep.io.file-handlers.remote.rep (export remote-rep-add-passwd remote-rep-close-host remote-rep-close-all remote-rep-empty-cache) (open rep rep.regexp rep.system rep.io.processes rep.io.files rep.io.file-handlers rep.io.file-handlers.remote.utils) (define-structure-alias remote-rep rep.io.file-handlers.remote.rep) ;; Configuration ;; rsh doesn't ask for passwords when changing uids, ;; better to use ssh which does (defvar remote-rep-rsh-program "rsh") (defvar remote-rep-program "rep-remote") (defvar remote-rep-timeout 30) (defvar remote-rep-display-progress nil) (defvar remote-rep-max-sessions 5) (defvar remote-rep-echo-output nil) (define remote-rep-passwd-alist nil) (defvar remote-rep-dircache-expiry-time 60) (defvar remote-rep-dircache-max-dirs 5) (define remote-rep-sessions nil) (defconst remote-rep-signature "\002rep-remote; protocol (\\d+)\002") (defvar remote-rep-passwd-msgs "[Pp]assword: *" "Regular expression matching password prompt.") (defconst remote-rep-required-protocol 1) (define remote-rep-hex-map (let ((map (make-string 128 0)) i) (setq i ?0) (while (<= i ?9) (aset map i (- i ?0)) (setq i (1+ i))) (setq i ?a) (while (<= i ?f) (aset map i (+ (- i ?a) 10)) (aset map (+ i (- ?A ?a)) (aref map i)) (setq i (1+ i))) map)) ;; session structure (defconst remote-rep-host 0) (defconst remote-rep-user 1) (defconst remote-rep-process 2) (defconst remote-rep-status 3) ;success,failure,busy,nil,dying,timed-out (defconst remote-rep-callback 4) (defconst remote-rep-dircache 5) (defconst remote-rep-pending-output 6) (defconst remote-rep-login-data 7) ;PASSWD while logging in (defconst remote-rep-error 8) (defconst remote-rep-protocol 9) (defconst remote-rep-struct-size 10) (defmacro remote-rep-status-p (session stat) `(eq (aref ,session remote-rep-status) ,stat)) ;; Return an rep structure for HOST and USER, with a running rep session (defun remote-rep-open-host (host #!optional user) (unless user (setq user (remote-get-user host))) (catch 'foo (mapc (lambda (s) (when (and (string= (aref s remote-rep-host) host) (string= (aref s remote-rep-user) user)) ;; Move S to the head of the list (setq remote-rep-sessions (cons s (delq s remote-rep-sessions))) (throw 'foo s))) remote-rep-sessions) ;; Create a new session (let* ((session (make-vector remote-rep-struct-size))) (aset session remote-rep-host host) (aset session remote-rep-user user) (remote-rep-open-session session)))) (defun remote-rep-open-session (session) (let ((process (make-process (lambda (data) (remote-rep-output-filter session data)) remote-rep-sentinel nil remote-rep-rsh-program (list "-l" (aref session remote-rep-user) (aref session remote-rep-host) remote-rep-program)))) (when (and remote-rep-max-sessions (> (length remote-rep-sessions) remote-rep-max-sessions)) ;; Kill the session last used the earliest (remote-rep-close-session (last remote-rep-sessions))) (set-process-connection-type process 'pipe) (aset session remote-rep-process process) (aset session remote-rep-status 'busy) (or (start-process process) (error "Can't start rep-remote session")) (setq remote-rep-sessions (cons session remote-rep-sessions)) (condition-case data (remote-rep-connect session) (error (remote-rep-close-session session) (signal (car data) (cdr data)))) session)) (defun remote-rep-close-session (session) (when (and (aref session remote-rep-process) (process-in-use-p (aref session remote-rep-process))) (aset session remote-rep-status 'dying) (set-process-output-stream (aref session remote-rep-process) nil) (set-process-error-stream (aref session remote-rep-process) nil) (kill-process (aref session remote-rep-process)))) (defun remote-rep-close-host (host #!optional user) "Close the rep-remote subprocess connected to `USER@HOST'." (interactive "sHost:\nsUser:") (when (or (null user) (string= user "")) (setq user (remote-get-user host))) (catch 'foo (mapc (lambda (s) (when (and (string= (aref s remote-rep-host) host) (string= (aref s remote-rep-user) user)) (remote-rep-close-session s) (throw 'foo t))) remote-rep-sessions))) (defun remote-rep-close-all () "Close all running rep-remote subprocesses." (interactive) (mapc remote-rep-close-session remote-rep-sessions)) (defun remote-rep-get-session-by-process (process) (catch 'return (mapc (lambda (s) (and (eq (aref s remote-rep-process) process) (throw 'return s))) remote-rep-sessions))) ;; Communicating with the remote process (defun remote-rep-write (session fmt #!rest args) (when (remote-rep-status-p session 'dying) (error "rep-remote session is dying")) (apply format (aref session remote-rep-process) fmt args) (aset session remote-rep-status 'busy)) (defun remote-rep-send-int (session int) (remote-rep-write session "%08x" int)) (defun remote-rep-send-string (session string) (remote-rep-send-int session (length string)) (remote-rep-write session "%s" string)) (defun remote-rep-while (session status #!optional type) (when (and (not (eq status 'dying)) (remote-rep-status-p session 'dying)) (error "rep-remote session is dying")) (while (remote-rep-status-p session status) (when (and (process-running-p (aref session remote-rep-process)) (accept-process-output-1 (aref session remote-rep-process) remote-rep-timeout)) (aset session remote-rep-status 'timed-out) (error "rep-remote process timed out (%s)" (or type "unknown"))))) (defun remote-rep-command (session type #!optional output-fun #!rest args) (when remote-rep-display-progress (message (format nil "rep %c %s: " type args) t)) (remote-rep-while session 'busy type) (remote-rep-write session "%c%c" type (length args)) (mapc (lambda (a) (remote-rep-send-string session a)) args) (when output-fun (funcall output-fun session)) (remote-rep-while session 'busy type) (when remote-rep-display-progress (format t " %s" (aref session remote-rep-status))) (remote-rep-error-if-unsuccessful session type args)) ;; Return t if successful, else signal a file-error (defun remote-rep-error-if-unsuccessful (session #!optional type args) (or (eq (aref session remote-rep-status) 'success) (signal 'file-error (list (aref session remote-rep-error) type (format nil "%s@%s %s" (aref session remote-rep-user) (aref session remote-rep-host) args))))) (defun remote-rep-read-length (string point) (when (>= (length string) (+ point 8)) ;; unrolled eight-digit hex decoder (+ (aref remote-rep-hex-map (aref string (+ point 7))) (ash (aref remote-rep-hex-map (aref string (+ point 6))) 4) (ash (aref remote-rep-hex-map (aref string (+ point 5))) 8) (ash (aref remote-rep-hex-map (aref string (+ point 4))) 12) (ash (aref remote-rep-hex-map (aref string (+ point 3))) 16) (ash (aref remote-rep-hex-map (aref string (+ point 2))) 20) (ash (aref remote-rep-hex-map (aref string (+ point 1))) 24) (ash (aref remote-rep-hex-map (aref string point)) 28)))) ;; returns nil or STRING (defun remote-rep-read-string (string point) (let ((len (remote-rep-read-length string point))) (when (and len (>= (length string) (+ point 8 len))) (substring string (+ point 8) (+ point 8 len))))) (defun remote-rep-output-filter (session output) (when (aref session remote-rep-pending-output) (setq output (concat (aref session remote-rep-pending-output) output)) (aset session remote-rep-pending-output nil)) (when remote-rep-echo-output (let ((print-escape t)) (format (stderr-file) "rep output: %S\n" output))) (if (aref session remote-rep-callback) (funcall (aref session remote-rep-callback) session output 0) (let ((point 0)) (while (< point (length output)) (cond ((and (null (aref session remote-rep-protocol)) (string-match remote-rep-passwd-msgs output point)) ;; Send password (remote-rep-write session "%s\n" (let ((pass (remote-rep-get-passwd (aref session remote-rep-user) (aref session remote-rep-host)))) (unless pass (remote-rep-close-session session) (error "No valid password")) (aset session remote-rep-login-data pass) pass)) (setq point (length output))) ((string-match remote-rep-signature output point) (aset session remote-rep-protocol (string->number (expand-last-match "\\1"))) (setq point (match-end))) ((= (aref output point) ?\001) ;; success (aset session remote-rep-status 'success) (setq point (1+ point))) ((= (aref output point) ?\177) ;; failure, look for error message (let ((msg (remote-rep-read-string output (1+ point)))) (if msg (progn (aset session remote-rep-error msg) (aset session remote-rep-status 'failure) (setq point (+ point 9 (length msg)))) (aset session remote-rep-pending-output (substring output point)) (setq point (length output))))) (t ; (unless (string-looking-at "\\s*$" output point) ; (format standard-error "remote-rep: unhandled output %S\n" ; (substring output point))) (setq point (length output)))))))) (defun remote-rep-sentinel (process) (let ((session (remote-rep-get-session-by-process process))) (unless (process-in-use-p process) (aset session remote-rep-process nil) (aset session remote-rep-dircache nil) (aset session remote-rep-status nil) (aset session remote-rep-pending-output nil) (aset session remote-rep-callback nil) (setq remote-rep-sessions (delq session remote-rep-sessions))))) ;; Commands ;; SESSION has been started, wait for the connection to ;; succeed or fail (defun remote-rep-connect (session) (remote-rep-while session 'busy 'connect) (remote-rep-error-if-unsuccessful session "connect") (unless (>= (aref session remote-rep-protocol) remote-rep-required-protocol) (error "rep-remote program on %s is too old" (aref session remote-rep-host)))) (defun remote-rep-get (session remote-file local-file) (let ((remote-rep-get-fh (open-file local-file 'write)) (remote-rep-len nil)) (when remote-rep-get-fh (unwind-protect (progn (aset session remote-rep-callback (lambda (session output point) (unless remote-rep-len (cond ((= (aref output point) ?\001) ;; success (let ((len (remote-rep-read-length output (1+ point)))) (if len (progn (setq remote-rep-len len) (setq point (+ point 9))) ;; wait for next output (aset session remote-rep-pending-output (substring output point))))) ((= (aref output point) ?\177) ;; failure (let ((msg (remote-rep-read-string output (1+ point)))) (if msg (progn (aset session remote-rep-status 'failure) (aset session remote-rep-error msg)) (aset remote-rep-pending-output (substring output point))))))) (when remote-rep-len (let ((this (min remote-rep-len (- (length output) point)))) (write remote-rep-get-fh (substring output point (+ point this))) (setq remote-rep-len (- remote-rep-len this)) (setq point (+ point this))) (when (zerop remote-rep-len) (aset session remote-rep-status 'success))))) (unwind-protect (remote-rep-command session ?G nil remote-file) (aset session remote-rep-callback nil))) (close-file remote-rep-get-fh))))) (defun remote-rep-put (session local-file remote-file) (unwind-protect (remote-rep-command session ?P (lambda (session) (let ((len (file-size local-file)) (fh (open-file local-file 'read))) (when fh (unwind-protect (progn (remote-rep-send-int session len) (copy-stream fh (aref session remote-rep-process))) (close-file fh))))) remote-file) (remote-rep-invalidate-directory session (file-name-directory remote-file)))) (defun remote-rep-rm (session remote-file) (unwind-protect (remote-rep-command session ?R nil remote-file) (remote-rep-invalidate-directory session (file-name-directory remote-file)))) (defun remote-rep-mv (session old-name new-name) (unwind-protect (remote-rep-command session ?M nil old-name new-name) (remote-rep-invalidate-directory session (file-name-directory old-name)) (remote-rep-invalidate-directory session (file-name-directory new-name)))) (defun remote-rep-rmdir (session remote-dir) (unwind-protect (remote-rep-command session ?r nil remote-dir) (remote-rep-invalidate-directory session (file-name-directory remote-dir)))) (defun remote-rep-mkdir (session remote-dir) (unwind-protect (remote-rep-command session ?m nil remote-dir) (remote-rep-invalidate-directory session (file-name-directory remote-dir)))) (defun remote-rep-chmod (session mode file) (unwind-protect (remote-rep-command session ?c nil file (format nil "%x" mode)) (remote-rep-invalidate-directory session (file-name-directory file)))) (defun remote-rep-make-symlink (session file contents) (unwind-protect (remote-rep-command session ?L nil contents file) (remote-rep-invalidate-directory session (file-name-directory file)))) (defun remote-rep-read-symlink (session file) (let (remote-rep-link) (aset session remote-rep-callback (lambda (session output point) (cond ((= (aref output point) ?\001) ;; success (setq remote-rep-link (remote-rep-read-string output (1+ point))) (if remote-rep-link (aset session remote-rep-status 'success) (aset session remote-rep-pending-output (substring output point)))) ((= (aref output point) ?\177) (let ((msg (remote-rep-read-string output (1+ point)))) (if msg (progn (aset session remote-rep-status 'failure) (aset session remote-rep-error msg)) (aset session remote-rep-pending-output (substring output point)))))))) (unwind-protect (remote-rep-command session ?l nil file) (aset session remote-rep-callback nil)) remote-rep-link)) ;; Directory handling/caching (defconst remote-rep-file-name 0) (defconst remote-rep-file-size 1) (defconst remote-rep-file-modtime 2) (defconst remote-rep-file-type 3) (defconst remote-rep-file-modes 4) (defconst remote-rep-file-mode-string 5) (defconst remote-rep-file-nlinks 6) (defconst remote-rep-file-user 7) (defconst remote-rep-file-group 8) (defconst remote-rep-file-struct-size 9) (defconst remote-rep-cache-dir 0) (defconst remote-rep-cache-expiry 1) (defconst remote-rep-cache-entries 2) (defconst remote-rep-cache-struct-size 3) (defun remote-rep-file-owner-p (session file) (string= (aref session remote-rep-user) (aref file remote-rep-file-user))) (defun remote-rep-dir-cached-p (session dir) (setq dir (directory-file-name dir)) (catch 'exit (mapc (lambda (dir-entry) (when (string= (aref dir-entry remote-rep-cache-dir) dir) (throw 'exit dir-entry))) (aref session remote-rep-dircache)))) (defun remote-rep-get-file (session filename) (let ((dir (file-name-directory filename)) (base (file-name-nondirectory filename)) entry) (when (string= base "") ;; hack, hack (setq base (file-name-nondirectory dir) dir (file-name-directory dir)) (when (string= base "") (setq base "."))) (setq dir (directory-file-name dir)) (setq entry (remote-rep-dir-cached-p session dir)) (if (not (and entry (time-later-p (aref entry remote-rep-cache-expiry) (current-time)))) (progn ;; Cache directory DIR (when entry (aset session remote-rep-dircache (delq entry (aref session remote-rep-dircache))) (setq entry nil)) (remote-rep-while session 'busy 'dircache) (when (>= (length (aref session remote-rep-dircache)) remote-rep-dircache-max-dirs) ;; delete the least-recently-used entry (setcdr (nthcdr (1- (length (aref session remote-rep-dircache))) (aref session remote-rep-dircache)) nil)) ;; add the new (empty) entry for the directory to be read. (setq entry (vector dir (fix-time (cons (car (current-time)) (+ (cdr (current-time)) remote-rep-dircache-expiry-time))) nil)) (aset session remote-rep-dircache (cons entry (aref session remote-rep-dircache))) ;; construct the callback function to have the new cache entry ;; as the first argument (aset session remote-rep-callback (lambda (#!rest args) (apply remote-rep-dircache-callback entry args))) (unwind-protect (condition-case nil (remote-rep-command session ?D nil dir) (file-error)) (aset session remote-rep-callback nil))) ;; entry is still valid, move it to the front of the list (aset session remote-rep-dircache (cons entry (delq entry (aref session remote-rep-dircache))))) ;; ENTRY now has the valid dircache directory structure (catch 'return (mapc (lambda (f) (when (string= (aref f remote-rep-file-name) base) (throw 'return f))) (aref entry remote-rep-cache-entries)) nil))) ;; similar to remote-rep-get-file, but symbolic links are followed (defun remote-rep-lookup-file (session file) (let ((file-struct (remote-rep-get-file session file))) (while (and file-struct (eq (aref file-struct remote-rep-file-type) 'symlink)) (let ((link (remote-rep-read-symlink session file))) (setq file (expand-file-name link (file-name-directory file))) (setq file-struct (remote-rep-get-file session file)))) file-struct)) (defun remote-rep-dircache-callback (cache-entry session output point) (catch 'done (while (string-match "\002" output point) (let* ((start (match-end)) (text (remote-rep-read-string output start)) file-struct) (if text (progn (setq file-struct (read-from-string text)) (unless (vectorp file-struct) (error "file-struct isn't a vector!: %S" file-struct)) (aset cache-entry remote-rep-cache-entries (cons file-struct (aref cache-entry remote-rep-cache-entries))) (setq point (+ start 8 (length text)))) (throw 'done t))))) (when (< point (length output)) (cond ((= (aref output point) ?\001) ;; success marker (aset session remote-rep-status 'success)) ((= (aref output point) ?\177) ;; failure (let ((msg (remote-rep-read-string output (1+ point)))) (if msg (progn (aset session remote-rep-status 'failure) (aset session remote-rep-error msg)) ;; save output for next time (aset session remote-rep-pending-output (substring output point))))) (t ;; some output to save for next time (aset session remote-rep-pending-output (substring output point)))))) (defun remote-rep-invalidate-directory (session directory) (setq directory (directory-file-name directory)) (let ((entry (remote-rep-dir-cached-p session directory))) (when entry (aset session remote-rep-dircache (delq entry (aref session remote-rep-dircache)))))) (defun remote-rep-empty-cache () "Discard all cached rep-remote directory entries." (interactive) (mapc (lambda (ses) (aset ses remote-rep-dircache nil)) remote-rep-sessions)) ;; Password caching (defun remote-rep-get-passwd (user host) (let* ((joined (concat user ?@ host)) (cell (assoc joined remote-rep-passwd-alist))) (if cell (cdr cell) (pwd-prompt (concat "Password for " joined ?:))))) (defun remote-rep-add-passwd (user host passwd) "Add the string PASSWD as the password for rep-remote session of USER@HOST." (interactive "sUsername:\nsHost:\nPassword for %s@%s:") (let ((joined (concat user ?@ host))) (catch 'foo (mapc (lambda (cell) (when (string= (car cell) joined) (setcdr cell passwd) (throw 'foo))) remote-rep-passwd-alist) (setq remote-rep-passwd-alist (cons (cons joined passwd) remote-rep-passwd-alist))))) ;; Backend handler (defun remote-rep-handler (split-name op args) (cond ((eq op 'canonical-file-name) ;; XXX implement this by resolving symlinks (car args)) ((filep (car args)) ;; Operations on file handles (cond ((memq op '(seek-file flush-file write-buffer-contents read-file-contents insert-file-contents)) ;; Just pass these through to the underlying file (apply (symbol-value op) (file-bound-stream (car args)) (cdr args))) ((eq op 'close-file) ;; Close the file, synchronise with the remote file if required (let* ((file (car args)) (data (file-handler-data file)) (session (remote-rep-open-host (nth 1 split-name) (car split-name)))) (close-file (file-bound-stream file)) (when (memq (aref data 1) '(write append)) ;; Copy the local version back to the remote fs (remote-rep-put session (aref data 3) (aref data 2))) (delete-file (aref data 3)))) (t (error "Unsupported rep-remote op on file-handler: %s %s" op args)))) ((memq op '(read-file-contents insert-file-contents copy-file-to-local-fs)) ;; Need to get the file to the local fs (let ((local-name (if (eq op 'copy-file-to-local-fs) (nth 1 args) (make-temp-name))) (session (remote-rep-open-host (nth 1 split-name) (car split-name)))) (remote-rep-get session (nth 2 split-name) local-name) (if (eq op 'copy-file-to-local-fs) (set-file-modes local-name (remote-rep-handler split-name 'file-modes (list (car args)))) (unwind-protect (funcall (symbol-value op) local-name) (delete-file local-name))) t)) ((memq op '(write-buffer-contents copy-file-from-local-fs)) ;; Need to get the file off the local fs (let ((local-name (if (eq op 'copy-file-from-local-fs) (car args) (make-temp-name))) (session (remote-rep-open-host (nth 1 split-name) (car split-name)))) (unless (eq op 'copy-file-from-local-fs) (apply (symbol-value op) local-name (cdr args))) (unwind-protect (remote-rep-put session local-name (nth 2 split-name)) (if (eq op 'copy-file-from-local-fs) (remote-rep-chmod session (file-modes local-name) (nth 2 split-name)) (delete-file local-name))) t)) ((eq op 'copy-file) ;; Copying on the remote fs. ;; XXX For intra-session remote copies use the rep-remote copy command (let ((local-file (make-temp-name)) (dest-split (remote-split-filename (nth 1 args)))) (unwind-protect (and (remote-rep-handler split-name 'copy-file-to-local-fs (list (car args) local-file)) (remote-rep-handler dest-split 'copy-file-from-local-fs (list local-file (nth 1 args)))) (and (file-exists-p local-file) (delete-file local-file))))) ((eq op 'rename-file) (let ((session (remote-rep-open-host (nth 1 split-name) (car split-name))) (dest-split (remote-split-filename (nth 1 args)))) (or (and (string= (car dest-split) (car split-name)) (string= (nth 1 dest-split) (nth 1 split-name))) (error "Can't rename files across rep sessions")) (remote-rep-mv session (nth 2 split-name) (nth 2 dest-split)))) (t ;; All functions taking a single argument (let ((session (remote-rep-open-host (nth 1 split-name) (car split-name))) (file-name (nth 2 split-name))) (cond ((eq op 'directory-files) (let ;; XXX this assumes local/remote have same naming structure! ((dir (file-name-as-directory file-name))) (remote-rep-lookup-file session dir) (mapcar (lambda (f) (aref f remote-rep-file-name)) (aref (remote-rep-dir-cached-p session dir) remote-rep-cache-entries)))) ((eq op 'delete-file) (remote-rep-rm session file-name)) ((eq op 'delete-directory) (remote-rep-rmdir session file-name)) ((eq op 'make-directory) (remote-rep-mkdir session file-name)) ((eq op 'set-file-modes) (remote-rep-chmod session (nth 1 args) file-name)) ((eq op 'make-symlink) (remote-rep-make-symlink session file-name (nth 1 args))) ((eq op 'read-symlink) (remote-rep-read-symlink session file-name)) ((eq op 'open-file) (let ((type (nth 1 args)) (local-file (make-temp-name)) local-fh) (when (memq type '(read append)) ;; Need to transfer the file initially (remote-rep-get session file-name local-file)) ;; Open the local file (setq local-fh (make-file-from-stream (car args) (open-file local-file type) 'remote-file-handler)) (set-file-handler-data local-fh (vector remote-rep-handler type ;access type file-name ;remote name local-file)) ;local copy (remote-register-file-handle local-fh) local-fh)) (t (let ((file (if (eq op 'file-symlink-p) (remote-rep-get-file session file-name) (remote-rep-lookup-file session file-name)))) (cond ((eq op 'file-exists-p) file) ((eq op 'file-regular-p) (and file (eq (aref file remote-rep-file-type) 'file))) ((eq op 'file-directory-p) (and file (eq (aref file remote-rep-file-type) 'directory))) ((eq op 'file-symlink-p) (and file (eq (aref file remote-rep-file-type) 'symlink))) ((eq op 'file-size) (and file (aref file remote-rep-file-size))) ((eq op 'file-modes) (and file (aref file remote-rep-file-modes))) ((eq op 'file-modes-as-string) (and file (aref file remote-rep-file-mode-string))) ((eq op 'file-nlinks) (and file (aref file remote-rep-file-nlinks))) ((eq op 'file-modtime) (if file (aref file remote-rep-file-modtime) (cons 0 0))) ((eq op 'file-owner-p) (and file (remote-rep-file-owner-p session file))) ((eq op 'file-readable-p) (and file (/= (logand (aref file remote-rep-file-modes) (if (remote-rep-file-owner-p session file) #o400 #o004)) 0))) ((eq op 'file-writable-p) (and file (/= (logand (aref file remote-rep-file-modes) (if (remote-rep-file-owner-p session file) #o200 #o002)) 0))) (t (error "Unsupported rep-remote op: %s %s" op args)))))))))) ;;;###autoload (put 'rep 'remote-backend 'remote-rep-handler) ;;;###autoload (autoload-file-handler 'remote-rep-handler 'rep.io.file-handlers.remote.rep) (define-file-handler 'remote-rep-handler remote-rep-handler)) librep-0.90.2/lisp/rep/io/file-handlers/remote/rcp.jl0000644000175200017520000000657111245011153021356 0ustar chrischris;;;; remote.jl -- Remote file access ;;; Copyright (C) 1998 John Harper ;;; $Id$ ;;; This file is part of Jade. ;;; Jade is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2, or (at your option) ;;; any later version. ;;; Jade is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; You should have received a copy of the GNU General Public License ;;; along with Jade; see the file COPYING. If not, write to ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (declare (unsafe-for-call/cc)) (define-structure rep.io.file-handlers.remote.rcp () (open rep rep.system rep.io.processes rep.io.files rep.io.file-handlers rep.io.file-handlers.remote.utils) ;; Notes: ;; Don't use this. It needs a lot of work. Use the FTP backend instead. ;; Configuration: (defvar rcp-program "rcp" "The name of the `rcp' program used to copy files from host to host.") ;; Code: (defun remote-rcp-command (#!rest args) (message (format nil "Calling rcp with args: %s... " args) t) (let ((status (apply call-process nil nil rcp-program args))) (write t "done") (or (zerop status) (error "Couldn't run rcp with args: %s" args)))) (defun remote-rcp-filename (split) (concat (and (car split) (concat (car split) ?@)) (nth 1 split) ?: (nth 2 split))) (defun remote-rcp-handler (split-name op args) (cond ((eq op 'canonical-file-name) (car args)) ((memq op '(read-file-contents insert-file-contents copy-to-local-fs)) ;; Need to get the file to the local fs (let ((local-name (if (eq op 'copy-to-local-fs) (car args) (make-temp-name)))) (remote-rcp-command (remote-rcp-filename split-name) local-name) (when (memq op '(read-file-contents insert-file-contents)) (unwind-protect (funcall (symbol-value op) local-name) (delete-file local-name))) t)) ((memq op '(write-buffer-contents copy-from-local-fs)) ;; Need to get the file off the local fs (let ((local-name (if (eq op 'copy-from-local-fs) (car args) (make-temp-name)))) (when (eq op 'write-buffer-contents) (apply (symbol-value op) local-name (cdr args))) (unwind-protect (remote-rcp-command local-name (remote-rcp-filename split-name)) (when (eq op 'write-buffer-contents) (delete-file local-name))) t)) ;; This is where the laziness sets in... ((memq op '(file-exists-p file-regular-p file-readable-p file-writable-p owner-p)) t) ((memq op '(file-directory-p file-symlink-p set-file-modes delete-file rename-file copy-file)) nil) ((eq op 'file-nlinks) 1) ((eq op 'file-size) 0) ((eq op 'file-modes) #o644) ((eq op 'file-modes-as-string) (make-string 10 ?*)) ((eq op 'file-modtime) (cons 0 0)) ((eq op 'directory-files) nil) (t (error "Unsupported remote-rcp op: %s %s" op args)))) ;;;###autoload (put 'rcp 'remote-backend 'remote-rcp-handler) ;;;###autoload (autoload-file-handler 'remote-rcp-handler 'rep.io.file-handelrs.remote.rcp) (define-file-handler 'remote-rcp-handler remote-rcp-handler)) librep-0.90.2/lisp/rep/io/file-handlers/remote/ftp.jl0000644000175200017520000007422011245011153021357 0ustar chrischris;;;; remote-ftp.jl -- Remote file access via FTP ;;; Copyright (C) 1998 John Harper ;;; $Id$ ;;; This file is part of Jade. ;;; Jade is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2, or (at your option) ;;; any later version. ;;; Jade is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; You should have received a copy of the GNU General Public License ;;; along with Jade; see the file COPYING. If not, write to ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;; TODO: ;; - Allow file transfer mode (binary/ascii) to be determined by ;; matching files against regexp(s) ;; - Fix all the kludges marked by XXX (declare (unsafe-for-call/cc)) (define-structure rep.io.file-handlers.remote.ftp (export remote-ftp-close-host remote-ftp-close-all remote-ftp-empty-cache remote-ftp-add-passwd) (open rep rep.regexp rep.system rep.io.files rep.io.processes rep.io.file-handlers rep.io.file-handlers.remote.utils rep.util.date rep.mail.addr) (define-structure-alias remote-ftp rep.io.file-handlers.remote.ftp) ;; Configuration: (defvar ftp-program "ftp" "Program used for FTP sessions.") (defvar remote-ftp-args '("-v" "-n" "-i" "-g") "List of arguments to remote FTP sessions.") (defvar remote-ftp-show-messages t "When t, informational messages from FTP sessions are displayed.") (defvar remote-ftp-max-message-lines nil "When true, the maximum number of FTP message lines to keep.") (defvar remote-ftp-timeout 30 "Number of seconds to wait for FTP output before giving up.") (defvar remote-ftp-max-sessions 5 "If true, the maximum number of FTP clients that may be running concurrently.") (defvar remote-ftp-anon-users "anonymous|ftp" "Regular expression matching user names of `anonymous' FTP sessions.") (defvar remote-ftp-anon-passwd user-mail-address "Password sent to anonymous FTP sessions.") ;; XXX Allow this to be set by filename? (defvar remote-ftp-transfer-type 'binary "Mode in which to transfer files, one of the symbols `binary' or `ascii'.") (defvar remote-ftp-display-progress nil "When true, show progress of FTP transfers.") (defvar remote-ftp-echo-output nil "When t, echo all output from FTP processes. Use for debugging only.") (defvar remote-ftp-passwd-alist nil "Alist of (USER@HOST . PASSWD) defining all known FTP passwords.") (defvar remote-ftp-ls-format "ls \"-la %s\"" "FTP command format string to produce an `ls -l' format listing of the directory substituted for the single %s format specifier.") (defvar remote-ftp-dircache-expiry-time 360 "Number of seconds before a dircache entry is reread.") (defvar remote-ftp-dircache-max-dirs 5 "Maximum number of directories whose contents may be cached at any one time.") (defvar remote-ftp-sessions nil "List of FTP structures defining all running FTP sessions.") ;; Output templates, mostly copied from ange-ftp..! (defvar remote-ftp-prompt-regexp "([Ff]tp> *)+" "Regular expression matching a prompt from the FTP command (to be ignored).") (defvar remote-ftp-multi-msgs "220-|230-|226|25.-|221-|200-|331-|4[25]1-|530-" "Regular expression matching the start of a multiline ftp reply.") (defvar remote-ftp-good-msgs "220 |230 |226 |25. |221 |200 |[Hh]ash mark" "Regular expression matching ftp \"success\" messages.") (defvar remote-ftp-bad-msgs (concat "55. |500 |530 |\\?Invalid command" "|([a-zA-Z0-9.-]+: )?[Uu]nknown host|ftp: ") "Regular expression matching ftp \"failure\" messages.") (defvar remote-ftp-skip-msgs (concat "200 (PORT|Port) |331 |150 |350 |[0-9]+ bytes |" "Connected |$|Remote system|Using| |" "Data connection |" "local:|Trying|125 |550-|221 .*oodbye") "Regular expression matching ftp messages that can be ignored.") (defvar remote-ftp-reconnect-msgs (concat "Not connected|4[25]1 |rcmd: |" "No control connection|" "lost connection") "Regular expression matching ftp messages that indicate that the current FTP process should be abandoned, and a new session started.") (defvar remote-ftp-passwd-msgs "[Pp]assword: *" "Regular expression matching password prompt.") (defvar remote-ftp-ls-l-regexp "([a-zA-Z-]+)\\s+(\\d+)\\s+(\\w+)\\s+(\\w+)\\s+(\\d+)\\s+([a-zA-Z]+\\s+\\d+\\s+[0-9:]+)\\s+([^/ \t\n]+)" "Regexp defining `ls -l' output syntax. Hairy.") (defvar remote-ftp-ls-l-type-alist '((?- . file) (?d . directory) (?l . symlink) (?p . pipe) (?s . socket) (?b . device) (?c . device)) "Alist associating characters in the first column of `ls -l' output with file types.") ;; ftp structure (defconst remote-ftp-host 0) (defconst remote-ftp-user 1) (defconst remote-ftp-process 2) (defconst remote-ftp-status 3) ;success,failure,busy,nil,dying,timed-out (defconst remote-ftp-callback 4) (defconst remote-ftp-dircache 5) (defconst remote-ftp-pending-output 6) (defconst remote-ftp-login-data 7) ;PASSWD while logging in (defconst remote-ftp-struct-size 8) (defmacro remote-ftp-status-p (session stat) `(eq (aref ,session remote-ftp-status) ,stat)) ;; Return an ftp structure for HOST and USER, with a running ftp session (defun remote-ftp-open-host (host #!optional user) (unless user (setq user (remote-get-user host))) (catch 'foo (mapc (lambda (s) (when (and (string= (aref s remote-ftp-host) host) (string= (aref s remote-ftp-user) user)) ;; Move S to the head of the list (setq remote-ftp-sessions (cons s (delq s remote-ftp-sessions))) (throw 'foo s))) remote-ftp-sessions) ;; Create a new session (let* ((session (make-vector remote-ftp-struct-size))) (aset session remote-ftp-host host) (aset session remote-ftp-user user) (remote-ftp-open-session session)))) (defun remote-ftp-open-session (session) (let ((process (make-process (lambda (data) (remote-ftp-output-filter session data)) remote-ftp-sentinel nil ftp-program (append remote-ftp-args (list (aref session remote-ftp-host)))))) (when (and remote-ftp-max-sessions (> (length remote-ftp-sessions) remote-ftp-max-sessions)) ;; Kill the session last used the earliest (remote-ftp-close-session (last remote-ftp-sessions))) (set-process-connection-type process 'pty) (aset session remote-ftp-process process) (aset session remote-ftp-status 'busy) (or (start-process process) (error "Can't start FTP session")) (setq remote-ftp-sessions (cons session remote-ftp-sessions)) (condition-case data (progn (remote-ftp-connect session) (remote-ftp-login session)) (error (remote-ftp-close-session session) (signal (car data) (cdr data)))) session)) (defun remote-ftp-close-session (session) (when (and (aref session remote-ftp-process) (process-in-use-p (aref session remote-ftp-process))) (aset session remote-ftp-status 'dying) (set-process-output-stream (aref session remote-ftp-process) nil) (set-process-error-stream (aref session remote-ftp-process) nil) (kill-process (aref session remote-ftp-process)))) (defun remote-ftp-close-host (host #!optional user) "Close the FTP subprocess connect to `USER@HOST'." (interactive "sHost:\nsUser:") (when (or (null user) (string= user "")) (setq user (remote-get-user host))) (catch 'foo (mapc (lambda (s) (when (and (string= (aref s remote-ftp-host) host) (string= (aref s remote-ftp-user) user)) (remote-ftp-close-session s) (throw 'foo t))) remote-ftp-sessions))) (defun remote-ftp-close-all () "Close all running FTP subprocesses." (interactive) (mapc remote-ftp-close-session remote-ftp-sessions)) (defun remote-ftp-get-session-by-process (process) (catch 'return (mapc (lambda (s) (and (eq (aref s remote-ftp-process) process) (throw 'return s))) remote-ftp-sessions))) ;; Communicating with ftp sessions (defun remote-ftp-write (session fmt arg-list) (when (remote-ftp-status-p session 'dying) (error "FTP session is dying")) (apply format (aref session remote-ftp-process) fmt arg-list) (write (aref session remote-ftp-process) ?\n) (aset session remote-ftp-status 'busy)) (defun remote-ftp-while (session status #!optional type) (when (and (not (eq status 'dying)) (remote-ftp-status-p session 'dying)) (error "FTP session is dying")) (while (remote-ftp-status-p session status) (when (and (process-running-p (aref session remote-ftp-process)) (accept-process-output remote-ftp-timeout)) (aset session remote-ftp-status 'timed-out) (error "FTP process timed out (%s)" (or type "unknown"))))) (defun remote-ftp-command (session type fmt #!rest args) (let ((retry t)) (while retry (setq retry nil) (condition-case data (progn (when remote-ftp-display-progress (message (format nil "FTP %s: " type) t)) (remote-ftp-while session 'busy type) (remote-ftp-write session fmt args) (remote-ftp-while session 'busy type) (when remote-ftp-display-progress (format t " %s" (aref session remote-ftp-status)))) (error (when (and (stringp (nth 1 data)) (string-match "transient error" (nth 1 data)) (not (eq type 'login))) ;; The session has been killed. Wait for it to die ;; totally then try to reconnect (message (format nil "FTP: reconnecting to `%s'...\n" (aref session remote-ftp-host))) (remote-ftp-while session 'dying type) (remote-ftp-open-session session) (setq retry t))))) (remote-ftp-error-if-unsuccessful session fmt args))) ;; Return t if successful, else signal a file-error (defun remote-ftp-error-if-unsuccessful (session #!optional fmt args) (or (eq (aref session remote-ftp-status) 'success) (signal 'file-error (list 'ftp (format nil "%s@%s" (aref session remote-ftp-user) (aref session remote-ftp-host)) (and fmt (apply format nil fmt args)))))) (defun remote-ftp-output-filter (session output) (when remote-ftp-echo-output (let ((print-escape t)) (format (stderr-file) "FTP output: %S\n" output))) (when (aref session remote-ftp-pending-output) (setq output (concat (aref session remote-ftp-pending-output) output)) (aset session remote-ftp-pending-output nil)) (let ((point 0) line-end) (while (< point (length output)) ;; Skip any prompts (when (string-looking-at remote-ftp-prompt-regexp output point) (setq point (match-end))) ;; Look for `#' progress characters (when (string-looking-at "#+" output point) (setq point (match-end)) (when remote-ftp-display-progress (write t (substring output (match-start) (match-end))) (when (featurep 'jade) (declare (bound redisplay)) (redisplay)))) (if (string-looking-at remote-ftp-passwd-msgs output point) ;; Send password (progn (remote-ftp-write session "%s\n" (list (if (string-match remote-ftp-anon-users (aref session remote-ftp-user)) remote-ftp-anon-passwd (let ((pass (remote-ftp-get-passwd (aref session remote-ftp-user) (aref session remote-ftp-host) (aref session remote-ftp-login-data)))) (unless pass (remote-ftp-close-session session) (error "No valid password")) (aset session remote-ftp-login-data pass) pass)))) ;; Can't be anything more? (setq point (length output))) (if (string-match "\n" output point) (progn ;; At least one whole line (setq line-end (match-end)) (cond ((string-looking-at remote-ftp-skip-msgs output point) ;; Ignore this line of output (setq point line-end)) ((string-looking-at remote-ftp-good-msgs output point) ;; Success! (aset session remote-ftp-status 'success) (setq point line-end)) ((string-looking-at remote-ftp-bad-msgs output point) ;; Failure! (aset session remote-ftp-status 'failure) (setq point line-end)) ((string-looking-at remote-ftp-multi-msgs output point) ;; One line of a multi-line message (remote-ftp-show-multi output point line-end) (setq point line-end)) ((string-looking-at remote-ftp-reconnect-msgs output point) ;; Transient error. Kill the session, then try to reopen it (remote-ftp-close-session session) (error "FTP process had transient error")) (t ;; Hmm. something else. If one exists invoke the callback (when (aref session remote-ftp-callback) (funcall (aref session remote-ftp-callback) session output point line-end)) (setq point line-end)))) ;; A partial line. Store it as pending (aset session remote-ftp-pending-output (substring output point)) (setq point (length output))))))) (defun remote-ftp-sentinel (process) (let ((session (remote-ftp-get-session-by-process process))) (unless (process-in-use-p process) (aset session remote-ftp-process nil) (aset session remote-ftp-dircache nil) (aset session remote-ftp-status nil) (aset session remote-ftp-pending-output nil) (aset session remote-ftp-callback nil) (setq remote-ftp-sessions (delq session remote-ftp-sessions))))) (defun remote-ftp-show-multi (string start end) (if (featurep 'jade) (progn (declare (bound open-buffer goto end-of-buffer insert pos-line delete-area start-of-buffer backward-line goto-buffer other-view shrink-view-if-larger-than-buffer)) (let ((buffer (open-buffer "*ftp messages*"))) (with-object buffer (goto (end-of-buffer)) (insert (substring string start end)) (when (and remote-ftp-max-message-lines (> (pos-line (end-of-buffer)) remote-ftp-max-message-lines)) (delete-area (start-of-buffer) (backward-line remote-ftp-max-message-lines (end-of-buffer))))) (when remote-ftp-show-messages (with-object (other-view) (goto-buffer buffer) (shrink-view-if-larger-than-buffer))))) (when remote-ftp-show-messages (write standard-output (substring string start end))))) ;; FTP commands ;; SESSION has been started, wait for the connection to ;; succeed or fail (defun remote-ftp-connect (session) (remote-ftp-while session 'busy 'connect) (remote-ftp-error-if-unsuccessful session "connect")) ;; Starts the process structure already defined in SESSION, then ;; logs in as the named user (defun remote-ftp-login (session) (and (remote-ftp-command session 'login "user %s" (aref session remote-ftp-user)) (when (stringp (aref session remote-ftp-login-data)) ;; The password for this session. It seemed successful ;; so store for later use (remote-ftp-add-passwd (aref session remote-ftp-user) (aref session remote-ftp-host) (aref session remote-ftp-login-data)) (aset session remote-ftp-login-data nil)) (remote-ftp-command session 'login "type %s" remote-ftp-transfer-type) ;; For testing the reconnection-on-idle ;(setq remote-ftp-echo-output t) ;(remote-ftp-command session 'login "quote site idle 30") (and remote-ftp-display-progress (remote-ftp-command session 'login "hash")))) (defun remote-ftp-get (session remote-file local-file) (remote-ftp-command session 'get "get %s %s" remote-file local-file)) (defun remote-ftp-put (session local-file remote-file) (unwind-protect (remote-ftp-command session 'put "put %s %s" local-file remote-file) (remote-ftp-invalidate-directory session (file-name-directory remote-file)))) (defun remote-ftp-rm (session remote-file) (unwind-protect (remote-ftp-command session 'rm "delete %s" remote-file) (remote-ftp-invalidate-directory session (file-name-directory remote-file)))) (defun remote-ftp-mv (session old-name new-name) (unwind-protect (remote-ftp-command session 'mv "rename %s %s" old-name new-name) (remote-ftp-invalidate-directory session (file-name-directory old-name)) (remote-ftp-invalidate-directory session (file-name-directory new-name)))) (defun remote-ftp-rmdir (session remote-dir) (unwind-protect (remote-ftp-command session 'rmdir "rmdir %s" remote-dir) (remote-ftp-invalidate-directory session (file-name-directory remote-dir)))) (defun remote-ftp-mkdir (session remote-dir) (unwind-protect (remote-ftp-command session 'mkdir "mkdir %s" remote-dir) (remote-ftp-invalidate-directory session (file-name-directory remote-dir)))) (defun remote-ftp-chmod (session mode file) ;; XXX Some FTP clients (i.e. Solaris 2.6) don't have the ;; XXX chmod command. Perhaps we could use "quote site chmod .." ;; XXX but the Solaris ftpd doesn't support this either.. (unwind-protect (condition-case nil (remote-ftp-command session 'chmod "quote site chmod %o %s" mode file) (file-error ;; Assume the chmod failed (message (format nil "Warning: `chmod %o %s@%s:file' failed" mode (aref session remote-ftp-user) (aref session remote-ftp-host) file) t) nil)) (remote-ftp-invalidate-directory session (file-name-directory file)))) ;; Directory handling/caching (defconst remote-ftp-file-name 0) (defconst remote-ftp-file-size 1) (defconst remote-ftp-file-modtime 2) ;may be an unparsed string (defconst remote-ftp-file-type 3) (defconst remote-ftp-file-modes 4) ;nil if mode-string needs parsing (defconst remote-ftp-file-mode-string 5) (defconst remote-ftp-file-nlinks 6) (defconst remote-ftp-file-user 7) (defconst remote-ftp-file-group 8) (defconst remote-ftp-file-symlink 9) (defconst remote-ftp-file-struct-size 10) (defconst remote-ftp-cache-dir 0) (defconst remote-ftp-cache-expiry 1) (defconst remote-ftp-cache-entries 2) (defconst remote-ftp-cache-struct-size 3) (defun remote-ftp-parse-ls-l (string point) (when (string-looking-at remote-ftp-ls-l-regexp string point) (let ((mode-string (substring string (match-start 1) (match-end 1))) (nlinks (string->number (substring string (match-start 2) (match-end 2)))) (user (substring string (match-start 3) (match-end 3))) (group (substring string (match-start 4) (match-end 4))) (size (string->number (substring string (match-start 5) (match-end 5)))) (modtime (substring string (match-start 6) (match-end 6))) (name (substring string (match-start 7) (match-end 7))) symlink) (when (string-match ".*\\s+->\\s+(\\S+)" string point) (setq symlink (substring string (match-start 1) (match-end 1)))) (vector name size modtime (cdr (assq (aref mode-string 0) remote-ftp-ls-l-type-alist)) nil mode-string nlinks user group symlink)))) (defun remote-ftp-file-get-modtime (file-struct) (when (stringp (aref file-struct remote-ftp-file-modtime)) (let ((date (parse-date (aref file-struct remote-ftp-file-modtime)))) (when date (aset file-struct remote-ftp-file-modtime (aref date date-vec-epoch-time))))) (aref file-struct remote-ftp-file-modtime)) (defun remote-ftp-file-get-modes (file-struct) (unless (aref file-struct remote-ftp-file-modes) (let* ((string (aref file-struct remote-ftp-file-mode-string)) (tuple-function (lambda (point tuple) (+ (ash (+ (if (/= (aref string point) ?-) 4 0) (if (/= (aref string (1+ point)) ?-) 2 0) (if (lower-case-p (aref string (+ point 2))) 1 0)) (* tuple 3)) (if (memq (aref string (+ point 2)) '(?s ?S ?t ?T)) (ash #o1000 tuple) 0))))) (aset file-struct remote-ftp-file-modes (+ (tuple-function 1 2) (tuple-function 4 1) (tuple-function 7 0))))) (aref file-struct remote-ftp-file-modes)) (defun remote-ftp-file-owner-p (session file) (string= (aref session remote-ftp-user) (aref file remote-ftp-file-user))) (defun remote-ftp-dir-cached-p (session dir) (setq dir (directory-file-name dir)) (catch 'exit (mapc (lambda (dir-entry) (when (string= (aref dir-entry remote-ftp-cache-dir) dir) (throw 'exit dir-entry))) (aref session remote-ftp-dircache)))) (defun remote-ftp-get-file (session filename) (let ((dir (file-name-directory filename)) (base (file-name-nondirectory filename)) entry) (when (string= base "") ;; hack, hack (setq base (file-name-nondirectory dir) dir (file-name-directory dir)) (when (string= base "") (setq base "."))) (setq dir (directory-file-name dir)) (setq entry (remote-ftp-dir-cached-p session dir)) (if (not (and entry (time-later-p (aref entry remote-ftp-cache-expiry) (current-time)))) (progn ;; Cache directory DIR (when entry (aset session remote-ftp-dircache (delq entry (aref session remote-ftp-dircache))) (setq entry nil)) (remote-ftp-while session 'busy 'dircache) (when (>= (length (aref session remote-ftp-dircache)) remote-ftp-dircache-max-dirs) ;; delete the least-recently-used entry (setcdr (nthcdr (1- (length (aref session remote-ftp-dircache))) (aref session remote-ftp-dircache)) nil)) ;; add the new (empty) entry for the directory to be read. (setq entry (vector dir (fix-time (cons (car (current-time)) (+ (cdr (current-time)) remote-ftp-dircache-expiry-time))) nil)) (aset session remote-ftp-dircache (cons entry (aref session remote-ftp-dircache))) ;; construct the callback function to have the new cache entry ;; as the first argument (aset session remote-ftp-callback (lambda (#!rest args) (apply (lambda (cache-entry session output point line-end) (declare (unused session line-end)) (let ((file-struct (remote-ftp-parse-ls-l output point))) (when file-struct (aset cache-entry remote-ftp-cache-entries (cons file-struct (aref cache-entry remote-ftp-cache-entries)))))) entry args))) ;; my ftp server (wu-2.6.0(1)) doesn't like being told to ;; `ls .' -- it recursively lists the top-level directories (if (string= dir ".") (remote-ftp-command session 'dircache "ls -la") (remote-ftp-command session 'dircache remote-ftp-ls-format dir)) (aset session remote-ftp-callback nil)) ;; entry is still valid, move it to the front of the list (aset session remote-ftp-dircache (cons entry (delq entry (aref session remote-ftp-dircache))))) ;; ENTRY now has the valid dircache directory structure (catch 'return (mapc (lambda (f) (when (string= (aref f remote-ftp-file-name) base) (throw 'return f))) (aref entry remote-ftp-cache-entries))))) ;; similar to remote-ftp-get-file, but symbolic links are followed (defun remote-ftp-lookup-file (session file) (let ((file-struct (remote-ftp-get-file session file))) (while (and file-struct (eq (aref file-struct remote-ftp-file-type) 'symlink)) (let ((link (aref file-struct remote-ftp-file-symlink))) (setq file (expand-file-name link (file-name-directory file))) (setq file-struct (remote-ftp-get-file session file)))) file-struct)) (defun remote-ftp-invalidate-directory (session directory) (setq directory (directory-file-name directory)) (let ((entry (remote-ftp-dir-cached-p session directory))) (when entry (aset session remote-ftp-dircache (delq entry (aref session remote-ftp-dircache)))))) (defun remote-ftp-empty-cache () "Discard all cached FTP directory entries." (interactive) (mapc (lambda (ses) (aset ses remote-ftp-dircache nil)) remote-ftp-sessions)) ;; Password caching (defun remote-ftp-get-passwd (user host #!optional retrying) (let* ((joined (concat user ?@ host)) (cell (assoc joined remote-ftp-passwd-alist))) (if cell (cdr cell) (pwd-prompt (concat (if retrying "Try again; p" ?P) "assword for " joined ?:))))) (defun remote-ftp-add-passwd (user host passwd) "Add the string PASSWD as the password for FTP session of USER@HOST." (interactive "sUsername:\nsHost:\nPassword for %s@%s:") (let ((joined (concat user ?@ host))) (catch 'foo (mapc (lambda (cell) (when (string= (car cell) joined) (setcdr cell passwd) (throw 'foo))) remote-ftp-passwd-alist) (setq remote-ftp-passwd-alist (cons (cons joined passwd) remote-ftp-passwd-alist))))) ;; Backend handler (defun remote-ftp-handler (split-name op args) (cond ((eq op 'canonical-file-name) ;; XXX implement this by resolving symlinks (car args)) ((filep (car args)) ;; Operations on file handles (cond ((memq op '(seek-file flush-file write-buffer-contents read-file-contents insert-file-contents)) ;; Just pass these through to the underlying file (apply (symbol-value op) (file-bound-stream (car args)) (cdr args))) ((eq op 'close-file) ;; Close the file, synchronise with the remote file if required (let* ((file (car args)) (data (file-handler-data file)) (session (remote-ftp-open-host (nth 1 split-name) (car split-name)))) (close-file (file-bound-stream file)) (when (memq (aref data 1) '(write append)) ;; Copy the local version back to the remote fs (remote-ftp-put session (aref data 3) (aref data 2))) (delete-file (aref data 3)))) (t (error "Unsupported FTP op on file-handler: %s %s" op args)))) ((memq op '(read-file-contents insert-file-contents copy-file-to-local-fs)) ;; Need to get the file to the local fs (let ((local-name (if (eq op 'copy-file-to-local-fs) (nth 1 args) (make-temp-name))) (session (remote-ftp-open-host (nth 1 split-name) (car split-name)))) (remote-ftp-get session (nth 2 split-name) local-name) (unless (eq op 'copy-file-to-local-fs) (unwind-protect (funcall (symbol-value op) local-name) (delete-file local-name))) t)) ((memq op '(write-buffer-contents copy-file-from-local-fs)) ;; Need to get the file off the local fs (let ((local-name (if (eq op 'copy-file-from-local-fs) (car args) (make-temp-name))) (session (remote-ftp-open-host (nth 1 split-name) (car split-name)))) (unless (eq op 'copy-file-from-local-fs) (apply (symbol-value op) local-name (cdr args))) (unwind-protect (remote-ftp-put session local-name (nth 2 split-name)) (unless (eq op 'copy-file-from-local-fs) (delete-file local-name))) t)) ((eq op 'copy-file) ;; Copying on the remote fs. ;; XXX Is there a way to avoid the double transfer? ;; XXX Not for inter-session copies, anyway. (let ((local-file (make-temp-name)) (dest-split (remote-split-filename (nth 1 args)))) (unwind-protect (and (remote-ftp-handler split-name 'copy-file-to-local-fs (list (car args) local-file)) (remote-ftp-handler dest-split 'copy-file-from-local-fs (list local-file (nth 1 args)))) (and (file-exists-p local-file) (delete-file local-file))))) ((eq op 'rename-file) (let ((session (remote-ftp-open-host (nth 1 split-name) (car split-name))) (dest-split (remote-split-filename (nth 1 args)))) (or (and (string= (car dest-split) (car split-name)) (string= (nth 1 dest-split) (nth 1 split-name))) (error "Can't rename files across FTP sessions")) (remote-ftp-mv session (nth 2 split-name) (nth 2 dest-split)))) (t ;; All functions taking a single argument (let ((session (remote-ftp-open-host (nth 1 split-name) (car split-name))) (file-name (nth 2 split-name))) (cond ((eq op 'directory-files) (let ;; XXX this assumes local/remote have same naming structure! ((dir (file-name-as-directory file-name))) (remote-ftp-lookup-file session dir) (mapcar (lambda (f) (aref f remote-ftp-file-name)) (aref (remote-ftp-dir-cached-p session dir) remote-ftp-cache-entries)))) ((eq op 'delete-file) (remote-ftp-rm session file-name)) ((eq op 'delete-directory) (remote-ftp-rmdir session file-name)) ((eq op 'make-directory) (remote-ftp-mkdir session file-name)) ((eq op 'set-file-modes) (remote-ftp-chmod session (nth 1 args) file-name)) ((eq op 'open-file) (let ((type (nth 1 args)) (local-file (make-temp-name)) local-fh) (when (memq type '(read append)) ;; Need to transfer the file initially (remote-ftp-get session file-name local-file)) ;; Open the local file (setq local-fh (make-file-from-stream (car args) (open-file local-file type) 'remote-file-handler)) (set-file-handler-data local-fh (vector remote-ftp-handler type ;access type file-name ;remote name local-file)) ;local copy (remote-register-file-handle local-fh) local-fh)) (t (let ((file (if (eq op 'file-symlink-p) (remote-ftp-get-file session file-name) (remote-ftp-lookup-file session file-name)))) (cond ((eq op 'file-exists-p) file) ((eq op 'file-regular-p) (and file (eq (aref file remote-ftp-file-type) 'file))) ((eq op 'file-directory-p) (and file (eq (aref file remote-ftp-file-type) 'directory))) ((eq op 'file-symlink-p) (and file (eq (aref file remote-ftp-file-type) 'symlink))) ((eq op 'file-size) (and file (aref file remote-ftp-file-size))) ((eq op 'file-modes) (and file (remote-ftp-file-get-modes file))) ((eq op 'file-modes-as-string) (and file (aref file remote-ftp-file-mode-string))) ((eq op 'file-nlinks) (and file (aref file remote-ftp-file-nlinks))) ((eq op 'file-modtime) (if file (remote-ftp-file-get-modtime file) (cons 0 0))) ((eq op 'file-owner-p) (and file (remote-ftp-file-owner-p session file))) ((eq op 'file-readable-p) (and file (/= (logand (remote-ftp-file-get-modes file) (if (remote-ftp-file-owner-p session file) #o400 #o004)) 0))) ((eq op 'file-writable-p) (and file (/= (logand (remote-ftp-file-get-modes file) (if (remote-ftp-file-owner-p session file) #o200 #o002)) 0))) ((eq op 'read-symlink) (and file (or (aref file remote-ftp-file-symlink) (signal 'file-error (list "File isn't a symlink:" split-name))))) (t (error "Unsupported FTP op: %s %s" op args)))))))))) ;;;###autoload (put 'ftp 'remote-backend 'remote-ftp-handler) ;;;###autoload (autoload-file-handler 'remote-ftp-handler 'rep.io.file-handlers.remote.ftp) (define-file-handler 'remote-ftp-handler remote-ftp-handler))